1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
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.
11
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.
16
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/>. */
20
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"
31
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)
37
38
39 static bool set_binding_label (const char **, const char *, int);
40
41
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
44
45 static int old_char_selector;
46
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. */
51
52 static gfc_typespec current_ts;
53
54 static symbol_attribute current_attr;
55 static gfc_array_spec *current_as;
56 static int colon_seen;
57 static int attr_seen;
58
59 /* The current binding label (if any). */
60 static const char* curr_binding_label;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals = 0;
67
68 /* Initializer of the previous enumerator. */
69
70 static gfc_expr *last_initializer;
71
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
75
76 typedef struct enumerator_history
77 {
78 gfc_symbol *sym;
79 gfc_expr *initializer;
80 struct enumerator_history *next;
81 }
82 enumerator_history;
83
84 /* Header of enum history chain. */
85
86 static enumerator_history *enum_history = NULL;
87
88 /* Pointer of enum history node containing largest initializer. */
89
90 static enumerator_history *max_enum = NULL;
91
92 /* gfc_new_block points to the symbol of a newly matched block. */
93
94 gfc_symbol *gfc_new_block;
95
96 bool gfc_matching_function;
97
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll = -1;
100
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr *saved_kind_expr = NULL;
104
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist *decl_type_param_list;
108 static gfc_actual_arglist *type_param_spec_list;
109
110 /********************* DATA statement subroutines *********************/
111
112 static bool in_match_data = false;
113
114 bool
gfc_in_match_data(void)115 gfc_in_match_data (void)
116 {
117 return in_match_data;
118 }
119
120 static void
set_in_match_data(bool set_value)121 set_in_match_data (bool set_value)
122 {
123 in_match_data = set_value;
124 }
125
126 /* Free a gfc_data_variable structure and everything beneath it. */
127
128 static void
free_variable(gfc_data_variable * p)129 free_variable (gfc_data_variable *p)
130 {
131 gfc_data_variable *q;
132
133 for (; p; p = q)
134 {
135 q = p->next;
136 gfc_free_expr (p->expr);
137 gfc_free_iterator (&p->iter, 0);
138 free_variable (p->list);
139 free (p);
140 }
141 }
142
143
144 /* Free a gfc_data_value structure and everything beneath it. */
145
146 static void
free_value(gfc_data_value * p)147 free_value (gfc_data_value *p)
148 {
149 gfc_data_value *q;
150
151 for (; p; p = q)
152 {
153 q = p->next;
154 mpz_clear (p->repeat);
155 gfc_free_expr (p->expr);
156 free (p);
157 }
158 }
159
160
161 /* Free a list of gfc_data structures. */
162
163 void
gfc_free_data(gfc_data * p)164 gfc_free_data (gfc_data *p)
165 {
166 gfc_data *q;
167
168 for (; p; p = q)
169 {
170 q = p->next;
171 free_variable (p->var);
172 free_value (p->value);
173 free (p);
174 }
175 }
176
177
178 /* Free all data in a namespace. */
179
180 static void
gfc_free_data_all(gfc_namespace * ns)181 gfc_free_data_all (gfc_namespace *ns)
182 {
183 gfc_data *d;
184
185 for (;ns->data;)
186 {
187 d = ns->data->next;
188 free (ns->data);
189 ns->data = d;
190 }
191 }
192
193 /* Reject data parsed since the last restore point was marked. */
194
195 void
gfc_reject_data(gfc_namespace * ns)196 gfc_reject_data (gfc_namespace *ns)
197 {
198 gfc_data *d;
199
200 while (ns->data && ns->data != ns->old_data)
201 {
202 d = ns->data->next;
203 free (ns->data);
204 ns->data = d;
205 }
206 }
207
208 static match var_element (gfc_data_variable *);
209
210 /* Match a list of variables terminated by an iterator and a right
211 parenthesis. */
212
213 static match
var_list(gfc_data_variable * parent)214 var_list (gfc_data_variable *parent)
215 {
216 gfc_data_variable *tail, var;
217 match m;
218
219 m = var_element (&var);
220 if (m == MATCH_ERROR)
221 return MATCH_ERROR;
222 if (m == MATCH_NO)
223 goto syntax;
224
225 tail = gfc_get_data_variable ();
226 *tail = var;
227
228 parent->list = tail;
229
230 for (;;)
231 {
232 if (gfc_match_char (',') != MATCH_YES)
233 goto syntax;
234
235 m = gfc_match_iterator (&parent->iter, 1);
236 if (m == MATCH_YES)
237 break;
238 if (m == MATCH_ERROR)
239 return MATCH_ERROR;
240
241 m = var_element (&var);
242 if (m == MATCH_ERROR)
243 return MATCH_ERROR;
244 if (m == MATCH_NO)
245 goto syntax;
246
247 tail->next = gfc_get_data_variable ();
248 tail = tail->next;
249
250 *tail = var;
251 }
252
253 if (gfc_match_char (')') != MATCH_YES)
254 goto syntax;
255 return MATCH_YES;
256
257 syntax:
258 gfc_syntax_error (ST_DATA);
259 return MATCH_ERROR;
260 }
261
262
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
265
266 static match
var_element(gfc_data_variable * new_var)267 var_element (gfc_data_variable *new_var)
268 {
269 match m;
270 gfc_symbol *sym;
271
272 memset (new_var, 0, sizeof (gfc_data_variable));
273
274 if (gfc_match_char ('(') == MATCH_YES)
275 return var_list (new_var);
276
277 m = gfc_match_variable (&new_var->expr, 0);
278 if (m != MATCH_YES)
279 return m;
280
281 sym = new_var->expr->symtree->n.sym;
282
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
285 return MATCH_ERROR;
286
287 if (!sym->attr.function && gfc_current_ns->parent
288 && gfc_current_ns->parent == sym->ns)
289 {
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym->name);
292 return MATCH_ERROR;
293 }
294
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym->attr.in_common
297 && !gfc_notify_std (GFC_STD_GNU, "initialization of "
298 "common block variable %qs in DATA statement at %C",
299 sym->name))
300 return MATCH_ERROR;
301
302 if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
303 return MATCH_ERROR;
304
305 return MATCH_YES;
306 }
307
308
309 /* Match the top-level list of data variables. */
310
311 static match
top_var_list(gfc_data * d)312 top_var_list (gfc_data *d)
313 {
314 gfc_data_variable var, *tail, *new_var;
315 match m;
316
317 tail = NULL;
318
319 for (;;)
320 {
321 m = var_element (&var);
322 if (m == MATCH_NO)
323 goto syntax;
324 if (m == MATCH_ERROR)
325 return MATCH_ERROR;
326
327 new_var = gfc_get_data_variable ();
328 *new_var = var;
329
330 if (tail == NULL)
331 d->var = new_var;
332 else
333 tail->next = new_var;
334
335 tail = new_var;
336
337 if (gfc_match_char ('/') == MATCH_YES)
338 break;
339 if (gfc_match_char (',') != MATCH_YES)
340 goto syntax;
341 }
342
343 return MATCH_YES;
344
345 syntax:
346 gfc_syntax_error (ST_DATA);
347 gfc_free_data_all (gfc_current_ns);
348 return MATCH_ERROR;
349 }
350
351
352 static match
match_data_constant(gfc_expr ** result)353 match_data_constant (gfc_expr **result)
354 {
355 char name[GFC_MAX_SYMBOL_LEN + 1];
356 gfc_symbol *sym, *dt_sym = NULL;
357 gfc_expr *expr;
358 match m;
359 locus old_loc;
360
361 m = gfc_match_literal_constant (&expr, 1);
362 if (m == MATCH_YES)
363 {
364 *result = expr;
365 return MATCH_YES;
366 }
367
368 if (m == MATCH_ERROR)
369 return MATCH_ERROR;
370
371 m = gfc_match_null (result);
372 if (m != MATCH_NO)
373 return m;
374
375 old_loc = gfc_current_locus;
376
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m = gfc_match_rvalue (result);
380 if (m == MATCH_ERROR)
381 return m;
382
383 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
384 {
385 if (!gfc_simplify_expr (*result, 0))
386 m = MATCH_ERROR;
387 return m;
388 }
389 else if (m == MATCH_YES)
390 gfc_free_expr (*result);
391
392 gfc_current_locus = old_loc;
393
394 m = gfc_match_name (name);
395 if (m != MATCH_YES)
396 return m;
397
398 if (gfc_find_symbol (name, NULL, 1, &sym))
399 return MATCH_ERROR;
400
401 if (sym && sym->attr.generic)
402 dt_sym = gfc_find_dt_in_generic (sym);
403
404 if (sym == NULL
405 || (sym->attr.flavor != FL_PARAMETER
406 && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
407 {
408 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
409 name);
410 *result = NULL;
411 return MATCH_ERROR;
412 }
413 else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
414 return gfc_match_structure_constructor (dt_sym, result);
415
416 /* Check to see if the value is an initialization array expression. */
417 if (sym->value->expr_type == EXPR_ARRAY)
418 {
419 gfc_current_locus = old_loc;
420
421 m = gfc_match_init_expr (result);
422 if (m == MATCH_ERROR)
423 return m;
424
425 if (m == MATCH_YES)
426 {
427 if (!gfc_simplify_expr (*result, 0))
428 m = MATCH_ERROR;
429
430 if ((*result)->expr_type == EXPR_CONSTANT)
431 return m;
432 else
433 {
434 gfc_error ("Invalid initializer %s in Data statement at %C", name);
435 return MATCH_ERROR;
436 }
437 }
438 }
439
440 *result = gfc_copy_expr (sym->value);
441 return MATCH_YES;
442 }
443
444
445 /* Match a list of values in a DATA statement. The leading '/' has
446 already been seen at this point. */
447
448 static match
top_val_list(gfc_data * data)449 top_val_list (gfc_data *data)
450 {
451 gfc_data_value *new_val, *tail;
452 gfc_expr *expr;
453 match m;
454
455 tail = NULL;
456
457 for (;;)
458 {
459 m = match_data_constant (&expr);
460 if (m == MATCH_NO)
461 goto syntax;
462 if (m == MATCH_ERROR)
463 return MATCH_ERROR;
464
465 new_val = gfc_get_data_value ();
466 mpz_init (new_val->repeat);
467
468 if (tail == NULL)
469 data->value = new_val;
470 else
471 tail->next = new_val;
472
473 tail = new_val;
474
475 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
476 {
477 tail->expr = expr;
478 mpz_set_ui (tail->repeat, 1);
479 }
480 else
481 {
482 mpz_set (tail->repeat, expr->value.integer);
483 gfc_free_expr (expr);
484
485 m = match_data_constant (&tail->expr);
486 if (m == MATCH_NO)
487 goto syntax;
488 if (m == MATCH_ERROR)
489 return MATCH_ERROR;
490 }
491
492 if (gfc_match_char ('/') == MATCH_YES)
493 break;
494 if (gfc_match_char (',') == MATCH_NO)
495 goto syntax;
496 }
497
498 return MATCH_YES;
499
500 syntax:
501 gfc_syntax_error (ST_DATA);
502 gfc_free_data_all (gfc_current_ns);
503 return MATCH_ERROR;
504 }
505
506
507 /* Matches an old style initialization. */
508
509 static match
match_old_style_init(const char * name)510 match_old_style_init (const char *name)
511 {
512 match m;
513 gfc_symtree *st;
514 gfc_symbol *sym;
515 gfc_data *newdata;
516
517 /* Set up data structure to hold initializers. */
518 gfc_find_sym_tree (name, NULL, 0, &st);
519 sym = st->n.sym;
520
521 newdata = gfc_get_data ();
522 newdata->var = gfc_get_data_variable ();
523 newdata->var->expr = gfc_get_variable_expr (st);
524 newdata->var->expr->where = sym->declared_at;
525 newdata->where = gfc_current_locus;
526
527 /* Match initial value list. This also eats the terminal '/'. */
528 m = top_val_list (newdata);
529 if (m != MATCH_YES)
530 {
531 free (newdata);
532 return m;
533 }
534
535 if (gfc_pure (NULL))
536 {
537 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
538 free (newdata);
539 return MATCH_ERROR;
540 }
541 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
542
543 /* Mark the variable as having appeared in a data statement. */
544 if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
545 {
546 free (newdata);
547 return MATCH_ERROR;
548 }
549
550 /* Chain in namespace list of DATA initializers. */
551 newdata->next = gfc_current_ns->data;
552 gfc_current_ns->data = newdata;
553
554 return m;
555 }
556
557
558 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
559 we are matching a DATA statement and are therefore issuing an error
560 if we encounter something unexpected, if not, we're trying to match
561 an old-style initialization expression of the form INTEGER I /2/. */
562
563 match
gfc_match_data(void)564 gfc_match_data (void)
565 {
566 gfc_data *new_data;
567 gfc_expr *e;
568 match m;
569
570 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
571 if ((gfc_current_state () == COMP_FUNCTION
572 || gfc_current_state () == COMP_SUBROUTINE)
573 && gfc_state_stack->previous->state == COMP_INTERFACE)
574 {
575 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
576 return MATCH_ERROR;
577 }
578
579 set_in_match_data (true);
580
581 for (;;)
582 {
583 new_data = gfc_get_data ();
584 new_data->where = gfc_current_locus;
585
586 m = top_var_list (new_data);
587 if (m != MATCH_YES)
588 goto cleanup;
589
590 if (new_data->var->iter.var
591 && new_data->var->iter.var->ts.type == BT_INTEGER
592 && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
593 && new_data->var->list
594 && new_data->var->list->expr
595 && new_data->var->list->expr->ts.type == BT_CHARACTER
596 && new_data->var->list->expr->ref
597 && new_data->var->list->expr->ref->type == REF_SUBSTRING)
598 {
599 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
600 "statement", &new_data->var->list->expr->where);
601 goto cleanup;
602 }
603
604 /* Check for an entity with an allocatable component, which is not
605 allowed. */
606 e = new_data->var->expr;
607 if (e)
608 {
609 bool invalid;
610
611 invalid = false;
612 for (gfc_ref *ref = e->ref; ref; ref = ref->next)
613 if ((ref->type == REF_COMPONENT
614 && ref->u.c.component->attr.allocatable)
615 || (ref->type == REF_ARRAY
616 && e->symtree->n.sym->attr.pointer != 1
617 && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
618 invalid = true;
619
620 if (invalid)
621 {
622 gfc_error ("Allocatable component or deferred-shaped array "
623 "near %C in DATA statement");
624 goto cleanup;
625 }
626 }
627
628 m = top_val_list (new_data);
629 if (m != MATCH_YES)
630 goto cleanup;
631
632 new_data->next = gfc_current_ns->data;
633 gfc_current_ns->data = new_data;
634
635 if (gfc_match_eos () == MATCH_YES)
636 break;
637
638 gfc_match_char (','); /* Optional comma */
639 }
640
641 set_in_match_data (false);
642
643 if (gfc_pure (NULL))
644 {
645 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
646 return MATCH_ERROR;
647 }
648 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
649
650 return MATCH_YES;
651
652 cleanup:
653 set_in_match_data (false);
654 gfc_free_data (new_data);
655 return MATCH_ERROR;
656 }
657
658
659 /************************ Declaration statements *********************/
660
661
662 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
663 list). The difference here is the expression is a list of constants
664 and is surrounded by '/'.
665 The typespec ts must match the typespec of the variable which the
666 clist is initializing.
667 The arrayspec tells whether this should match a list of constants
668 corresponding to array elements or a scalar (as == NULL). */
669
670 static match
match_clist_expr(gfc_expr ** result,gfc_typespec * ts,gfc_array_spec * as)671 match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
672 {
673 gfc_constructor_base array_head = NULL;
674 gfc_expr *expr = NULL;
675 match m = MATCH_ERROR;
676 locus where;
677 mpz_t repeat, cons_size, as_size;
678 bool scalar;
679 int cmp;
680
681 gcc_assert (ts);
682
683 /* We have already matched '/' - now look for a constant list, as with
684 top_val_list from decl.c, but append the result to an array. */
685 if (gfc_match ("/") == MATCH_YES)
686 {
687 gfc_error ("Empty old style initializer list at %C");
688 return MATCH_ERROR;
689 }
690
691 where = gfc_current_locus;
692 scalar = !as || !as->rank;
693
694 if (!scalar && !spec_size (as, &as_size))
695 {
696 gfc_error ("Array in initializer list at %L must have an explicit shape",
697 as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
698 /* Nothing to cleanup yet. */
699 return MATCH_ERROR;
700 }
701
702 mpz_init_set_ui (repeat, 0);
703
704 for (;;)
705 {
706 m = match_data_constant (&expr);
707 if (m != MATCH_YES)
708 expr = NULL; /* match_data_constant may set expr to garbage */
709 if (m == MATCH_NO)
710 goto syntax;
711 if (m == MATCH_ERROR)
712 goto cleanup;
713
714 /* Found r in repeat spec r*c; look for the constant to repeat. */
715 if ( gfc_match_char ('*') == MATCH_YES)
716 {
717 if (scalar)
718 {
719 gfc_error ("Repeat spec invalid in scalar initializer at %C");
720 goto cleanup;
721 }
722 if (expr->ts.type != BT_INTEGER)
723 {
724 gfc_error ("Repeat spec must be an integer at %C");
725 goto cleanup;
726 }
727 mpz_set (repeat, expr->value.integer);
728 gfc_free_expr (expr);
729 expr = NULL;
730
731 m = match_data_constant (&expr);
732 if (m == MATCH_NO)
733 {
734 m = MATCH_ERROR;
735 gfc_error ("Expected data constant after repeat spec at %C");
736 }
737 if (m != MATCH_YES)
738 goto cleanup;
739 }
740 /* No repeat spec, we matched the data constant itself. */
741 else
742 mpz_set_ui (repeat, 1);
743
744 if (!scalar)
745 {
746 /* Add the constant initializer as many times as repeated. */
747 for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
748 {
749 /* Make sure types of elements match */
750 if(ts && !gfc_compare_types (&expr->ts, ts)
751 && !gfc_convert_type (expr, ts, 1))
752 goto cleanup;
753
754 gfc_constructor_append_expr (&array_head,
755 gfc_copy_expr (expr), &gfc_current_locus);
756 }
757
758 gfc_free_expr (expr);
759 expr = NULL;
760 }
761
762 /* For scalar initializers quit after one element. */
763 else
764 {
765 if(gfc_match_char ('/') != MATCH_YES)
766 {
767 gfc_error ("End of scalar initializer expected at %C");
768 goto cleanup;
769 }
770 break;
771 }
772
773 if (gfc_match_char ('/') == MATCH_YES)
774 break;
775 if (gfc_match_char (',') == MATCH_NO)
776 goto syntax;
777 }
778
779 /* If we break early from here out, we encountered an error. */
780 m = MATCH_ERROR;
781
782 /* Set up expr as an array constructor. */
783 if (!scalar)
784 {
785 expr = gfc_get_array_expr (ts->type, ts->kind, &where);
786 expr->ts = *ts;
787 expr->value.constructor = array_head;
788
789 expr->rank = as->rank;
790 expr->shape = gfc_get_shape (expr->rank);
791
792 /* Validate sizes. We built expr ourselves, so cons_size will be
793 constant (we fail above for non-constant expressions).
794 We still need to verify that the sizes match. */
795 gcc_assert (gfc_array_size (expr, &cons_size));
796 cmp = mpz_cmp (cons_size, as_size);
797 if (cmp < 0)
798 gfc_error ("Not enough elements in array initializer at %C");
799 else if (cmp > 0)
800 gfc_error ("Too many elements in array initializer at %C");
801 mpz_clear (cons_size);
802 if (cmp)
803 goto cleanup;
804 }
805
806 /* Make sure scalar types match. */
807 else if (!gfc_compare_types (&expr->ts, ts)
808 && !gfc_convert_type (expr, ts, 1))
809 goto cleanup;
810
811 if (expr->ts.u.cl)
812 expr->ts.u.cl->length_from_typespec = 1;
813
814 *result = expr;
815 m = MATCH_YES;
816 goto done;
817
818 syntax:
819 m = MATCH_ERROR;
820 gfc_error ("Syntax error in old style initializer list at %C");
821
822 cleanup:
823 if (expr)
824 expr->value.constructor = NULL;
825 gfc_free_expr (expr);
826 gfc_constructor_free (array_head);
827
828 done:
829 mpz_clear (repeat);
830 if (!scalar)
831 mpz_clear (as_size);
832 return m;
833 }
834
835
836 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
837
838 static bool
merge_array_spec(gfc_array_spec * from,gfc_array_spec * to,bool copy)839 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
840 {
841 if ((from->type == AS_ASSUMED_RANK && to->corank)
842 || (to->type == AS_ASSUMED_RANK && from->corank))
843 {
844 gfc_error ("The assumed-rank array at %C shall not have a codimension");
845 return false;
846 }
847
848 if (to->rank == 0 && from->rank > 0)
849 {
850 to->rank = from->rank;
851 to->type = from->type;
852 to->cray_pointee = from->cray_pointee;
853 to->cp_was_assumed = from->cp_was_assumed;
854
855 for (int i = to->corank - 1; i >= 0; i--)
856 {
857 /* Do not exceed the limits on lower[] and upper[]. gfortran
858 cleans up elsewhere. */
859 int j = from->rank + i;
860 if (j >= GFC_MAX_DIMENSIONS)
861 break;
862
863 to->lower[j] = to->lower[i];
864 to->upper[j] = to->upper[i];
865 }
866 for (int i = 0; i < from->rank; i++)
867 {
868 if (copy)
869 {
870 to->lower[i] = gfc_copy_expr (from->lower[i]);
871 to->upper[i] = gfc_copy_expr (from->upper[i]);
872 }
873 else
874 {
875 to->lower[i] = from->lower[i];
876 to->upper[i] = from->upper[i];
877 }
878 }
879 }
880 else if (to->corank == 0 && from->corank > 0)
881 {
882 to->corank = from->corank;
883 to->cotype = from->cotype;
884
885 for (int i = 0; i < from->corank; i++)
886 {
887 /* Do not exceed the limits on lower[] and upper[]. gfortran
888 cleans up elsewhere. */
889 int k = from->rank + i;
890 int j = to->rank + i;
891 if (j >= GFC_MAX_DIMENSIONS)
892 break;
893
894 if (copy)
895 {
896 to->lower[j] = gfc_copy_expr (from->lower[k]);
897 to->upper[j] = gfc_copy_expr (from->upper[k]);
898 }
899 else
900 {
901 to->lower[j] = from->lower[k];
902 to->upper[j] = from->upper[k];
903 }
904 }
905 }
906
907 if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
908 {
909 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
910 "allowed dimensions of %d",
911 to->rank, to->corank, GFC_MAX_DIMENSIONS);
912 to->corank = GFC_MAX_DIMENSIONS - to->rank;
913 return false;
914 }
915 return true;
916 }
917
918
919 /* Match an intent specification. Since this can only happen after an
920 INTENT word, a legal intent-spec must follow. */
921
922 static sym_intent
match_intent_spec(void)923 match_intent_spec (void)
924 {
925
926 if (gfc_match (" ( in out )") == MATCH_YES)
927 return INTENT_INOUT;
928 if (gfc_match (" ( in )") == MATCH_YES)
929 return INTENT_IN;
930 if (gfc_match (" ( out )") == MATCH_YES)
931 return INTENT_OUT;
932
933 gfc_error ("Bad INTENT specification at %C");
934 return INTENT_UNKNOWN;
935 }
936
937
938 /* Matches a character length specification, which is either a
939 specification expression, '*', or ':'. */
940
941 static match
char_len_param_value(gfc_expr ** expr,bool * deferred)942 char_len_param_value (gfc_expr **expr, bool *deferred)
943 {
944 match m;
945
946 *expr = NULL;
947 *deferred = false;
948
949 if (gfc_match_char ('*') == MATCH_YES)
950 return MATCH_YES;
951
952 if (gfc_match_char (':') == MATCH_YES)
953 {
954 if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
955 return MATCH_ERROR;
956
957 *deferred = true;
958
959 return MATCH_YES;
960 }
961
962 m = gfc_match_expr (expr);
963
964 if (m == MATCH_NO || m == MATCH_ERROR)
965 return m;
966
967 if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
968 return MATCH_ERROR;
969
970 if ((*expr)->expr_type == EXPR_FUNCTION)
971 {
972 if ((*expr)->ts.type == BT_INTEGER
973 || ((*expr)->ts.type == BT_UNKNOWN
974 && strcmp((*expr)->symtree->name, "null") != 0))
975 return MATCH_YES;
976
977 goto syntax;
978 }
979 else if ((*expr)->expr_type == EXPR_CONSTANT)
980 {
981 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
982 processor dependent and its value is greater than or equal to zero.
983 F2008, 4.4.3.2: If the character length parameter value evaluates
984 to a negative value, the length of character entities declared
985 is zero. */
986
987 if ((*expr)->ts.type == BT_INTEGER)
988 {
989 if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
990 mpz_set_si ((*expr)->value.integer, 0);
991 }
992 else
993 goto syntax;
994 }
995 else if ((*expr)->expr_type == EXPR_ARRAY)
996 goto syntax;
997 else if ((*expr)->expr_type == EXPR_VARIABLE)
998 {
999 bool t;
1000 gfc_expr *e;
1001
1002 e = gfc_copy_expr (*expr);
1003
1004 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1005 which causes an ICE if gfc_reduce_init_expr() is called. */
1006 if (e->ref && e->ref->type == REF_ARRAY
1007 && e->ref->u.ar.type == AR_UNKNOWN
1008 && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1009 goto syntax;
1010
1011 t = gfc_reduce_init_expr (e);
1012
1013 if (!t && e->ts.type == BT_UNKNOWN
1014 && e->symtree->n.sym->attr.untyped == 1
1015 && (flag_implicit_none
1016 || e->symtree->n.sym->ns->seen_implicit_none == 1
1017 || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1018 {
1019 gfc_free_expr (e);
1020 goto syntax;
1021 }
1022
1023 if ((e->ref && e->ref->type == REF_ARRAY
1024 && e->ref->u.ar.type != AR_ELEMENT)
1025 || (!e->ref && e->expr_type == EXPR_ARRAY))
1026 {
1027 gfc_free_expr (e);
1028 goto syntax;
1029 }
1030
1031 gfc_free_expr (e);
1032 }
1033
1034 return m;
1035
1036 syntax:
1037 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1038 return MATCH_ERROR;
1039 }
1040
1041
1042 /* A character length is a '*' followed by a literal integer or a
1043 char_len_param_value in parenthesis. */
1044
1045 static match
match_char_length(gfc_expr ** expr,bool * deferred,bool obsolescent_check)1046 match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1047 {
1048 int length;
1049 match m;
1050
1051 *deferred = false;
1052 m = gfc_match_char ('*');
1053 if (m != MATCH_YES)
1054 return m;
1055
1056 m = gfc_match_small_literal_int (&length, NULL);
1057 if (m == MATCH_ERROR)
1058 return m;
1059
1060 if (m == MATCH_YES)
1061 {
1062 if (obsolescent_check
1063 && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1064 return MATCH_ERROR;
1065 *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1066 return m;
1067 }
1068
1069 if (gfc_match_char ('(') == MATCH_NO)
1070 goto syntax;
1071
1072 m = char_len_param_value (expr, deferred);
1073 if (m != MATCH_YES && gfc_matching_function)
1074 {
1075 gfc_undo_symbols ();
1076 m = MATCH_YES;
1077 }
1078
1079 if (m == MATCH_ERROR)
1080 return m;
1081 if (m == MATCH_NO)
1082 goto syntax;
1083
1084 if (gfc_match_char (')') == MATCH_NO)
1085 {
1086 gfc_free_expr (*expr);
1087 *expr = NULL;
1088 goto syntax;
1089 }
1090
1091 return MATCH_YES;
1092
1093 syntax:
1094 gfc_error ("Syntax error in character length specification at %C");
1095 return MATCH_ERROR;
1096 }
1097
1098
1099 /* Special subroutine for finding a symbol. Check if the name is found
1100 in the current name space. If not, and we're compiling a function or
1101 subroutine and the parent compilation unit is an interface, then check
1102 to see if the name we've been given is the name of the interface
1103 (located in another namespace). */
1104
1105 static int
find_special(const char * name,gfc_symbol ** result,bool allow_subroutine)1106 find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1107 {
1108 gfc_state_data *s;
1109 gfc_symtree *st;
1110 int i;
1111
1112 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1113 if (i == 0)
1114 {
1115 *result = st ? st->n.sym : NULL;
1116 goto end;
1117 }
1118
1119 if (gfc_current_state () != COMP_SUBROUTINE
1120 && gfc_current_state () != COMP_FUNCTION)
1121 goto end;
1122
1123 s = gfc_state_stack->previous;
1124 if (s == NULL)
1125 goto end;
1126
1127 if (s->state != COMP_INTERFACE)
1128 goto end;
1129 if (s->sym == NULL)
1130 goto end; /* Nameless interface. */
1131
1132 if (strcmp (name, s->sym->name) == 0)
1133 {
1134 *result = s->sym;
1135 return 0;
1136 }
1137
1138 end:
1139 return i;
1140 }
1141
1142
1143 /* Special subroutine for getting a symbol node associated with a
1144 procedure name, used in SUBROUTINE and FUNCTION statements. The
1145 symbol is created in the parent using with symtree node in the
1146 child unit pointing to the symbol. If the current namespace has no
1147 parent, then the symbol is just created in the current unit. */
1148
1149 static int
get_proc_name(const char * name,gfc_symbol ** result,bool module_fcn_entry)1150 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1151 {
1152 gfc_symtree *st;
1153 gfc_symbol *sym;
1154 int rc = 0;
1155
1156 /* Module functions have to be left in their own namespace because
1157 they have potentially (almost certainly!) already been referenced.
1158 In this sense, they are rather like external functions. This is
1159 fixed up in resolve.c(resolve_entries), where the symbol name-
1160 space is set to point to the master function, so that the fake
1161 result mechanism can work. */
1162 if (module_fcn_entry)
1163 {
1164 /* Present if entry is declared to be a module procedure. */
1165 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1166
1167 if (*result == NULL)
1168 rc = gfc_get_symbol (name, NULL, result);
1169 else if (!gfc_get_symbol (name, NULL, &sym) && sym
1170 && (*result)->ts.type == BT_UNKNOWN
1171 && sym->attr.flavor == FL_UNKNOWN)
1172 /* Pick up the typespec for the entry, if declared in the function
1173 body. Note that this symbol is FL_UNKNOWN because it will
1174 only have appeared in a type declaration. The local symtree
1175 is set to point to the module symbol and a unique symtree
1176 to the local version. This latter ensures a correct clearing
1177 of the symbols. */
1178 {
1179 /* If the ENTRY proceeds its specification, we need to ensure
1180 that this does not raise a "has no IMPLICIT type" error. */
1181 if (sym->ts.type == BT_UNKNOWN)
1182 sym->attr.untyped = 1;
1183
1184 (*result)->ts = sym->ts;
1185
1186 /* Put the symbol in the procedure namespace so that, should
1187 the ENTRY precede its specification, the specification
1188 can be applied. */
1189 (*result)->ns = gfc_current_ns;
1190
1191 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1192 st->n.sym = *result;
1193 st = gfc_get_unique_symtree (gfc_current_ns);
1194 sym->refs++;
1195 st->n.sym = sym;
1196 }
1197 }
1198 else
1199 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1200
1201 if (rc)
1202 return rc;
1203
1204 sym = *result;
1205 if (sym->attr.proc == PROC_ST_FUNCTION)
1206 return rc;
1207
1208 if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1209 {
1210 /* Create a partially populated interface symbol to carry the
1211 characteristics of the procedure and the result. */
1212 sym->tlink = gfc_new_symbol (name, sym->ns);
1213 gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1214 gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1215 if (sym->attr.dimension)
1216 sym->tlink->as = gfc_copy_array_spec (sym->as);
1217
1218 /* Ideally, at this point, a copy would be made of the formal
1219 arguments and their namespace. However, this does not appear
1220 to be necessary, albeit at the expense of not being able to
1221 use gfc_compare_interfaces directly. */
1222
1223 if (sym->result && sym->result != sym)
1224 {
1225 sym->tlink->result = sym->result;
1226 sym->result = NULL;
1227 }
1228 else if (sym->result)
1229 {
1230 sym->tlink->result = sym->tlink;
1231 }
1232 }
1233 else if (sym && !sym->gfc_new
1234 && gfc_current_state () != COMP_INTERFACE)
1235 {
1236 /* Trap another encompassed procedure with the same name. All
1237 these conditions are necessary to avoid picking up an entry
1238 whose name clashes with that of the encompassing procedure;
1239 this is handled using gsymbols to register unique, globally
1240 accessible names. */
1241 if (sym->attr.flavor != 0
1242 && sym->attr.proc != 0
1243 && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1244 && sym->attr.if_source != IFSRC_UNKNOWN)
1245 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1246 name, &sym->declared_at);
1247
1248 if (sym->attr.flavor != 0
1249 && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1250 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1251 name, &sym->declared_at);
1252
1253 if (sym->attr.external && sym->attr.procedure
1254 && gfc_current_state () == COMP_CONTAINS)
1255 gfc_error_now ("Contained procedure %qs at %C clashes with "
1256 "procedure defined at %L",
1257 name, &sym->declared_at);
1258
1259 /* Trap a procedure with a name the same as interface in the
1260 encompassing scope. */
1261 if (sym->attr.generic != 0
1262 && (sym->attr.subroutine || sym->attr.function)
1263 && !sym->attr.mod_proc)
1264 gfc_error_now ("Name %qs at %C is already defined"
1265 " as a generic interface at %L",
1266 name, &sym->declared_at);
1267
1268 /* Trap declarations of attributes in encompassing scope. The
1269 signature for this is that ts.kind is set. Legitimate
1270 references only set ts.type. */
1271 if (sym->ts.kind != 0
1272 && !sym->attr.implicit_type
1273 && sym->attr.proc == 0
1274 && gfc_current_ns->parent != NULL
1275 && sym->attr.access == 0
1276 && !module_fcn_entry)
1277 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1278 "from a previous declaration", name);
1279 }
1280
1281 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1282 subroutine-stmt of a module subprogram or of a nonabstract interface
1283 body that is declared in the scoping unit of a module or submodule. */
1284 if (sym->attr.external
1285 && (sym->attr.subroutine || sym->attr.function)
1286 && sym->attr.if_source == IFSRC_IFBODY
1287 && !current_attr.module_procedure
1288 && sym->attr.proc == PROC_MODULE
1289 && gfc_state_stack->state == COMP_CONTAINS)
1290 gfc_error_now ("Procedure %qs defined in interface body at %L "
1291 "clashes with internal procedure defined at %C",
1292 name, &sym->declared_at);
1293
1294 if (sym && !sym->gfc_new
1295 && sym->attr.flavor != FL_UNKNOWN
1296 && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1297 && gfc_state_stack->state == COMP_CONTAINS
1298 && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1299 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1300 name, &sym->declared_at);
1301
1302 if (gfc_current_ns->parent == NULL || *result == NULL)
1303 return rc;
1304
1305 /* Module function entries will already have a symtree in
1306 the current namespace but will need one at module level. */
1307 if (module_fcn_entry)
1308 {
1309 /* Present if entry is declared to be a module procedure. */
1310 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1311 if (st == NULL)
1312 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1313 }
1314 else
1315 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1316
1317 st->n.sym = sym;
1318 sym->refs++;
1319
1320 /* See if the procedure should be a module procedure. */
1321
1322 if (((sym->ns->proc_name != NULL
1323 && sym->ns->proc_name->attr.flavor == FL_MODULE
1324 && sym->attr.proc != PROC_MODULE)
1325 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1326 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1327 rc = 2;
1328
1329 return rc;
1330 }
1331
1332
1333 /* Verify that the given symbol representing a parameter is C
1334 interoperable, by checking to see if it was marked as such after
1335 its declaration. If the given symbol is not interoperable, a
1336 warning is reported, thus removing the need to return the status to
1337 the calling function. The standard does not require the user use
1338 one of the iso_c_binding named constants to declare an
1339 interoperable parameter, but we can't be sure if the param is C
1340 interop or not if the user doesn't. For example, integer(4) may be
1341 legal Fortran, but doesn't have meaning in C. It may interop with
1342 a number of the C types, which causes a problem because the
1343 compiler can't know which one. This code is almost certainly not
1344 portable, and the user will get what they deserve if the C type
1345 across platforms isn't always interoperable with integer(4). If
1346 the user had used something like integer(c_int) or integer(c_long),
1347 the compiler could have automatically handled the varying sizes
1348 across platforms. */
1349
1350 bool
gfc_verify_c_interop_param(gfc_symbol * sym)1351 gfc_verify_c_interop_param (gfc_symbol *sym)
1352 {
1353 int is_c_interop = 0;
1354 bool retval = true;
1355
1356 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1357 Don't repeat the checks here. */
1358 if (sym->attr.implicit_type)
1359 return true;
1360
1361 /* For subroutines or functions that are passed to a BIND(C) procedure,
1362 they're interoperable if they're BIND(C) and their params are all
1363 interoperable. */
1364 if (sym->attr.flavor == FL_PROCEDURE)
1365 {
1366 if (sym->attr.is_bind_c == 0)
1367 {
1368 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1369 "attribute to be C interoperable", sym->name,
1370 &(sym->declared_at));
1371 return false;
1372 }
1373 else
1374 {
1375 if (sym->attr.is_c_interop == 1)
1376 /* We've already checked this procedure; don't check it again. */
1377 return true;
1378 else
1379 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1380 sym->common_block);
1381 }
1382 }
1383
1384 /* See if we've stored a reference to a procedure that owns sym. */
1385 if (sym->ns != NULL && sym->ns->proc_name != NULL)
1386 {
1387 if (sym->ns->proc_name->attr.is_bind_c == 1)
1388 {
1389 is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1390
1391 if (is_c_interop != 1)
1392 {
1393 /* Make personalized messages to give better feedback. */
1394 if (sym->ts.type == BT_DERIVED)
1395 gfc_error ("Variable %qs at %L is a dummy argument to the "
1396 "BIND(C) procedure %qs but is not C interoperable "
1397 "because derived type %qs is not C interoperable",
1398 sym->name, &(sym->declared_at),
1399 sym->ns->proc_name->name,
1400 sym->ts.u.derived->name);
1401 else if (sym->ts.type == BT_CLASS)
1402 gfc_error ("Variable %qs at %L is a dummy argument to the "
1403 "BIND(C) procedure %qs but is not C interoperable "
1404 "because it is polymorphic",
1405 sym->name, &(sym->declared_at),
1406 sym->ns->proc_name->name);
1407 else if (warn_c_binding_type)
1408 gfc_warning (OPT_Wc_binding_type,
1409 "Variable %qs at %L is a dummy argument of the "
1410 "BIND(C) procedure %qs but may not be C "
1411 "interoperable",
1412 sym->name, &(sym->declared_at),
1413 sym->ns->proc_name->name);
1414 }
1415
1416 /* Character strings are only C interoperable if they have a
1417 length of 1. */
1418 if (sym->ts.type == BT_CHARACTER)
1419 {
1420 gfc_charlen *cl = sym->ts.u.cl;
1421 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
1422 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1423 {
1424 gfc_error ("Character argument %qs at %L "
1425 "must be length 1 because "
1426 "procedure %qs is BIND(C)",
1427 sym->name, &sym->declared_at,
1428 sym->ns->proc_name->name);
1429 retval = false;
1430 }
1431 }
1432
1433 /* We have to make sure that any param to a bind(c) routine does
1434 not have the allocatable, pointer, or optional attributes,
1435 according to J3/04-007, section 5.1. */
1436 if (sym->attr.allocatable == 1
1437 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
1438 "ALLOCATABLE attribute in procedure %qs "
1439 "with BIND(C)", sym->name,
1440 &(sym->declared_at),
1441 sym->ns->proc_name->name))
1442 retval = false;
1443
1444 if (sym->attr.pointer == 1
1445 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
1446 "POINTER attribute in procedure %qs "
1447 "with BIND(C)", sym->name,
1448 &(sym->declared_at),
1449 sym->ns->proc_name->name))
1450 retval = false;
1451
1452 if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
1453 {
1454 gfc_error ("Scalar variable %qs at %L with POINTER or "
1455 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1456 " supported", sym->name, &(sym->declared_at),
1457 sym->ns->proc_name->name);
1458 retval = false;
1459 }
1460
1461 if (sym->attr.optional == 1 && sym->attr.value)
1462 {
1463 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1464 "and the VALUE attribute because procedure %qs "
1465 "is BIND(C)", sym->name, &(sym->declared_at),
1466 sym->ns->proc_name->name);
1467 retval = false;
1468 }
1469 else if (sym->attr.optional == 1
1470 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs "
1471 "at %L with OPTIONAL attribute in "
1472 "procedure %qs which is BIND(C)",
1473 sym->name, &(sym->declared_at),
1474 sym->ns->proc_name->name))
1475 retval = false;
1476
1477 /* Make sure that if it has the dimension attribute, that it is
1478 either assumed size or explicit shape. Deferred shape is already
1479 covered by the pointer/allocatable attribute. */
1480 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1481 && !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array %qs "
1482 "at %L as dummy argument to the BIND(C) "
1483 "procedure %qs at %L", sym->name,
1484 &(sym->declared_at),
1485 sym->ns->proc_name->name,
1486 &(sym->ns->proc_name->declared_at)))
1487 retval = false;
1488 }
1489 }
1490
1491 return retval;
1492 }
1493
1494
1495
1496 /* Function called by variable_decl() that adds a name to the symbol table. */
1497
1498 static bool
build_sym(const char * name,gfc_charlen * cl,bool cl_deferred,gfc_array_spec ** as,locus * var_locus)1499 build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1500 gfc_array_spec **as, locus *var_locus)
1501 {
1502 symbol_attribute attr;
1503 gfc_symbol *sym;
1504 int upper;
1505 gfc_symtree *st;
1506
1507 /* Symbols in a submodule are host associated from the parent module or
1508 submodules. Therefore, they can be overridden by declarations in the
1509 submodule scope. Deal with this by attaching the existing symbol to
1510 a new symtree and recycling the old symtree with a new symbol... */
1511 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1512 if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1513 && st->n.sym != NULL
1514 && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1515 {
1516 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1517 s->n.sym = st->n.sym;
1518 sym = gfc_new_symbol (name, gfc_current_ns);
1519
1520
1521 st->n.sym = sym;
1522 sym->refs++;
1523 gfc_set_sym_referenced (sym);
1524 }
1525 /* ...Otherwise generate a new symtree and new symbol. */
1526 else if (gfc_get_symbol (name, NULL, &sym))
1527 return false;
1528
1529 /* Check if the name has already been defined as a type. The
1530 first letter of the symtree will be in upper case then. Of
1531 course, this is only necessary if the upper case letter is
1532 actually different. */
1533
1534 upper = TOUPPER(name[0]);
1535 if (upper != name[0])
1536 {
1537 char u_name[GFC_MAX_SYMBOL_LEN + 1];
1538 gfc_symtree *st;
1539
1540 gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1541 strcpy (u_name, name);
1542 u_name[0] = upper;
1543
1544 st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1545
1546 /* STRUCTURE types can alias symbol names */
1547 if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1548 {
1549 gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1550 &st->n.sym->declared_at);
1551 return false;
1552 }
1553 }
1554
1555 /* Start updating the symbol table. Add basic type attribute if present. */
1556 if (current_ts.type != BT_UNKNOWN
1557 && (sym->attr.implicit_type == 0
1558 || !gfc_compare_types (&sym->ts, ¤t_ts))
1559 && !gfc_add_type (sym, ¤t_ts, var_locus))
1560 return false;
1561
1562 if (sym->ts.type == BT_CHARACTER)
1563 {
1564 sym->ts.u.cl = cl;
1565 sym->ts.deferred = cl_deferred;
1566 }
1567
1568 /* Add dimension attribute if present. */
1569 if (!gfc_set_array_spec (sym, *as, var_locus))
1570 return false;
1571 *as = NULL;
1572
1573 /* Add attribute to symbol. The copy is so that we can reset the
1574 dimension attribute. */
1575 attr = current_attr;
1576 attr.dimension = 0;
1577 attr.codimension = 0;
1578
1579 if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1580 return false;
1581
1582 /* Finish any work that may need to be done for the binding label,
1583 if it's a bind(c). The bind(c) attr is found before the symbol
1584 is made, and before the symbol name (for data decls), so the
1585 current_ts is holding the binding label, or nothing if the
1586 name= attr wasn't given. Therefore, test here if we're dealing
1587 with a bind(c) and make sure the binding label is set correctly. */
1588 if (sym->attr.is_bind_c == 1)
1589 {
1590 if (!sym->binding_label)
1591 {
1592 /* Set the binding label and verify that if a NAME= was specified
1593 then only one identifier was in the entity-decl-list. */
1594 if (!set_binding_label (&sym->binding_label, sym->name,
1595 num_idents_on_line))
1596 return false;
1597 }
1598 }
1599
1600 /* See if we know we're in a common block, and if it's a bind(c)
1601 common then we need to make sure we're an interoperable type. */
1602 if (sym->attr.in_common == 1)
1603 {
1604 /* Test the common block object. */
1605 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1606 && sym->ts.is_c_interop != 1)
1607 {
1608 gfc_error_now ("Variable %qs in common block %qs at %C "
1609 "must be declared with a C interoperable "
1610 "kind since common block %qs is BIND(C)",
1611 sym->name, sym->common_block->name,
1612 sym->common_block->name);
1613 gfc_clear_error ();
1614 }
1615 }
1616
1617 sym->attr.implied_index = 0;
1618
1619 /* Use the parameter expressions for a parameterized derived type. */
1620 if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1621 && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1622 sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1623
1624 if (sym->ts.type == BT_CLASS)
1625 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1626
1627 return true;
1628 }
1629
1630
1631 /* Set character constant to the given length. The constant will be padded or
1632 truncated. If we're inside an array constructor without a typespec, we
1633 additionally check that all elements have the same length; check_len -1
1634 means no checking. */
1635
1636 void
gfc_set_constant_character_len(gfc_charlen_t len,gfc_expr * expr,gfc_charlen_t check_len)1637 gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1638 gfc_charlen_t check_len)
1639 {
1640 gfc_char_t *s;
1641 gfc_charlen_t slen;
1642
1643 if (expr->ts.type != BT_CHARACTER)
1644 return;
1645
1646 if (expr->expr_type != EXPR_CONSTANT)
1647 {
1648 gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1649 return;
1650 }
1651
1652 slen = expr->value.character.length;
1653 if (len != slen)
1654 {
1655 s = gfc_get_wide_string (len + 1);
1656 memcpy (s, expr->value.character.string,
1657 MIN (len, slen) * sizeof (gfc_char_t));
1658 if (len > slen)
1659 gfc_wide_memset (&s[slen], ' ', len - slen);
1660
1661 if (warn_character_truncation && slen > len)
1662 gfc_warning_now (OPT_Wcharacter_truncation,
1663 "CHARACTER expression at %L is being truncated "
1664 "(%ld/%ld)", &expr->where,
1665 (long) slen, (long) len);
1666
1667 /* Apply the standard by 'hand' otherwise it gets cleared for
1668 initializers. */
1669 if (check_len != -1 && slen != check_len
1670 && !(gfc_option.allow_std & GFC_STD_GNU))
1671 gfc_error_now ("The CHARACTER elements of the array constructor "
1672 "at %L must have the same length (%ld/%ld)",
1673 &expr->where, (long) slen,
1674 (long) check_len);
1675
1676 s[len] = '\0';
1677 free (expr->value.character.string);
1678 expr->value.character.string = s;
1679 expr->value.character.length = len;
1680 /* If explicit representation was given, clear it
1681 as it is no longer needed after padding. */
1682 if (expr->representation.length)
1683 {
1684 expr->representation.length = 0;
1685 free (expr->representation.string);
1686 expr->representation.string = NULL;
1687 }
1688 }
1689 }
1690
1691
1692 /* Function to create and update the enumerator history
1693 using the information passed as arguments.
1694 Pointer "max_enum" is also updated, to point to
1695 enum history node containing largest initializer.
1696
1697 SYM points to the symbol node of enumerator.
1698 INIT points to its enumerator value. */
1699
1700 static void
create_enum_history(gfc_symbol * sym,gfc_expr * init)1701 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1702 {
1703 enumerator_history *new_enum_history;
1704 gcc_assert (sym != NULL && init != NULL);
1705
1706 new_enum_history = XCNEW (enumerator_history);
1707
1708 new_enum_history->sym = sym;
1709 new_enum_history->initializer = init;
1710 new_enum_history->next = NULL;
1711
1712 if (enum_history == NULL)
1713 {
1714 enum_history = new_enum_history;
1715 max_enum = enum_history;
1716 }
1717 else
1718 {
1719 new_enum_history->next = enum_history;
1720 enum_history = new_enum_history;
1721
1722 if (mpz_cmp (max_enum->initializer->value.integer,
1723 new_enum_history->initializer->value.integer) < 0)
1724 max_enum = new_enum_history;
1725 }
1726 }
1727
1728
1729 /* Function to free enum kind history. */
1730
1731 void
gfc_free_enum_history(void)1732 gfc_free_enum_history (void)
1733 {
1734 enumerator_history *current = enum_history;
1735 enumerator_history *next;
1736
1737 while (current != NULL)
1738 {
1739 next = current->next;
1740 free (current);
1741 current = next;
1742 }
1743 max_enum = NULL;
1744 enum_history = NULL;
1745 }
1746
1747
1748 /* Function called by variable_decl() that adds an initialization
1749 expression to a symbol. */
1750
1751 static bool
add_init_expr_to_sym(const char * name,gfc_expr ** initp,locus * var_locus)1752 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1753 {
1754 symbol_attribute attr;
1755 gfc_symbol *sym;
1756 gfc_expr *init;
1757
1758 init = *initp;
1759 if (find_special (name, &sym, false))
1760 return false;
1761
1762 attr = sym->attr;
1763
1764 /* If this symbol is confirming an implicit parameter type,
1765 then an initialization expression is not allowed. */
1766 if (attr.flavor == FL_PARAMETER
1767 && sym->value != NULL
1768 && *initp != NULL)
1769 {
1770 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1771 sym->name);
1772 return false;
1773 }
1774
1775 if (init == NULL)
1776 {
1777 /* An initializer is required for PARAMETER declarations. */
1778 if (attr.flavor == FL_PARAMETER)
1779 {
1780 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1781 return false;
1782 }
1783 }
1784 else
1785 {
1786 /* If a variable appears in a DATA block, it cannot have an
1787 initializer. */
1788 if (sym->attr.data)
1789 {
1790 gfc_error ("Variable %qs at %C with an initializer already "
1791 "appears in a DATA statement", sym->name);
1792 return false;
1793 }
1794
1795 /* Check if the assignment can happen. This has to be put off
1796 until later for derived type variables and procedure pointers. */
1797 if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
1798 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1799 && !sym->attr.proc_pointer
1800 && !gfc_check_assign_symbol (sym, NULL, init))
1801 return false;
1802
1803 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1804 && init->ts.type == BT_CHARACTER)
1805 {
1806 /* Update symbol character length according initializer. */
1807 if (!gfc_check_assign_symbol (sym, NULL, init))
1808 return false;
1809
1810 if (sym->ts.u.cl->length == NULL)
1811 {
1812 gfc_charlen_t clen;
1813 /* If there are multiple CHARACTER variables declared on the
1814 same line, we don't want them to share the same length. */
1815 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1816
1817 if (sym->attr.flavor == FL_PARAMETER)
1818 {
1819 if (init->expr_type == EXPR_CONSTANT)
1820 {
1821 clen = init->value.character.length;
1822 sym->ts.u.cl->length
1823 = gfc_get_int_expr (gfc_charlen_int_kind,
1824 NULL, clen);
1825 }
1826 else if (init->expr_type == EXPR_ARRAY)
1827 {
1828 if (init->ts.u.cl && init->ts.u.cl->length)
1829 {
1830 const gfc_expr *length = init->ts.u.cl->length;
1831 if (length->expr_type != EXPR_CONSTANT)
1832 {
1833 gfc_error ("Cannot initialize parameter array "
1834 "at %L "
1835 "with variable length elements",
1836 &sym->declared_at);
1837 return false;
1838 }
1839 clen = mpz_get_si (length->value.integer);
1840 }
1841 else if (init->value.constructor)
1842 {
1843 gfc_constructor *c;
1844 c = gfc_constructor_first (init->value.constructor);
1845 clen = c->expr->value.character.length;
1846 }
1847 else
1848 gcc_unreachable ();
1849 sym->ts.u.cl->length
1850 = gfc_get_int_expr (gfc_charlen_int_kind,
1851 NULL, clen);
1852 }
1853 else if (init->ts.u.cl && init->ts.u.cl->length)
1854 sym->ts.u.cl->length =
1855 gfc_copy_expr (init->ts.u.cl->length);
1856 }
1857 }
1858 /* Update initializer character length according symbol. */
1859 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1860 {
1861 if (!gfc_specification_expr (sym->ts.u.cl->length))
1862 return false;
1863
1864 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
1865 false);
1866 /* resolve_charlen will complain later on if the length
1867 is too large. Just skeep the initialization in that case. */
1868 if (mpz_cmp (sym->ts.u.cl->length->value.integer,
1869 gfc_integer_kinds[k].huge) <= 0)
1870 {
1871 HOST_WIDE_INT len
1872 = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
1873
1874 if (init->expr_type == EXPR_CONSTANT)
1875 gfc_set_constant_character_len (len, init, -1);
1876 else if (init->expr_type == EXPR_ARRAY)
1877 {
1878 gfc_constructor *c;
1879
1880 /* Build a new charlen to prevent simplification from
1881 deleting the length before it is resolved. */
1882 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1883 init->ts.u.cl->length
1884 = gfc_copy_expr (sym->ts.u.cl->length);
1885
1886 for (c = gfc_constructor_first (init->value.constructor);
1887 c; c = gfc_constructor_next (c))
1888 gfc_set_constant_character_len (len, c->expr, -1);
1889 }
1890 }
1891 }
1892 }
1893
1894 /* If sym is implied-shape, set its upper bounds from init. */
1895 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1896 && sym->as->type == AS_IMPLIED_SHAPE)
1897 {
1898 int dim;
1899
1900 if (init->rank == 0)
1901 {
1902 gfc_error ("Can't initialize implied-shape array at %L"
1903 " with scalar", &sym->declared_at);
1904 return false;
1905 }
1906
1907 /* Shape should be present, we get an initialization expression. */
1908 gcc_assert (init->shape);
1909
1910 for (dim = 0; dim < sym->as->rank; ++dim)
1911 {
1912 int k;
1913 gfc_expr *e, *lower;
1914
1915 lower = sym->as->lower[dim];
1916
1917 /* If the lower bound is an array element from another
1918 parameterized array, then it is marked with EXPR_VARIABLE and
1919 is an initialization expression. Try to reduce it. */
1920 if (lower->expr_type == EXPR_VARIABLE)
1921 gfc_reduce_init_expr (lower);
1922
1923 if (lower->expr_type == EXPR_CONSTANT)
1924 {
1925 /* All dimensions must be without upper bound. */
1926 gcc_assert (!sym->as->upper[dim]);
1927
1928 k = lower->ts.kind;
1929 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1930 mpz_add (e->value.integer, lower->value.integer,
1931 init->shape[dim]);
1932 mpz_sub_ui (e->value.integer, e->value.integer, 1);
1933 sym->as->upper[dim] = e;
1934 }
1935 else
1936 {
1937 gfc_error ("Non-constant lower bound in implied-shape"
1938 " declaration at %L", &lower->where);
1939 return false;
1940 }
1941 }
1942
1943 sym->as->type = AS_EXPLICIT;
1944 }
1945
1946 /* Need to check if the expression we initialized this
1947 to was one of the iso_c_binding named constants. If so,
1948 and we're a parameter (constant), let it be iso_c.
1949 For example:
1950 integer(c_int), parameter :: my_int = c_int
1951 integer(my_int) :: my_int_2
1952 If we mark my_int as iso_c (since we can see it's value
1953 is equal to one of the named constants), then my_int_2
1954 will be considered C interoperable. */
1955 if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
1956 {
1957 sym->ts.is_iso_c |= init->ts.is_iso_c;
1958 sym->ts.is_c_interop |= init->ts.is_c_interop;
1959 /* attr bits needed for module files. */
1960 sym->attr.is_iso_c |= init->ts.is_iso_c;
1961 sym->attr.is_c_interop |= init->ts.is_c_interop;
1962 if (init->ts.is_iso_c)
1963 sym->ts.f90_type = init->ts.f90_type;
1964 }
1965
1966 /* Add initializer. Make sure we keep the ranks sane. */
1967 if (sym->attr.dimension && init->rank == 0)
1968 {
1969 mpz_t size;
1970 gfc_expr *array;
1971 int n;
1972 if (sym->attr.flavor == FL_PARAMETER
1973 && init->expr_type == EXPR_CONSTANT
1974 && spec_size (sym->as, &size)
1975 && mpz_cmp_si (size, 0) > 0)
1976 {
1977 array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1978 &init->where);
1979 for (n = 0; n < (int)mpz_get_si (size); n++)
1980 gfc_constructor_append_expr (&array->value.constructor,
1981 n == 0
1982 ? init
1983 : gfc_copy_expr (init),
1984 &init->where);
1985
1986 array->shape = gfc_get_shape (sym->as->rank);
1987 for (n = 0; n < sym->as->rank; n++)
1988 spec_dimen_size (sym->as, n, &array->shape[n]);
1989
1990 init = array;
1991 mpz_clear (size);
1992 }
1993 init->rank = sym->as->rank;
1994 }
1995
1996 sym->value = init;
1997 if (sym->attr.save == SAVE_NONE)
1998 sym->attr.save = SAVE_IMPLICIT;
1999 *initp = NULL;
2000 }
2001
2002 return true;
2003 }
2004
2005
2006 /* Function called by variable_decl() that adds a name to a structure
2007 being built. */
2008
2009 static bool
build_struct(const char * name,gfc_charlen * cl,gfc_expr ** init,gfc_array_spec ** as)2010 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2011 gfc_array_spec **as)
2012 {
2013 gfc_state_data *s;
2014 gfc_component *c;
2015
2016 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2017 constructing, it must have the pointer attribute. */
2018 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2019 && current_ts.u.derived == gfc_current_block ()
2020 && current_attr.pointer == 0)
2021 {
2022 if (current_attr.allocatable
2023 && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2024 "must have the POINTER attribute"))
2025 {
2026 return false;
2027 }
2028 else if (current_attr.allocatable == 0)
2029 {
2030 gfc_error ("Component at %C must have the POINTER attribute");
2031 return false;
2032 }
2033 }
2034
2035 /* F03:C437. */
2036 if (current_ts.type == BT_CLASS
2037 && !(current_attr.pointer || current_attr.allocatable))
2038 {
2039 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2040 "or pointer", name);
2041 return false;
2042 }
2043
2044 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2045 {
2046 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2047 {
2048 gfc_error ("Array component of structure at %C must have explicit "
2049 "or deferred shape");
2050 return false;
2051 }
2052 }
2053
2054 /* If we are in a nested union/map definition, gfc_add_component will not
2055 properly find repeated components because:
2056 (i) gfc_add_component does a flat search, where components of unions
2057 and maps are implicity chained so nested components may conflict.
2058 (ii) Unions and maps are not linked as components of their parent
2059 structures until after they are parsed.
2060 For (i) we use gfc_find_component which searches recursively, and for (ii)
2061 we search each block directly from the parse stack until we find the top
2062 level structure. */
2063
2064 s = gfc_state_stack;
2065 if (s->state == COMP_UNION || s->state == COMP_MAP)
2066 {
2067 while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2068 {
2069 c = gfc_find_component (s->sym, name, true, true, NULL);
2070 if (c != NULL)
2071 {
2072 gfc_error_now ("Component %qs at %C already declared at %L",
2073 name, &c->loc);
2074 return false;
2075 }
2076 /* Break after we've searched the entire chain. */
2077 if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2078 break;
2079 s = s->previous;
2080 }
2081 }
2082
2083 if (!gfc_add_component (gfc_current_block(), name, &c))
2084 return false;
2085
2086 c->ts = current_ts;
2087 if (c->ts.type == BT_CHARACTER)
2088 c->ts.u.cl = cl;
2089
2090 if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2091 && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2092 && saved_kind_expr != NULL)
2093 c->kind_expr = gfc_copy_expr (saved_kind_expr);
2094
2095 c->attr = current_attr;
2096
2097 c->initializer = *init;
2098 *init = NULL;
2099
2100 c->as = *as;
2101 if (c->as != NULL)
2102 {
2103 if (c->as->corank)
2104 c->attr.codimension = 1;
2105 if (c->as->rank)
2106 c->attr.dimension = 1;
2107 }
2108 *as = NULL;
2109
2110 gfc_apply_init (&c->ts, &c->attr, c->initializer);
2111
2112 /* Check array components. */
2113 if (!c->attr.dimension)
2114 goto scalar;
2115
2116 if (c->attr.pointer)
2117 {
2118 if (c->as->type != AS_DEFERRED)
2119 {
2120 gfc_error ("Pointer array component of structure at %C must have a "
2121 "deferred shape");
2122 return false;
2123 }
2124 }
2125 else if (c->attr.allocatable)
2126 {
2127 if (c->as->type != AS_DEFERRED)
2128 {
2129 gfc_error ("Allocatable component of structure at %C must have a "
2130 "deferred shape");
2131 return false;
2132 }
2133 }
2134 else
2135 {
2136 if (c->as->type != AS_EXPLICIT)
2137 {
2138 gfc_error ("Array component of structure at %C must have an "
2139 "explicit shape");
2140 return false;
2141 }
2142 }
2143
2144 scalar:
2145 if (c->ts.type == BT_CLASS)
2146 return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2147
2148 if (c->attr.pdt_kind || c->attr.pdt_len)
2149 {
2150 gfc_symbol *sym;
2151 gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2152 0, &sym);
2153 if (sym == NULL)
2154 {
2155 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2156 "in the type parameter name list at %L",
2157 c->name, &gfc_current_block ()->declared_at);
2158 return false;
2159 }
2160 sym->ts = c->ts;
2161 sym->attr.pdt_kind = c->attr.pdt_kind;
2162 sym->attr.pdt_len = c->attr.pdt_len;
2163 if (c->initializer)
2164 sym->value = gfc_copy_expr (c->initializer);
2165 sym->attr.flavor = FL_VARIABLE;
2166 }
2167
2168 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2169 && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2170 && decl_type_param_list)
2171 c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2172
2173 return true;
2174 }
2175
2176
2177 /* Match a 'NULL()', and possibly take care of some side effects. */
2178
2179 match
gfc_match_null(gfc_expr ** result)2180 gfc_match_null (gfc_expr **result)
2181 {
2182 gfc_symbol *sym;
2183 match m, m2 = MATCH_NO;
2184
2185 if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2186 return MATCH_ERROR;
2187
2188 if (m == MATCH_NO)
2189 {
2190 locus old_loc;
2191 char name[GFC_MAX_SYMBOL_LEN + 1];
2192
2193 if ((m2 = gfc_match (" null (")) != MATCH_YES)
2194 return m2;
2195
2196 old_loc = gfc_current_locus;
2197 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2198 return MATCH_ERROR;
2199 if (m2 != MATCH_YES
2200 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2201 return MATCH_ERROR;
2202 if (m2 == MATCH_NO)
2203 {
2204 gfc_current_locus = old_loc;
2205 return MATCH_NO;
2206 }
2207 }
2208
2209 /* The NULL symbol now has to be/become an intrinsic function. */
2210 if (gfc_get_symbol ("null", NULL, &sym))
2211 {
2212 gfc_error ("NULL() initialization at %C is ambiguous");
2213 return MATCH_ERROR;
2214 }
2215
2216 gfc_intrinsic_symbol (sym);
2217
2218 if (sym->attr.proc != PROC_INTRINSIC
2219 && !(sym->attr.use_assoc && sym->attr.intrinsic)
2220 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2221 || !gfc_add_function (&sym->attr, sym->name, NULL)))
2222 return MATCH_ERROR;
2223
2224 *result = gfc_get_null_expr (&gfc_current_locus);
2225
2226 /* Invalid per F2008, C512. */
2227 if (m2 == MATCH_YES)
2228 {
2229 gfc_error ("NULL() initialization at %C may not have MOLD");
2230 return MATCH_ERROR;
2231 }
2232
2233 return MATCH_YES;
2234 }
2235
2236
2237 /* Match the initialization expr for a data pointer or procedure pointer. */
2238
2239 static match
match_pointer_init(gfc_expr ** init,int procptr)2240 match_pointer_init (gfc_expr **init, int procptr)
2241 {
2242 match m;
2243
2244 if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2245 {
2246 gfc_error ("Initialization of pointer at %C is not allowed in "
2247 "a PURE procedure");
2248 return MATCH_ERROR;
2249 }
2250 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2251
2252 /* Match NULL() initialization. */
2253 m = gfc_match_null (init);
2254 if (m != MATCH_NO)
2255 return m;
2256
2257 /* Match non-NULL initialization. */
2258 gfc_matching_ptr_assignment = !procptr;
2259 gfc_matching_procptr_assignment = procptr;
2260 m = gfc_match_rvalue (init);
2261 gfc_matching_ptr_assignment = 0;
2262 gfc_matching_procptr_assignment = 0;
2263 if (m == MATCH_ERROR)
2264 return MATCH_ERROR;
2265 else if (m == MATCH_NO)
2266 {
2267 gfc_error ("Error in pointer initialization at %C");
2268 return MATCH_ERROR;
2269 }
2270
2271 if (!procptr && !gfc_resolve_expr (*init))
2272 return MATCH_ERROR;
2273
2274 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2275 "initialization at %C"))
2276 return MATCH_ERROR;
2277
2278 return MATCH_YES;
2279 }
2280
2281
2282 static bool
check_function_name(char * name)2283 check_function_name (char *name)
2284 {
2285 /* In functions that have a RESULT variable defined, the function name always
2286 refers to function calls. Therefore, the name is not allowed to appear in
2287 specification statements. When checking this, be careful about
2288 'hidden' procedure pointer results ('ppr@'). */
2289
2290 if (gfc_current_state () == COMP_FUNCTION)
2291 {
2292 gfc_symbol *block = gfc_current_block ();
2293 if (block && block->result && block->result != block
2294 && strcmp (block->result->name, "ppr@") != 0
2295 && strcmp (block->name, name) == 0)
2296 {
2297 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2298 "from appearing in a specification statement",
2299 block->result->name, &block->result->declared_at, name);
2300 return false;
2301 }
2302 }
2303
2304 return true;
2305 }
2306
2307
2308 /* Match a variable name with an optional initializer. When this
2309 subroutine is called, a variable is expected to be parsed next.
2310 Depending on what is happening at the moment, updates either the
2311 symbol table or the current interface. */
2312
2313 static match
variable_decl(int elem)2314 variable_decl (int elem)
2315 {
2316 char name[GFC_MAX_SYMBOL_LEN + 1];
2317 static unsigned int fill_id = 0;
2318 gfc_expr *initializer, *char_len;
2319 gfc_array_spec *as;
2320 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2321 gfc_charlen *cl;
2322 bool cl_deferred;
2323 locus var_locus;
2324 match m;
2325 bool t;
2326 gfc_symbol *sym;
2327
2328 initializer = NULL;
2329 as = NULL;
2330 cp_as = NULL;
2331
2332 /* When we get here, we've just matched a list of attributes and
2333 maybe a type and a double colon. The next thing we expect to see
2334 is the name of the symbol. */
2335
2336 /* If we are parsing a structure with legacy support, we allow the symbol
2337 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2338 m = MATCH_NO;
2339 gfc_gobble_whitespace ();
2340 if (gfc_peek_ascii_char () == '%')
2341 {
2342 gfc_next_ascii_char ();
2343 m = gfc_match ("fill");
2344 }
2345
2346 if (m != MATCH_YES)
2347 {
2348 m = gfc_match_name (name);
2349 if (m != MATCH_YES)
2350 goto cleanup;
2351 }
2352
2353 else
2354 {
2355 m = MATCH_ERROR;
2356 if (gfc_current_state () != COMP_STRUCTURE)
2357 {
2358 if (flag_dec_structure)
2359 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2360 else
2361 gfc_error ("%qs at %C is a DEC extension, enable with "
2362 "%<-fdec-structure%>", "%FILL");
2363 goto cleanup;
2364 }
2365
2366 if (attr_seen)
2367 {
2368 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2369 goto cleanup;
2370 }
2371
2372 /* %FILL components are given invalid fortran names. */
2373 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2374 m = MATCH_YES;
2375 }
2376
2377 var_locus = gfc_current_locus;
2378
2379 /* Now we could see the optional array spec. or character length. */
2380 m = gfc_match_array_spec (&as, true, true);
2381 if (m == MATCH_ERROR)
2382 goto cleanup;
2383
2384 if (m == MATCH_NO)
2385 as = gfc_copy_array_spec (current_as);
2386 else if (current_as
2387 && !merge_array_spec (current_as, as, true))
2388 {
2389 m = MATCH_ERROR;
2390 goto cleanup;
2391 }
2392
2393 if (flag_cray_pointer)
2394 cp_as = gfc_copy_array_spec (as);
2395
2396 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2397 determine (and check) whether it can be implied-shape. If it
2398 was parsed as assumed-size, change it because PARAMETERs can not
2399 be assumed-size.
2400
2401 An explicit-shape-array cannot appear under several conditions.
2402 That check is done here as well. */
2403 if (as)
2404 {
2405 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2406 {
2407 m = MATCH_ERROR;
2408 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2409 name, &var_locus);
2410 goto cleanup;
2411 }
2412
2413 if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2414 && current_attr.flavor == FL_PARAMETER)
2415 as->type = AS_IMPLIED_SHAPE;
2416
2417 if (as->type == AS_IMPLIED_SHAPE
2418 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2419 &var_locus))
2420 {
2421 m = MATCH_ERROR;
2422 goto cleanup;
2423 }
2424
2425 gfc_seen_div0 = false;
2426
2427 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2428 constant expressions shall appear only in a subprogram, derived
2429 type definition, BLOCK construct, or interface body. */
2430 if (as->type == AS_EXPLICIT
2431 && gfc_current_state () != COMP_BLOCK
2432 && gfc_current_state () != COMP_DERIVED
2433 && gfc_current_state () != COMP_FUNCTION
2434 && gfc_current_state () != COMP_INTERFACE
2435 && gfc_current_state () != COMP_SUBROUTINE)
2436 {
2437 gfc_expr *e;
2438 bool not_constant = false;
2439
2440 for (int i = 0; i < as->rank; i++)
2441 {
2442 e = gfc_copy_expr (as->lower[i]);
2443 if (!gfc_resolve_expr (e) && gfc_seen_div0)
2444 {
2445 m = MATCH_ERROR;
2446 goto cleanup;
2447 }
2448
2449 gfc_simplify_expr (e, 0);
2450 if (e && (e->expr_type != EXPR_CONSTANT))
2451 {
2452 not_constant = true;
2453 break;
2454 }
2455 gfc_free_expr (e);
2456
2457 e = gfc_copy_expr (as->upper[i]);
2458 if (!gfc_resolve_expr (e) && gfc_seen_div0)
2459 {
2460 m = MATCH_ERROR;
2461 goto cleanup;
2462 }
2463
2464 gfc_simplify_expr (e, 0);
2465 if (e && (e->expr_type != EXPR_CONSTANT))
2466 {
2467 not_constant = true;
2468 break;
2469 }
2470 gfc_free_expr (e);
2471 }
2472
2473 if (not_constant)
2474 {
2475 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2476 m = MATCH_ERROR;
2477 goto cleanup;
2478 }
2479 }
2480 if (as->type == AS_EXPLICIT)
2481 {
2482 for (int i = 0; i < as->rank; i++)
2483 {
2484 gfc_expr *e, *n;
2485 e = as->lower[i];
2486 if (e->expr_type != EXPR_CONSTANT)
2487 {
2488 n = gfc_copy_expr (e);
2489 if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2490 {
2491 m = MATCH_ERROR;
2492 goto cleanup;
2493 }
2494
2495 if (n->expr_type == EXPR_CONSTANT)
2496 gfc_replace_expr (e, n);
2497 else
2498 gfc_free_expr (n);
2499 }
2500 e = as->upper[i];
2501 if (e->expr_type != EXPR_CONSTANT)
2502 {
2503 n = gfc_copy_expr (e);
2504 if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2505 {
2506 m = MATCH_ERROR;
2507 goto cleanup;
2508 }
2509
2510 if (n->expr_type == EXPR_CONSTANT)
2511 gfc_replace_expr (e, n);
2512 else
2513 gfc_free_expr (n);
2514 }
2515 }
2516 }
2517 }
2518
2519 char_len = NULL;
2520 cl = NULL;
2521 cl_deferred = false;
2522
2523 if (current_ts.type == BT_CHARACTER)
2524 {
2525 switch (match_char_length (&char_len, &cl_deferred, false))
2526 {
2527 case MATCH_YES:
2528 cl = gfc_new_charlen (gfc_current_ns, NULL);
2529
2530 cl->length = char_len;
2531 break;
2532
2533 /* Non-constant lengths need to be copied after the first
2534 element. Also copy assumed lengths. */
2535 case MATCH_NO:
2536 if (elem > 1
2537 && (current_ts.u.cl->length == NULL
2538 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2539 {
2540 cl = gfc_new_charlen (gfc_current_ns, NULL);
2541 cl->length = gfc_copy_expr (current_ts.u.cl->length);
2542 }
2543 else
2544 cl = current_ts.u.cl;
2545
2546 cl_deferred = current_ts.deferred;
2547
2548 break;
2549
2550 case MATCH_ERROR:
2551 goto cleanup;
2552 }
2553 }
2554
2555 /* The dummy arguments and result of the abreviated form of MODULE
2556 PROCEDUREs, used in SUBMODULES should not be redefined. */
2557 if (gfc_current_ns->proc_name
2558 && gfc_current_ns->proc_name->abr_modproc_decl)
2559 {
2560 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2561 if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2562 {
2563 m = MATCH_ERROR;
2564 gfc_error ("%qs at %C is a redefinition of the declaration "
2565 "in the corresponding interface for MODULE "
2566 "PROCEDURE %qs", sym->name,
2567 gfc_current_ns->proc_name->name);
2568 goto cleanup;
2569 }
2570 }
2571
2572 /* %FILL components may not have initializers. */
2573 if (strncmp (name, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES)
2574 {
2575 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2576 m = MATCH_ERROR;
2577 goto cleanup;
2578 }
2579
2580 /* If this symbol has already shown up in a Cray Pointer declaration,
2581 and this is not a component declaration,
2582 then we want to set the type & bail out. */
2583 if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2584 {
2585 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2586 if (sym != NULL && sym->attr.cray_pointee)
2587 {
2588 sym->ts.type = current_ts.type;
2589 sym->ts.kind = current_ts.kind;
2590 sym->ts.u.cl = cl;
2591 sym->ts.u.derived = current_ts.u.derived;
2592 sym->ts.is_c_interop = current_ts.is_c_interop;
2593 sym->ts.is_iso_c = current_ts.is_iso_c;
2594 m = MATCH_YES;
2595
2596 /* Check to see if we have an array specification. */
2597 if (cp_as != NULL)
2598 {
2599 if (sym->as != NULL)
2600 {
2601 gfc_error ("Duplicate array spec for Cray pointee at %C");
2602 gfc_free_array_spec (cp_as);
2603 m = MATCH_ERROR;
2604 goto cleanup;
2605 }
2606 else
2607 {
2608 if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2609 gfc_internal_error ("Couldn't set pointee array spec.");
2610
2611 /* Fix the array spec. */
2612 m = gfc_mod_pointee_as (sym->as);
2613 if (m == MATCH_ERROR)
2614 goto cleanup;
2615 }
2616 }
2617 goto cleanup;
2618 }
2619 else
2620 {
2621 gfc_free_array_spec (cp_as);
2622 }
2623 }
2624
2625 /* Procedure pointer as function result. */
2626 if (gfc_current_state () == COMP_FUNCTION
2627 && strcmp ("ppr@", gfc_current_block ()->name) == 0
2628 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2629 strcpy (name, "ppr@");
2630
2631 if (gfc_current_state () == COMP_FUNCTION
2632 && strcmp (name, gfc_current_block ()->name) == 0
2633 && gfc_current_block ()->result
2634 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2635 strcpy (name, "ppr@");
2636
2637 /* OK, we've successfully matched the declaration. Now put the
2638 symbol in the current namespace, because it might be used in the
2639 optional initialization expression for this symbol, e.g. this is
2640 perfectly legal:
2641
2642 integer, parameter :: i = huge(i)
2643
2644 This is only true for parameters or variables of a basic type.
2645 For components of derived types, it is not true, so we don't
2646 create a symbol for those yet. If we fail to create the symbol,
2647 bail out. */
2648 if (!gfc_comp_struct (gfc_current_state ())
2649 && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2650 {
2651 m = MATCH_ERROR;
2652 goto cleanup;
2653 }
2654
2655 if (!check_function_name (name))
2656 {
2657 m = MATCH_ERROR;
2658 goto cleanup;
2659 }
2660
2661 /* We allow old-style initializations of the form
2662 integer i /2/, j(4) /3*3, 1/
2663 (if no colon has been seen). These are different from data
2664 statements in that initializers are only allowed to apply to the
2665 variable immediately preceding, i.e.
2666 integer i, j /1, 2/
2667 is not allowed. Therefore we have to do some work manually, that
2668 could otherwise be left to the matchers for DATA statements. */
2669
2670 if (!colon_seen && gfc_match (" /") == MATCH_YES)
2671 {
2672 if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2673 "initialization at %C"))
2674 return MATCH_ERROR;
2675
2676 /* Allow old style initializations for components of STRUCTUREs and MAPs
2677 but not components of derived types. */
2678 else if (gfc_current_state () == COMP_DERIVED)
2679 {
2680 gfc_error ("Invalid old style initialization for derived type "
2681 "component at %C");
2682 m = MATCH_ERROR;
2683 goto cleanup;
2684 }
2685
2686 /* For structure components, read the initializer as a special
2687 expression and let the rest of this function apply the initializer
2688 as usual. */
2689 else if (gfc_comp_struct (gfc_current_state ()))
2690 {
2691 m = match_clist_expr (&initializer, ¤t_ts, as);
2692 if (m == MATCH_NO)
2693 gfc_error ("Syntax error in old style initialization of %s at %C",
2694 name);
2695 if (m != MATCH_YES)
2696 goto cleanup;
2697 }
2698
2699 /* Otherwise we treat the old style initialization just like a
2700 DATA declaration for the current variable. */
2701 else
2702 return match_old_style_init (name);
2703 }
2704
2705 /* The double colon must be present in order to have initializers.
2706 Otherwise the statement is ambiguous with an assignment statement. */
2707 if (colon_seen)
2708 {
2709 if (gfc_match (" =>") == MATCH_YES)
2710 {
2711 if (!current_attr.pointer)
2712 {
2713 gfc_error ("Initialization at %C isn't for a pointer variable");
2714 m = MATCH_ERROR;
2715 goto cleanup;
2716 }
2717
2718 m = match_pointer_init (&initializer, 0);
2719 if (m != MATCH_YES)
2720 goto cleanup;
2721 }
2722 else if (gfc_match_char ('=') == MATCH_YES)
2723 {
2724 if (current_attr.pointer)
2725 {
2726 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2727 "not %<=%>");
2728 m = MATCH_ERROR;
2729 goto cleanup;
2730 }
2731
2732 m = gfc_match_init_expr (&initializer);
2733 if (m == MATCH_NO)
2734 {
2735 gfc_error ("Expected an initialization expression at %C");
2736 m = MATCH_ERROR;
2737 }
2738
2739 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
2740 && !gfc_comp_struct (gfc_state_stack->state))
2741 {
2742 gfc_error ("Initialization of variable at %C is not allowed in "
2743 "a PURE procedure");
2744 m = MATCH_ERROR;
2745 }
2746
2747 if (current_attr.flavor != FL_PARAMETER
2748 && !gfc_comp_struct (gfc_state_stack->state))
2749 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2750
2751 if (m != MATCH_YES)
2752 goto cleanup;
2753 }
2754 }
2755
2756 if (initializer != NULL && current_attr.allocatable
2757 && gfc_comp_struct (gfc_current_state ()))
2758 {
2759 gfc_error ("Initialization of allocatable component at %C is not "
2760 "allowed");
2761 m = MATCH_ERROR;
2762 goto cleanup;
2763 }
2764
2765 if (gfc_current_state () == COMP_DERIVED
2766 && gfc_current_block ()->attr.pdt_template)
2767 {
2768 gfc_symbol *param;
2769 gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
2770 0, ¶m);
2771 if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
2772 {
2773 gfc_error ("The component with KIND or LEN attribute at %C does not "
2774 "not appear in the type parameter list at %L",
2775 &gfc_current_block ()->declared_at);
2776 m = MATCH_ERROR;
2777 goto cleanup;
2778 }
2779 else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
2780 {
2781 gfc_error ("The component at %C that appears in the type parameter "
2782 "list at %L has neither the KIND nor LEN attribute",
2783 &gfc_current_block ()->declared_at);
2784 m = MATCH_ERROR;
2785 goto cleanup;
2786 }
2787 else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
2788 {
2789 gfc_error ("The component at %C which is a type parameter must be "
2790 "a scalar");
2791 m = MATCH_ERROR;
2792 goto cleanup;
2793 }
2794 else if (param && initializer)
2795 param->value = gfc_copy_expr (initializer);
2796 }
2797
2798 /* Before adding a possible initilizer, do a simple check for compatibility
2799 of lhs and rhs types. Assigning a REAL value to a derive type is not a
2800 good thing. */
2801 if (current_ts.type == BT_DERIVED && initializer
2802 && (gfc_numeric_ts (&initializer->ts)
2803 || initializer->ts.type == BT_LOGICAL
2804 || initializer->ts.type == BT_CHARACTER))
2805 {
2806 gfc_error ("Incompatible initialization between a derive type "
2807 "entity and an entity with %qs type at %C",
2808 gfc_typename (&initializer->ts));
2809 m = MATCH_ERROR;
2810 goto cleanup;
2811 }
2812
2813
2814 /* Add the initializer. Note that it is fine if initializer is
2815 NULL here, because we sometimes also need to check if a
2816 declaration *must* have an initialization expression. */
2817 if (!gfc_comp_struct (gfc_current_state ()))
2818 t = add_init_expr_to_sym (name, &initializer, &var_locus);
2819 else
2820 {
2821 if (current_ts.type == BT_DERIVED
2822 && !current_attr.pointer && !initializer)
2823 initializer = gfc_default_initializer (¤t_ts);
2824 t = build_struct (name, cl, &initializer, &as);
2825
2826 /* If we match a nested structure definition we expect to see the
2827 * body even if the variable declarations blow up, so we need to keep
2828 * the structure declaration around. */
2829 if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
2830 gfc_commit_symbol (gfc_new_block);
2831 }
2832
2833 m = (t) ? MATCH_YES : MATCH_ERROR;
2834
2835 cleanup:
2836 /* Free stuff up and return. */
2837 gfc_seen_div0 = false;
2838 gfc_free_expr (initializer);
2839 gfc_free_array_spec (as);
2840
2841 return m;
2842 }
2843
2844
2845 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2846 This assumes that the byte size is equal to the kind number for
2847 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2848
2849 match
gfc_match_old_kind_spec(gfc_typespec * ts)2850 gfc_match_old_kind_spec (gfc_typespec *ts)
2851 {
2852 match m;
2853 int original_kind;
2854
2855 if (gfc_match_char ('*') != MATCH_YES)
2856 return MATCH_NO;
2857
2858 m = gfc_match_small_literal_int (&ts->kind, NULL);
2859 if (m != MATCH_YES)
2860 return MATCH_ERROR;
2861
2862 original_kind = ts->kind;
2863
2864 /* Massage the kind numbers for complex types. */
2865 if (ts->type == BT_COMPLEX)
2866 {
2867 if (ts->kind % 2)
2868 {
2869 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2870 gfc_basic_typename (ts->type), original_kind);
2871 return MATCH_ERROR;
2872 }
2873 ts->kind /= 2;
2874
2875 }
2876
2877 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2878 ts->kind = 8;
2879
2880 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2881 {
2882 if (ts->kind == 4)
2883 {
2884 if (flag_real4_kind == 8)
2885 ts->kind = 8;
2886 if (flag_real4_kind == 10)
2887 ts->kind = 10;
2888 if (flag_real4_kind == 16)
2889 ts->kind = 16;
2890 }
2891
2892 if (ts->kind == 8)
2893 {
2894 if (flag_real8_kind == 4)
2895 ts->kind = 4;
2896 if (flag_real8_kind == 10)
2897 ts->kind = 10;
2898 if (flag_real8_kind == 16)
2899 ts->kind = 16;
2900 }
2901 }
2902
2903 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2904 {
2905 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2906 gfc_basic_typename (ts->type), original_kind);
2907 return MATCH_ERROR;
2908 }
2909
2910 if (!gfc_notify_std (GFC_STD_GNU,
2911 "Nonstandard type declaration %s*%d at %C",
2912 gfc_basic_typename(ts->type), original_kind))
2913 return MATCH_ERROR;
2914
2915 return MATCH_YES;
2916 }
2917
2918
2919 /* Match a kind specification. Since kinds are generally optional, we
2920 usually return MATCH_NO if something goes wrong. If a "kind="
2921 string is found, then we know we have an error. */
2922
2923 match
gfc_match_kind_spec(gfc_typespec * ts,bool kind_expr_only)2924 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2925 {
2926 locus where, loc;
2927 gfc_expr *e;
2928 match m, n;
2929 char c;
2930
2931 m = MATCH_NO;
2932 n = MATCH_YES;
2933 e = NULL;
2934 saved_kind_expr = NULL;
2935
2936 where = loc = gfc_current_locus;
2937
2938 if (kind_expr_only)
2939 goto kind_expr;
2940
2941 if (gfc_match_char ('(') == MATCH_NO)
2942 return MATCH_NO;
2943
2944 /* Also gobbles optional text. */
2945 if (gfc_match (" kind = ") == MATCH_YES)
2946 m = MATCH_ERROR;
2947
2948 loc = gfc_current_locus;
2949
2950 kind_expr:
2951
2952 n = gfc_match_init_expr (&e);
2953
2954 if (gfc_derived_parameter_expr (e))
2955 {
2956 ts->kind = 0;
2957 saved_kind_expr = gfc_copy_expr (e);
2958 goto close_brackets;
2959 }
2960
2961 if (n != MATCH_YES)
2962 {
2963 if (gfc_matching_function)
2964 {
2965 /* The function kind expression might include use associated or
2966 imported parameters and try again after the specification
2967 expressions..... */
2968 if (gfc_match_char (')') != MATCH_YES)
2969 {
2970 gfc_error ("Missing right parenthesis at %C");
2971 m = MATCH_ERROR;
2972 goto no_match;
2973 }
2974
2975 gfc_free_expr (e);
2976 gfc_undo_symbols ();
2977 return MATCH_YES;
2978 }
2979 else
2980 {
2981 /* ....or else, the match is real. */
2982 if (n == MATCH_NO)
2983 gfc_error ("Expected initialization expression at %C");
2984 if (n != MATCH_YES)
2985 return MATCH_ERROR;
2986 }
2987 }
2988
2989 if (e->rank != 0)
2990 {
2991 gfc_error ("Expected scalar initialization expression at %C");
2992 m = MATCH_ERROR;
2993 goto no_match;
2994 }
2995
2996 if (gfc_extract_int (e, &ts->kind, 1))
2997 {
2998 m = MATCH_ERROR;
2999 goto no_match;
3000 }
3001
3002 /* Before throwing away the expression, let's see if we had a
3003 C interoperable kind (and store the fact). */
3004 if (e->ts.is_c_interop == 1)
3005 {
3006 /* Mark this as C interoperable if being declared with one
3007 of the named constants from iso_c_binding. */
3008 ts->is_c_interop = e->ts.is_iso_c;
3009 ts->f90_type = e->ts.f90_type;
3010 if (e->symtree)
3011 ts->interop_kind = e->symtree->n.sym;
3012 }
3013
3014 gfc_free_expr (e);
3015 e = NULL;
3016
3017 /* Ignore errors to this point, if we've gotten here. This means
3018 we ignore the m=MATCH_ERROR from above. */
3019 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3020 {
3021 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3022 gfc_basic_typename (ts->type));
3023 gfc_current_locus = where;
3024 return MATCH_ERROR;
3025 }
3026
3027 /* Warn if, e.g., c_int is used for a REAL variable, but not
3028 if, e.g., c_double is used for COMPLEX as the standard
3029 explicitly says that the kind type parameter for complex and real
3030 variable is the same, i.e. c_float == c_float_complex. */
3031 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3032 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3033 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3034 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3035 "is %s", gfc_basic_typename (ts->f90_type), &where,
3036 gfc_basic_typename (ts->type));
3037
3038 close_brackets:
3039
3040 gfc_gobble_whitespace ();
3041 if ((c = gfc_next_ascii_char ()) != ')'
3042 && (ts->type != BT_CHARACTER || c != ','))
3043 {
3044 if (ts->type == BT_CHARACTER)
3045 gfc_error ("Missing right parenthesis or comma at %C");
3046 else
3047 gfc_error ("Missing right parenthesis at %C");
3048 m = MATCH_ERROR;
3049 }
3050 else
3051 /* All tests passed. */
3052 m = MATCH_YES;
3053
3054 if(m == MATCH_ERROR)
3055 gfc_current_locus = where;
3056
3057 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3058 ts->kind = 8;
3059
3060 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3061 {
3062 if (ts->kind == 4)
3063 {
3064 if (flag_real4_kind == 8)
3065 ts->kind = 8;
3066 if (flag_real4_kind == 10)
3067 ts->kind = 10;
3068 if (flag_real4_kind == 16)
3069 ts->kind = 16;
3070 }
3071
3072 if (ts->kind == 8)
3073 {
3074 if (flag_real8_kind == 4)
3075 ts->kind = 4;
3076 if (flag_real8_kind == 10)
3077 ts->kind = 10;
3078 if (flag_real8_kind == 16)
3079 ts->kind = 16;
3080 }
3081 }
3082
3083 /* Return what we know from the test(s). */
3084 return m;
3085
3086 no_match:
3087 gfc_free_expr (e);
3088 gfc_current_locus = where;
3089 return m;
3090 }
3091
3092
3093 static match
match_char_kind(int * kind,int * is_iso_c)3094 match_char_kind (int * kind, int * is_iso_c)
3095 {
3096 locus where;
3097 gfc_expr *e;
3098 match m, n;
3099 bool fail;
3100
3101 m = MATCH_NO;
3102 e = NULL;
3103 where = gfc_current_locus;
3104
3105 n = gfc_match_init_expr (&e);
3106
3107 if (n != MATCH_YES && gfc_matching_function)
3108 {
3109 /* The expression might include use-associated or imported
3110 parameters and try again after the specification
3111 expressions. */
3112 gfc_free_expr (e);
3113 gfc_undo_symbols ();
3114 return MATCH_YES;
3115 }
3116
3117 if (n == MATCH_NO)
3118 gfc_error ("Expected initialization expression at %C");
3119 if (n != MATCH_YES)
3120 return MATCH_ERROR;
3121
3122 if (e->rank != 0)
3123 {
3124 gfc_error ("Expected scalar initialization expression at %C");
3125 m = MATCH_ERROR;
3126 goto no_match;
3127 }
3128
3129 if (gfc_derived_parameter_expr (e))
3130 {
3131 saved_kind_expr = e;
3132 *kind = 0;
3133 return MATCH_YES;
3134 }
3135
3136 fail = gfc_extract_int (e, kind, 1);
3137 *is_iso_c = e->ts.is_iso_c;
3138 if (fail)
3139 {
3140 m = MATCH_ERROR;
3141 goto no_match;
3142 }
3143
3144 gfc_free_expr (e);
3145
3146 /* Ignore errors to this point, if we've gotten here. This means
3147 we ignore the m=MATCH_ERROR from above. */
3148 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3149 {
3150 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3151 m = MATCH_ERROR;
3152 }
3153 else
3154 /* All tests passed. */
3155 m = MATCH_YES;
3156
3157 if (m == MATCH_ERROR)
3158 gfc_current_locus = where;
3159
3160 /* Return what we know from the test(s). */
3161 return m;
3162
3163 no_match:
3164 gfc_free_expr (e);
3165 gfc_current_locus = where;
3166 return m;
3167 }
3168
3169
3170 /* Match the various kind/length specifications in a CHARACTER
3171 declaration. We don't return MATCH_NO. */
3172
3173 match
gfc_match_char_spec(gfc_typespec * ts)3174 gfc_match_char_spec (gfc_typespec *ts)
3175 {
3176 int kind, seen_length, is_iso_c;
3177 gfc_charlen *cl;
3178 gfc_expr *len;
3179 match m;
3180 bool deferred;
3181
3182 len = NULL;
3183 seen_length = 0;
3184 kind = 0;
3185 is_iso_c = 0;
3186 deferred = false;
3187
3188 /* Try the old-style specification first. */
3189 old_char_selector = 0;
3190
3191 m = match_char_length (&len, &deferred, true);
3192 if (m != MATCH_NO)
3193 {
3194 if (m == MATCH_YES)
3195 old_char_selector = 1;
3196 seen_length = 1;
3197 goto done;
3198 }
3199
3200 m = gfc_match_char ('(');
3201 if (m != MATCH_YES)
3202 {
3203 m = MATCH_YES; /* Character without length is a single char. */
3204 goto done;
3205 }
3206
3207 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3208 if (gfc_match (" kind =") == MATCH_YES)
3209 {
3210 m = match_char_kind (&kind, &is_iso_c);
3211
3212 if (m == MATCH_ERROR)
3213 goto done;
3214 if (m == MATCH_NO)
3215 goto syntax;
3216
3217 if (gfc_match (" , len =") == MATCH_NO)
3218 goto rparen;
3219
3220 m = char_len_param_value (&len, &deferred);
3221 if (m == MATCH_NO)
3222 goto syntax;
3223 if (m == MATCH_ERROR)
3224 goto done;
3225 seen_length = 1;
3226
3227 goto rparen;
3228 }
3229
3230 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3231 if (gfc_match (" len =") == MATCH_YES)
3232 {
3233 m = char_len_param_value (&len, &deferred);
3234 if (m == MATCH_NO)
3235 goto syntax;
3236 if (m == MATCH_ERROR)
3237 goto done;
3238 seen_length = 1;
3239
3240 if (gfc_match_char (')') == MATCH_YES)
3241 goto done;
3242
3243 if (gfc_match (" , kind =") != MATCH_YES)
3244 goto syntax;
3245
3246 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3247 goto done;
3248
3249 goto rparen;
3250 }
3251
3252 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3253 m = char_len_param_value (&len, &deferred);
3254 if (m == MATCH_NO)
3255 goto syntax;
3256 if (m == MATCH_ERROR)
3257 goto done;
3258 seen_length = 1;
3259
3260 m = gfc_match_char (')');
3261 if (m == MATCH_YES)
3262 goto done;
3263
3264 if (gfc_match_char (',') != MATCH_YES)
3265 goto syntax;
3266
3267 gfc_match (" kind ="); /* Gobble optional text. */
3268
3269 m = match_char_kind (&kind, &is_iso_c);
3270 if (m == MATCH_ERROR)
3271 goto done;
3272 if (m == MATCH_NO)
3273 goto syntax;
3274
3275 rparen:
3276 /* Require a right-paren at this point. */
3277 m = gfc_match_char (')');
3278 if (m == MATCH_YES)
3279 goto done;
3280
3281 syntax:
3282 gfc_error ("Syntax error in CHARACTER declaration at %C");
3283 m = MATCH_ERROR;
3284 gfc_free_expr (len);
3285 return m;
3286
3287 done:
3288 /* Deal with character functions after USE and IMPORT statements. */
3289 if (gfc_matching_function)
3290 {
3291 gfc_free_expr (len);
3292 gfc_undo_symbols ();
3293 return MATCH_YES;
3294 }
3295
3296 if (m != MATCH_YES)
3297 {
3298 gfc_free_expr (len);
3299 return m;
3300 }
3301
3302 /* Do some final massaging of the length values. */
3303 cl = gfc_new_charlen (gfc_current_ns, NULL);
3304
3305 if (seen_length == 0)
3306 cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3307 else
3308 {
3309 /* If gfortran ends up here, then len may be reducible to a constant.
3310 Try to do that here. If it does not reduce, simply assign len to
3311 charlen. A complication occurs with user-defined generic functions,
3312 which are not resolved. Use a private namespace to deal with
3313 generic functions. */
3314
3315 if (len && len->expr_type != EXPR_CONSTANT)
3316 {
3317 gfc_namespace *old_ns;
3318 gfc_expr *e;
3319
3320 old_ns = gfc_current_ns;
3321 gfc_current_ns = gfc_get_namespace (NULL, 0);
3322
3323 e = gfc_copy_expr (len);
3324 gfc_reduce_init_expr (e);
3325 if (e->expr_type == EXPR_CONSTANT)
3326 {
3327 gfc_replace_expr (len, e);
3328 if (mpz_cmp_si (len->value.integer, 0) < 0)
3329 mpz_set_ui (len->value.integer, 0);
3330 }
3331 else
3332 gfc_free_expr (e);
3333
3334 gfc_free_namespace (gfc_current_ns);
3335 gfc_current_ns = old_ns;
3336 }
3337
3338 cl->length = len;
3339 }
3340
3341 ts->u.cl = cl;
3342 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3343 ts->deferred = deferred;
3344
3345 /* We have to know if it was a C interoperable kind so we can
3346 do accurate type checking of bind(c) procs, etc. */
3347 if (kind != 0)
3348 /* Mark this as C interoperable if being declared with one
3349 of the named constants from iso_c_binding. */
3350 ts->is_c_interop = is_iso_c;
3351 else if (len != NULL)
3352 /* Here, we might have parsed something such as: character(c_char)
3353 In this case, the parsing code above grabs the c_char when
3354 looking for the length (line 1690, roughly). it's the last
3355 testcase for parsing the kind params of a character variable.
3356 However, it's not actually the length. this seems like it
3357 could be an error.
3358 To see if the user used a C interop kind, test the expr
3359 of the so called length, and see if it's C interoperable. */
3360 ts->is_c_interop = len->ts.is_iso_c;
3361
3362 return MATCH_YES;
3363 }
3364
3365
3366 /* Matches a RECORD declaration. */
3367
3368 static match
match_record_decl(char * name)3369 match_record_decl (char *name)
3370 {
3371 locus old_loc;
3372 old_loc = gfc_current_locus;
3373 match m;
3374
3375 m = gfc_match (" record /");
3376 if (m == MATCH_YES)
3377 {
3378 if (!flag_dec_structure)
3379 {
3380 gfc_current_locus = old_loc;
3381 gfc_error ("RECORD at %C is an extension, enable it with "
3382 "-fdec-structure");
3383 return MATCH_ERROR;
3384 }
3385 m = gfc_match (" %n/", name);
3386 if (m == MATCH_YES)
3387 return MATCH_YES;
3388 }
3389
3390 gfc_current_locus = old_loc;
3391 if (flag_dec_structure
3392 && (gfc_match (" record% ") == MATCH_YES
3393 || gfc_match (" record%t") == MATCH_YES))
3394 gfc_error ("Structure name expected after RECORD at %C");
3395 if (m == MATCH_NO)
3396 return MATCH_NO;
3397
3398 return MATCH_ERROR;
3399 }
3400
3401
3402 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3403 of expressions to substitute into the possibly parameterized expression
3404 'e'. Using a list is inefficient but should not be too bad since the
3405 number of type parameters is not likely to be large. */
3406 static bool
insert_parameter_exprs(gfc_expr * e,gfc_symbol * sym ATTRIBUTE_UNUSED,int * f)3407 insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3408 int* f)
3409 {
3410 gfc_actual_arglist *param;
3411 gfc_expr *copy;
3412
3413 if (e->expr_type != EXPR_VARIABLE)
3414 return false;
3415
3416 gcc_assert (e->symtree);
3417 if (e->symtree->n.sym->attr.pdt_kind
3418 || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3419 {
3420 for (param = type_param_spec_list; param; param = param->next)
3421 if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3422 break;
3423
3424 if (param)
3425 {
3426 copy = gfc_copy_expr (param->expr);
3427 *e = *copy;
3428 free (copy);
3429 }
3430 }
3431
3432 return false;
3433 }
3434
3435
3436 bool
gfc_insert_kind_parameter_exprs(gfc_expr * e)3437 gfc_insert_kind_parameter_exprs (gfc_expr *e)
3438 {
3439 return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3440 }
3441
3442
3443 bool
gfc_insert_parameter_exprs(gfc_expr * e,gfc_actual_arglist * param_list)3444 gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3445 {
3446 gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3447 type_param_spec_list = param_list;
3448 return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3449 type_param_spec_list = NULL;
3450 type_param_spec_list = old_param_spec_list;
3451 }
3452
3453 /* Determines the instance of a parameterized derived type to be used by
3454 matching determining the values of the kind parameters and using them
3455 in the name of the instance. If the instance exists, it is used, otherwise
3456 a new derived type is created. */
3457 match
gfc_get_pdt_instance(gfc_actual_arglist * param_list,gfc_symbol ** sym,gfc_actual_arglist ** ext_param_list)3458 gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3459 gfc_actual_arglist **ext_param_list)
3460 {
3461 /* The PDT template symbol. */
3462 gfc_symbol *pdt = *sym;
3463 /* The symbol for the parameter in the template f2k_namespace. */
3464 gfc_symbol *param;
3465 /* The hoped for instance of the PDT. */
3466 gfc_symbol *instance;
3467 /* The list of parameters appearing in the PDT declaration. */
3468 gfc_formal_arglist *type_param_name_list;
3469 /* Used to store the parameter specification list during recursive calls. */
3470 gfc_actual_arglist *old_param_spec_list;
3471 /* Pointers to the parameter specification being used. */
3472 gfc_actual_arglist *actual_param;
3473 gfc_actual_arglist *tail = NULL;
3474 /* Used to build up the name of the PDT instance. The prefix uses 4
3475 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3476 char name[GFC_MAX_SYMBOL_LEN + 21];
3477
3478 bool name_seen = (param_list == NULL);
3479 bool assumed_seen = false;
3480 bool deferred_seen = false;
3481 bool spec_error = false;
3482 int kind_value, i;
3483 gfc_expr *kind_expr;
3484 gfc_component *c1, *c2;
3485 match m;
3486
3487 type_param_spec_list = NULL;
3488
3489 type_param_name_list = pdt->formal;
3490 actual_param = param_list;
3491 sprintf (name, "Pdt%s", pdt->name);
3492
3493 /* Run through the parameter name list and pick up the actual
3494 parameter values or use the default values in the PDT declaration. */
3495 for (; type_param_name_list;
3496 type_param_name_list = type_param_name_list->next)
3497 {
3498 if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3499 {
3500 if (actual_param->spec_type == SPEC_ASSUMED)
3501 spec_error = deferred_seen;
3502 else
3503 spec_error = assumed_seen;
3504
3505 if (spec_error)
3506 {
3507 gfc_error ("The type parameter spec list at %C cannot contain "
3508 "both ASSUMED and DEFERRED parameters");
3509 goto error_return;
3510 }
3511 }
3512
3513 if (actual_param && actual_param->name)
3514 name_seen = true;
3515 param = type_param_name_list->sym;
3516
3517 if (!param || !param->name)
3518 continue;
3519
3520 c1 = gfc_find_component (pdt, param->name, false, true, NULL);
3521 /* An error should already have been thrown in resolve.c
3522 (resolve_fl_derived0). */
3523 if (!pdt->attr.use_assoc && !c1)
3524 goto error_return;
3525
3526 kind_expr = NULL;
3527 if (!name_seen)
3528 {
3529 if (!actual_param && !(c1 && c1->initializer))
3530 {
3531 gfc_error ("The type parameter spec list at %C does not contain "
3532 "enough parameter expressions");
3533 goto error_return;
3534 }
3535 else if (!actual_param && c1 && c1->initializer)
3536 kind_expr = gfc_copy_expr (c1->initializer);
3537 else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3538 kind_expr = gfc_copy_expr (actual_param->expr);
3539 }
3540 else
3541 {
3542 actual_param = param_list;
3543 for (;actual_param; actual_param = actual_param->next)
3544 if (actual_param->name
3545 && strcmp (actual_param->name, param->name) == 0)
3546 break;
3547 if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3548 kind_expr = gfc_copy_expr (actual_param->expr);
3549 else
3550 {
3551 if (c1->initializer)
3552 kind_expr = gfc_copy_expr (c1->initializer);
3553 else if (!(actual_param && param->attr.pdt_len))
3554 {
3555 gfc_error ("The derived parameter %qs at %C does not "
3556 "have a default value", param->name);
3557 goto error_return;
3558 }
3559 }
3560 }
3561
3562 /* Store the current parameter expressions in a temporary actual
3563 arglist 'list' so that they can be substituted in the corresponding
3564 expressions in the PDT instance. */
3565 if (type_param_spec_list == NULL)
3566 {
3567 type_param_spec_list = gfc_get_actual_arglist ();
3568 tail = type_param_spec_list;
3569 }
3570 else
3571 {
3572 tail->next = gfc_get_actual_arglist ();
3573 tail = tail->next;
3574 }
3575 tail->name = param->name;
3576
3577 if (kind_expr)
3578 {
3579 /* Try simplification even for LEN expressions. */
3580 gfc_resolve_expr (kind_expr);
3581 gfc_simplify_expr (kind_expr, 1);
3582 /* Variable expressions seem to default to BT_PROCEDURE.
3583 TODO find out why this is and fix it. */
3584 if (kind_expr->ts.type != BT_INTEGER
3585 && kind_expr->ts.type != BT_PROCEDURE)
3586 {
3587 gfc_error ("The parameter expression at %C must be of "
3588 "INTEGER type and not %s type",
3589 gfc_basic_typename (kind_expr->ts.type));
3590 goto error_return;
3591 }
3592
3593 tail->expr = gfc_copy_expr (kind_expr);
3594 }
3595
3596 if (actual_param)
3597 tail->spec_type = actual_param->spec_type;
3598
3599 if (!param->attr.pdt_kind)
3600 {
3601 if (!name_seen && actual_param)
3602 actual_param = actual_param->next;
3603 if (kind_expr)
3604 {
3605 gfc_free_expr (kind_expr);
3606 kind_expr = NULL;
3607 }
3608 continue;
3609 }
3610
3611 if (actual_param
3612 && (actual_param->spec_type == SPEC_ASSUMED
3613 || actual_param->spec_type == SPEC_DEFERRED))
3614 {
3615 gfc_error ("The KIND parameter %qs at %C cannot either be "
3616 "ASSUMED or DEFERRED", param->name);
3617 goto error_return;
3618 }
3619
3620 if (!kind_expr || !gfc_is_constant_expr (kind_expr))
3621 {
3622 gfc_error ("The value for the KIND parameter %qs at %C does not "
3623 "reduce to a constant expression", param->name);
3624 goto error_return;
3625 }
3626
3627 gfc_extract_int (kind_expr, &kind_value);
3628 sprintf (name + strlen (name), "_%d", kind_value);
3629
3630 if (!name_seen && actual_param)
3631 actual_param = actual_param->next;
3632 gfc_free_expr (kind_expr);
3633 }
3634
3635 if (!name_seen && actual_param)
3636 {
3637 gfc_error ("The type parameter spec list at %C contains too many "
3638 "parameter expressions");
3639 goto error_return;
3640 }
3641
3642 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3643 build it, using 'pdt' as a template. */
3644 if (gfc_get_symbol (name, pdt->ns, &instance))
3645 {
3646 gfc_error ("Parameterized derived type at %C is ambiguous");
3647 goto error_return;
3648 }
3649
3650 m = MATCH_YES;
3651
3652 if (instance->attr.flavor == FL_DERIVED
3653 && instance->attr.pdt_type)
3654 {
3655 instance->refs++;
3656 if (ext_param_list)
3657 *ext_param_list = type_param_spec_list;
3658 *sym = instance;
3659 gfc_commit_symbols ();
3660 return m;
3661 }
3662
3663 /* Start building the new instance of the parameterized type. */
3664 gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
3665 instance->attr.pdt_template = 0;
3666 instance->attr.pdt_type = 1;
3667 instance->declared_at = gfc_current_locus;
3668
3669 /* Add the components, replacing the parameters in all expressions
3670 with the expressions for their values in 'type_param_spec_list'. */
3671 c1 = pdt->components;
3672 tail = type_param_spec_list;
3673 for (; c1; c1 = c1->next)
3674 {
3675 gfc_add_component (instance, c1->name, &c2);
3676
3677 c2->ts = c1->ts;
3678 c2->attr = c1->attr;
3679
3680 /* The order of declaration of the type_specs might not be the
3681 same as that of the components. */
3682 if (c1->attr.pdt_kind || c1->attr.pdt_len)
3683 {
3684 for (tail = type_param_spec_list; tail; tail = tail->next)
3685 if (strcmp (c1->name, tail->name) == 0)
3686 break;
3687 }
3688
3689 /* Deal with type extension by recursively calling this function
3690 to obtain the instance of the extended type. */
3691 if (gfc_current_state () != COMP_DERIVED
3692 && c1 == pdt->components
3693 && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
3694 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
3695 && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
3696 {
3697 gfc_formal_arglist *f;
3698
3699 old_param_spec_list = type_param_spec_list;
3700
3701 /* Obtain a spec list appropriate to the extended type..*/
3702 actual_param = gfc_copy_actual_arglist (type_param_spec_list);
3703 type_param_spec_list = actual_param;
3704 for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
3705 actual_param = actual_param->next;
3706 if (actual_param)
3707 {
3708 gfc_free_actual_arglist (actual_param->next);
3709 actual_param->next = NULL;
3710 }
3711
3712 /* Now obtain the PDT instance for the extended type. */
3713 c2->param_list = type_param_spec_list;
3714 m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
3715 NULL);
3716 type_param_spec_list = old_param_spec_list;
3717
3718 c2->ts.u.derived->refs++;
3719 gfc_set_sym_referenced (c2->ts.u.derived);
3720
3721 /* Set extension level. */
3722 if (c2->ts.u.derived->attr.extension == 255)
3723 {
3724 /* Since the extension field is 8 bit wide, we can only have
3725 up to 255 extension levels. */
3726 gfc_error ("Maximum extension level reached with type %qs at %L",
3727 c2->ts.u.derived->name,
3728 &c2->ts.u.derived->declared_at);
3729 goto error_return;
3730 }
3731 instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
3732
3733 continue;
3734 }
3735
3736 /* Set the component kind using the parameterized expression. */
3737 if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
3738 && c1->kind_expr != NULL)
3739 {
3740 gfc_expr *e = gfc_copy_expr (c1->kind_expr);
3741 gfc_insert_kind_parameter_exprs (e);
3742 gfc_simplify_expr (e, 1);
3743 gfc_extract_int (e, &c2->ts.kind);
3744 gfc_free_expr (e);
3745 if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
3746 {
3747 gfc_error ("Kind %d not supported for type %s at %C",
3748 c2->ts.kind, gfc_basic_typename (c2->ts.type));
3749 goto error_return;
3750 }
3751 }
3752
3753 /* Similarly, set the string length if parameterized. */
3754 if (c1->ts.type == BT_CHARACTER
3755 && c1->ts.u.cl->length
3756 && gfc_derived_parameter_expr (c1->ts.u.cl->length))
3757 {
3758 gfc_expr *e;
3759 e = gfc_copy_expr (c1->ts.u.cl->length);
3760 gfc_insert_kind_parameter_exprs (e);
3761 gfc_simplify_expr (e, 1);
3762 c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3763 c2->ts.u.cl->length = e;
3764 c2->attr.pdt_string = 1;
3765 }
3766
3767 /* Set up either the KIND/LEN initializer, if constant,
3768 or the parameterized expression. Use the template
3769 initializer if one is not already set in this instance. */
3770 if (c2->attr.pdt_kind || c2->attr.pdt_len)
3771 {
3772 if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
3773 c2->initializer = gfc_copy_expr (tail->expr);
3774 else if (tail && tail->expr)
3775 {
3776 c2->param_list = gfc_get_actual_arglist ();
3777 c2->param_list->name = tail->name;
3778 c2->param_list->expr = gfc_copy_expr (tail->expr);
3779 c2->param_list->next = NULL;
3780 }
3781
3782 if (!c2->initializer && c1->initializer)
3783 c2->initializer = gfc_copy_expr (c1->initializer);
3784 }
3785
3786 /* Copy the array spec. */
3787 c2->as = gfc_copy_array_spec (c1->as);
3788 if (c1->ts.type == BT_CLASS)
3789 CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
3790
3791 /* Determine if an array spec is parameterized. If so, substitute
3792 in the parameter expressions for the bounds and set the pdt_array
3793 attribute. Notice that this attribute must be unconditionally set
3794 if this is an array of parameterized character length. */
3795 if (c1->as && c1->as->type == AS_EXPLICIT)
3796 {
3797 bool pdt_array = false;
3798
3799 /* Are the bounds of the array parameterized? */
3800 for (i = 0; i < c1->as->rank; i++)
3801 {
3802 if (gfc_derived_parameter_expr (c1->as->lower[i]))
3803 pdt_array = true;
3804 if (gfc_derived_parameter_expr (c1->as->upper[i]))
3805 pdt_array = true;
3806 }
3807
3808 /* If they are, free the expressions for the bounds and
3809 replace them with the template expressions with substitute
3810 values. */
3811 for (i = 0; pdt_array && i < c1->as->rank; i++)
3812 {
3813 gfc_expr *e;
3814 e = gfc_copy_expr (c1->as->lower[i]);
3815 gfc_insert_kind_parameter_exprs (e);
3816 gfc_simplify_expr (e, 1);
3817 gfc_free_expr (c2->as->lower[i]);
3818 c2->as->lower[i] = e;
3819 e = gfc_copy_expr (c1->as->upper[i]);
3820 gfc_insert_kind_parameter_exprs (e);
3821 gfc_simplify_expr (e, 1);
3822 gfc_free_expr (c2->as->upper[i]);
3823 c2->as->upper[i] = e;
3824 }
3825 c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
3826 if (c1->initializer)
3827 {
3828 c2->initializer = gfc_copy_expr (c1->initializer);
3829 gfc_insert_kind_parameter_exprs (c2->initializer);
3830 gfc_simplify_expr (c2->initializer, 1);
3831 }
3832 }
3833
3834 /* Recurse into this function for PDT components. */
3835 if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
3836 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
3837 {
3838 gfc_actual_arglist *params;
3839 /* The component in the template has a list of specification
3840 expressions derived from its declaration. */
3841 params = gfc_copy_actual_arglist (c1->param_list);
3842 actual_param = params;
3843 /* Substitute the template parameters with the expressions
3844 from the specification list. */
3845 for (;actual_param; actual_param = actual_param->next)
3846 gfc_insert_parameter_exprs (actual_param->expr,
3847 type_param_spec_list);
3848
3849 /* Now obtain the PDT instance for the component. */
3850 old_param_spec_list = type_param_spec_list;
3851 m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
3852 type_param_spec_list = old_param_spec_list;
3853
3854 c2->param_list = params;
3855 if (!(c2->attr.pointer || c2->attr.allocatable))
3856 c2->initializer = gfc_default_initializer (&c2->ts);
3857
3858 if (c2->attr.allocatable)
3859 instance->attr.alloc_comp = 1;
3860 }
3861 }
3862
3863 gfc_commit_symbol (instance);
3864 if (ext_param_list)
3865 *ext_param_list = type_param_spec_list;
3866 *sym = instance;
3867 return m;
3868
3869 error_return:
3870 gfc_free_actual_arglist (type_param_spec_list);
3871 return MATCH_ERROR;
3872 }
3873
3874
3875 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3876 structure to the matched specification. This is necessary for FUNCTION and
3877 IMPLICIT statements.
3878
3879 If implicit_flag is nonzero, then we don't check for the optional
3880 kind specification. Not doing so is needed for matching an IMPLICIT
3881 statement correctly. */
3882
3883 match
gfc_match_decl_type_spec(gfc_typespec * ts,int implicit_flag)3884 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
3885 {
3886 char name[GFC_MAX_SYMBOL_LEN + 1];
3887 gfc_symbol *sym, *dt_sym;
3888 match m;
3889 char c;
3890 bool seen_deferred_kind, matched_type;
3891 const char *dt_name;
3892
3893 decl_type_param_list = NULL;
3894
3895 /* A belt and braces check that the typespec is correctly being treated
3896 as a deferred characteristic association. */
3897 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
3898 && (gfc_current_block ()->result->ts.kind == -1)
3899 && (ts->kind == -1);
3900 gfc_clear_ts (ts);
3901 if (seen_deferred_kind)
3902 ts->kind = -1;
3903
3904 /* Clear the current binding label, in case one is given. */
3905 curr_binding_label = NULL;
3906
3907 if (gfc_match (" byte") == MATCH_YES)
3908 {
3909 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
3910 return MATCH_ERROR;
3911
3912 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
3913 {
3914 gfc_error ("BYTE type used at %C "
3915 "is not available on the target machine");
3916 return MATCH_ERROR;
3917 }
3918
3919 ts->type = BT_INTEGER;
3920 ts->kind = 1;
3921 return MATCH_YES;
3922 }
3923
3924 m = gfc_match (" type (");
3925 matched_type = (m == MATCH_YES);
3926 if (matched_type)
3927 {
3928 gfc_gobble_whitespace ();
3929 if (gfc_peek_ascii_char () == '*')
3930 {
3931 if ((m = gfc_match ("*)")) != MATCH_YES)
3932 return m;
3933 if (gfc_comp_struct (gfc_current_state ()))
3934 {
3935 gfc_error ("Assumed type at %C is not allowed for components");
3936 return MATCH_ERROR;
3937 }
3938 if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
3939 "at %C"))
3940 return MATCH_ERROR;
3941 ts->type = BT_ASSUMED;
3942 return MATCH_YES;
3943 }
3944
3945 m = gfc_match ("%n", name);
3946 matched_type = (m == MATCH_YES);
3947 }
3948
3949 if ((matched_type && strcmp ("integer", name) == 0)
3950 || (!matched_type && gfc_match (" integer") == MATCH_YES))
3951 {
3952 ts->type = BT_INTEGER;
3953 ts->kind = gfc_default_integer_kind;
3954 goto get_kind;
3955 }
3956
3957 if ((matched_type && strcmp ("character", name) == 0)
3958 || (!matched_type && gfc_match (" character") == MATCH_YES))
3959 {
3960 if (matched_type
3961 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3962 "intrinsic-type-spec at %C"))
3963 return MATCH_ERROR;
3964
3965 ts->type = BT_CHARACTER;
3966 if (implicit_flag == 0)
3967 m = gfc_match_char_spec (ts);
3968 else
3969 m = MATCH_YES;
3970
3971 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
3972 {
3973 gfc_error ("Malformed type-spec at %C");
3974 return MATCH_ERROR;
3975 }
3976
3977 return m;
3978 }
3979
3980 if ((matched_type && strcmp ("real", name) == 0)
3981 || (!matched_type && gfc_match (" real") == MATCH_YES))
3982 {
3983 ts->type = BT_REAL;
3984 ts->kind = gfc_default_real_kind;
3985 goto get_kind;
3986 }
3987
3988 if ((matched_type
3989 && (strcmp ("doubleprecision", name) == 0
3990 || (strcmp ("double", name) == 0
3991 && gfc_match (" precision") == MATCH_YES)))
3992 || (!matched_type && gfc_match (" double precision") == MATCH_YES))
3993 {
3994 if (matched_type
3995 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3996 "intrinsic-type-spec at %C"))
3997 return MATCH_ERROR;
3998
3999 if (matched_type && gfc_match_char (')') != MATCH_YES)
4000 {
4001 gfc_error ("Malformed type-spec at %C");
4002 return MATCH_ERROR;
4003 }
4004
4005 ts->type = BT_REAL;
4006 ts->kind = gfc_default_double_kind;
4007 return MATCH_YES;
4008 }
4009
4010 if ((matched_type && strcmp ("complex", name) == 0)
4011 || (!matched_type && gfc_match (" complex") == MATCH_YES))
4012 {
4013 ts->type = BT_COMPLEX;
4014 ts->kind = gfc_default_complex_kind;
4015 goto get_kind;
4016 }
4017
4018 if ((matched_type
4019 && (strcmp ("doublecomplex", name) == 0
4020 || (strcmp ("double", name) == 0
4021 && gfc_match (" complex") == MATCH_YES)))
4022 || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4023 {
4024 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4025 return MATCH_ERROR;
4026
4027 if (matched_type
4028 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4029 "intrinsic-type-spec at %C"))
4030 return MATCH_ERROR;
4031
4032 if (matched_type && gfc_match_char (')') != MATCH_YES)
4033 {
4034 gfc_error ("Malformed type-spec at %C");
4035 return MATCH_ERROR;
4036 }
4037
4038 ts->type = BT_COMPLEX;
4039 ts->kind = gfc_default_double_kind;
4040 return MATCH_YES;
4041 }
4042
4043 if ((matched_type && strcmp ("logical", name) == 0)
4044 || (!matched_type && gfc_match (" logical") == MATCH_YES))
4045 {
4046 ts->type = BT_LOGICAL;
4047 ts->kind = gfc_default_logical_kind;
4048 goto get_kind;
4049 }
4050
4051 if (matched_type)
4052 {
4053 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4054 if (m == MATCH_ERROR)
4055 return m;
4056
4057 gfc_gobble_whitespace ();
4058 if (gfc_peek_ascii_char () != ')')
4059 {
4060 gfc_error ("Malformed type-spec at %C");
4061 return MATCH_ERROR;
4062 }
4063 m = gfc_match_char (')'); /* Burn closing ')'. */
4064 }
4065
4066 if (m != MATCH_YES)
4067 m = match_record_decl (name);
4068
4069 if (matched_type || m == MATCH_YES)
4070 {
4071 ts->type = BT_DERIVED;
4072 /* We accept record/s/ or type(s) where s is a structure, but we
4073 * don't need all the extra derived-type stuff for structures. */
4074 if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4075 {
4076 gfc_error ("Type name %qs at %C is ambiguous", name);
4077 return MATCH_ERROR;
4078 }
4079
4080 if (sym && sym->attr.flavor == FL_DERIVED
4081 && sym->attr.pdt_template
4082 && gfc_current_state () != COMP_DERIVED)
4083 {
4084 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4085 if (m != MATCH_YES)
4086 return m;
4087 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4088 ts->u.derived = sym;
4089 strcpy (name, gfc_dt_lower_string (sym->name));
4090 }
4091
4092 if (sym && sym->attr.flavor == FL_STRUCT)
4093 {
4094 ts->u.derived = sym;
4095 return MATCH_YES;
4096 }
4097 /* Actually a derived type. */
4098 }
4099
4100 else
4101 {
4102 /* Match nested STRUCTURE declarations; only valid within another
4103 structure declaration. */
4104 if (flag_dec_structure
4105 && (gfc_current_state () == COMP_STRUCTURE
4106 || gfc_current_state () == COMP_MAP))
4107 {
4108 m = gfc_match (" structure");
4109 if (m == MATCH_YES)
4110 {
4111 m = gfc_match_structure_decl ();
4112 if (m == MATCH_YES)
4113 {
4114 /* gfc_new_block is updated by match_structure_decl. */
4115 ts->type = BT_DERIVED;
4116 ts->u.derived = gfc_new_block;
4117 return MATCH_YES;
4118 }
4119 }
4120 if (m == MATCH_ERROR)
4121 return MATCH_ERROR;
4122 }
4123
4124 /* Match CLASS declarations. */
4125 m = gfc_match (" class ( * )");
4126 if (m == MATCH_ERROR)
4127 return MATCH_ERROR;
4128 else if (m == MATCH_YES)
4129 {
4130 gfc_symbol *upe;
4131 gfc_symtree *st;
4132 ts->type = BT_CLASS;
4133 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4134 if (upe == NULL)
4135 {
4136 upe = gfc_new_symbol ("STAR", gfc_current_ns);
4137 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4138 st->n.sym = upe;
4139 gfc_set_sym_referenced (upe);
4140 upe->refs++;
4141 upe->ts.type = BT_VOID;
4142 upe->attr.unlimited_polymorphic = 1;
4143 /* This is essential to force the construction of
4144 unlimited polymorphic component class containers. */
4145 upe->attr.zero_comp = 1;
4146 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4147 &gfc_current_locus))
4148 return MATCH_ERROR;
4149 }
4150 else
4151 {
4152 st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4153 st->n.sym = upe;
4154 upe->refs++;
4155 }
4156 ts->u.derived = upe;
4157 return m;
4158 }
4159
4160 m = gfc_match (" class (");
4161
4162 if (m == MATCH_YES)
4163 m = gfc_match ("%n", name);
4164 else
4165 return m;
4166
4167 if (m != MATCH_YES)
4168 return m;
4169 ts->type = BT_CLASS;
4170
4171 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4172 return MATCH_ERROR;
4173
4174 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4175 if (m == MATCH_ERROR)
4176 return m;
4177
4178 m = gfc_match_char (')');
4179 if (m != MATCH_YES)
4180 return m;
4181 }
4182
4183 /* Defer association of the derived type until the end of the
4184 specification block. However, if the derived type can be
4185 found, add it to the typespec. */
4186 if (gfc_matching_function)
4187 {
4188 ts->u.derived = NULL;
4189 if (gfc_current_state () != COMP_INTERFACE
4190 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4191 {
4192 sym = gfc_find_dt_in_generic (sym);
4193 ts->u.derived = sym;
4194 }
4195 return MATCH_YES;
4196 }
4197
4198 /* Search for the name but allow the components to be defined later. If
4199 type = -1, this typespec has been seen in a function declaration but
4200 the type could not be accessed at that point. The actual derived type is
4201 stored in a symtree with the first letter of the name capitalized; the
4202 symtree with the all lower-case name contains the associated
4203 generic function. */
4204 dt_name = gfc_dt_upper_string (name);
4205 sym = NULL;
4206 dt_sym = NULL;
4207 if (ts->kind != -1)
4208 {
4209 gfc_get_ha_symbol (name, &sym);
4210 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4211 {
4212 gfc_error ("Type name %qs at %C is ambiguous", name);
4213 return MATCH_ERROR;
4214 }
4215 if (sym->generic && !dt_sym)
4216 dt_sym = gfc_find_dt_in_generic (sym);
4217
4218 /* Host associated PDTs can get confused with their constructors
4219 because they ar instantiated in the template's namespace. */
4220 if (!dt_sym)
4221 {
4222 if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4223 {
4224 gfc_error ("Type name %qs at %C is ambiguous", name);
4225 return MATCH_ERROR;
4226 }
4227 if (dt_sym && !dt_sym->attr.pdt_type)
4228 dt_sym = NULL;
4229 }
4230 }
4231 else if (ts->kind == -1)
4232 {
4233 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4234 || gfc_current_ns->has_import_set;
4235 gfc_find_symbol (name, NULL, iface, &sym);
4236 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4237 {
4238 gfc_error ("Type name %qs at %C is ambiguous", name);
4239 return MATCH_ERROR;
4240 }
4241 if (sym && sym->generic && !dt_sym)
4242 dt_sym = gfc_find_dt_in_generic (sym);
4243
4244 ts->kind = 0;
4245 if (sym == NULL)
4246 return MATCH_NO;
4247 }
4248
4249 if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4250 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4251 || sym->attr.subroutine)
4252 {
4253 gfc_error ("Type name %qs at %C conflicts with previously declared "
4254 "entity at %L, which has the same name", name,
4255 &sym->declared_at);
4256 return MATCH_ERROR;
4257 }
4258
4259 if (sym && sym->attr.flavor == FL_DERIVED
4260 && sym->attr.pdt_template
4261 && gfc_current_state () != COMP_DERIVED)
4262 {
4263 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4264 if (m != MATCH_YES)
4265 return m;
4266 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4267 ts->u.derived = sym;
4268 strcpy (name, gfc_dt_lower_string (sym->name));
4269 }
4270
4271 gfc_save_symbol_data (sym);
4272 gfc_set_sym_referenced (sym);
4273 if (!sym->attr.generic
4274 && !gfc_add_generic (&sym->attr, sym->name, NULL))
4275 return MATCH_ERROR;
4276
4277 if (!sym->attr.function
4278 && !gfc_add_function (&sym->attr, sym->name, NULL))
4279 return MATCH_ERROR;
4280
4281 if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4282 && dt_sym->attr.pdt_template
4283 && gfc_current_state () != COMP_DERIVED)
4284 {
4285 m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
4286 if (m != MATCH_YES)
4287 return m;
4288 gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
4289 }
4290
4291 if (!dt_sym)
4292 {
4293 gfc_interface *intr, *head;
4294
4295 /* Use upper case to save the actual derived-type symbol. */
4296 gfc_get_symbol (dt_name, NULL, &dt_sym);
4297 dt_sym->name = gfc_get_string ("%s", sym->name);
4298 head = sym->generic;
4299 intr = gfc_get_interface ();
4300 intr->sym = dt_sym;
4301 intr->where = gfc_current_locus;
4302 intr->next = head;
4303 sym->generic = intr;
4304 sym->attr.if_source = IFSRC_DECL;
4305 }
4306 else
4307 gfc_save_symbol_data (dt_sym);
4308
4309 gfc_set_sym_referenced (dt_sym);
4310
4311 if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4312 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
4313 return MATCH_ERROR;
4314
4315 ts->u.derived = dt_sym;
4316
4317 return MATCH_YES;
4318
4319 get_kind:
4320 if (matched_type
4321 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4322 "intrinsic-type-spec at %C"))
4323 return MATCH_ERROR;
4324
4325 /* For all types except double, derived and character, look for an
4326 optional kind specifier. MATCH_NO is actually OK at this point. */
4327 if (implicit_flag == 1)
4328 {
4329 if (matched_type && gfc_match_char (')') != MATCH_YES)
4330 return MATCH_ERROR;
4331
4332 return MATCH_YES;
4333 }
4334
4335 if (gfc_current_form == FORM_FREE)
4336 {
4337 c = gfc_peek_ascii_char ();
4338 if (!gfc_is_whitespace (c) && c != '*' && c != '('
4339 && c != ':' && c != ',')
4340 {
4341 if (matched_type && c == ')')
4342 {
4343 gfc_next_ascii_char ();
4344 return MATCH_YES;
4345 }
4346 return MATCH_NO;
4347 }
4348 }
4349
4350 m = gfc_match_kind_spec (ts, false);
4351 if (m == MATCH_NO && ts->type != BT_CHARACTER)
4352 {
4353 m = gfc_match_old_kind_spec (ts);
4354 if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4355 return MATCH_ERROR;
4356 }
4357
4358 if (matched_type && gfc_match_char (')') != MATCH_YES)
4359 return MATCH_ERROR;
4360
4361 /* Defer association of the KIND expression of function results
4362 until after USE and IMPORT statements. */
4363 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
4364 || gfc_matching_function)
4365 return MATCH_YES;
4366
4367 if (m == MATCH_NO)
4368 m = MATCH_YES; /* No kind specifier found. */
4369
4370 return m;
4371 }
4372
4373
4374 /* Match an IMPLICIT NONE statement. Actually, this statement is
4375 already matched in parse.c, or we would not end up here in the
4376 first place. So the only thing we need to check, is if there is
4377 trailing garbage. If not, the match is successful. */
4378
4379 match
gfc_match_implicit_none(void)4380 gfc_match_implicit_none (void)
4381 {
4382 char c;
4383 match m;
4384 char name[GFC_MAX_SYMBOL_LEN + 1];
4385 bool type = false;
4386 bool external = false;
4387 locus cur_loc = gfc_current_locus;
4388
4389 if (gfc_current_ns->seen_implicit_none
4390 || gfc_current_ns->has_implicit_none_export)
4391 {
4392 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4393 return MATCH_ERROR;
4394 }
4395
4396 gfc_gobble_whitespace ();
4397 c = gfc_peek_ascii_char ();
4398 if (c == '(')
4399 {
4400 (void) gfc_next_ascii_char ();
4401 if (!gfc_notify_std (GFC_STD_F2018, "IMPORT NONE with spec list at %C"))
4402 return MATCH_ERROR;
4403
4404 gfc_gobble_whitespace ();
4405 if (gfc_peek_ascii_char () == ')')
4406 {
4407 (void) gfc_next_ascii_char ();
4408 type = true;
4409 }
4410 else
4411 for(;;)
4412 {
4413 m = gfc_match (" %n", name);
4414 if (m != MATCH_YES)
4415 return MATCH_ERROR;
4416
4417 if (strcmp (name, "type") == 0)
4418 type = true;
4419 else if (strcmp (name, "external") == 0)
4420 external = true;
4421 else
4422 return MATCH_ERROR;
4423
4424 gfc_gobble_whitespace ();
4425 c = gfc_next_ascii_char ();
4426 if (c == ',')
4427 continue;
4428 if (c == ')')
4429 break;
4430 return MATCH_ERROR;
4431 }
4432 }
4433 else
4434 type = true;
4435
4436 if (gfc_match_eos () != MATCH_YES)
4437 return MATCH_ERROR;
4438
4439 gfc_set_implicit_none (type, external, &cur_loc);
4440
4441 return MATCH_YES;
4442 }
4443
4444
4445 /* Match the letter range(s) of an IMPLICIT statement. */
4446
4447 static match
match_implicit_range(void)4448 match_implicit_range (void)
4449 {
4450 char c, c1, c2;
4451 int inner;
4452 locus cur_loc;
4453
4454 cur_loc = gfc_current_locus;
4455
4456 gfc_gobble_whitespace ();
4457 c = gfc_next_ascii_char ();
4458 if (c != '(')
4459 {
4460 gfc_error ("Missing character range in IMPLICIT at %C");
4461 goto bad;
4462 }
4463
4464 inner = 1;
4465 while (inner)
4466 {
4467 gfc_gobble_whitespace ();
4468 c1 = gfc_next_ascii_char ();
4469 if (!ISALPHA (c1))
4470 goto bad;
4471
4472 gfc_gobble_whitespace ();
4473 c = gfc_next_ascii_char ();
4474
4475 switch (c)
4476 {
4477 case ')':
4478 inner = 0; /* Fall through. */
4479
4480 case ',':
4481 c2 = c1;
4482 break;
4483
4484 case '-':
4485 gfc_gobble_whitespace ();
4486 c2 = gfc_next_ascii_char ();
4487 if (!ISALPHA (c2))
4488 goto bad;
4489
4490 gfc_gobble_whitespace ();
4491 c = gfc_next_ascii_char ();
4492
4493 if ((c != ',') && (c != ')'))
4494 goto bad;
4495 if (c == ')')
4496 inner = 0;
4497
4498 break;
4499
4500 default:
4501 goto bad;
4502 }
4503
4504 if (c1 > c2)
4505 {
4506 gfc_error ("Letters must be in alphabetic order in "
4507 "IMPLICIT statement at %C");
4508 goto bad;
4509 }
4510
4511 /* See if we can add the newly matched range to the pending
4512 implicits from this IMPLICIT statement. We do not check for
4513 conflicts with whatever earlier IMPLICIT statements may have
4514 set. This is done when we've successfully finished matching
4515 the current one. */
4516 if (!gfc_add_new_implicit_range (c1, c2))
4517 goto bad;
4518 }
4519
4520 return MATCH_YES;
4521
4522 bad:
4523 gfc_syntax_error (ST_IMPLICIT);
4524
4525 gfc_current_locus = cur_loc;
4526 return MATCH_ERROR;
4527 }
4528
4529
4530 /* Match an IMPLICIT statement, storing the types for
4531 gfc_set_implicit() if the statement is accepted by the parser.
4532 There is a strange looking, but legal syntactic construction
4533 possible. It looks like:
4534
4535 IMPLICIT INTEGER (a-b) (c-d)
4536
4537 This is legal if "a-b" is a constant expression that happens to
4538 equal one of the legal kinds for integers. The real problem
4539 happens with an implicit specification that looks like:
4540
4541 IMPLICIT INTEGER (a-b)
4542
4543 In this case, a typespec matcher that is "greedy" (as most of the
4544 matchers are) gobbles the character range as a kindspec, leaving
4545 nothing left. We therefore have to go a bit more slowly in the
4546 matching process by inhibiting the kindspec checking during
4547 typespec matching and checking for a kind later. */
4548
4549 match
gfc_match_implicit(void)4550 gfc_match_implicit (void)
4551 {
4552 gfc_typespec ts;
4553 locus cur_loc;
4554 char c;
4555 match m;
4556
4557 if (gfc_current_ns->seen_implicit_none)
4558 {
4559 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4560 "statement");
4561 return MATCH_ERROR;
4562 }
4563
4564 gfc_clear_ts (&ts);
4565
4566 /* We don't allow empty implicit statements. */
4567 if (gfc_match_eos () == MATCH_YES)
4568 {
4569 gfc_error ("Empty IMPLICIT statement at %C");
4570 return MATCH_ERROR;
4571 }
4572
4573 do
4574 {
4575 /* First cleanup. */
4576 gfc_clear_new_implicit ();
4577
4578 /* A basic type is mandatory here. */
4579 m = gfc_match_decl_type_spec (&ts, 1);
4580 if (m == MATCH_ERROR)
4581 goto error;
4582 if (m == MATCH_NO)
4583 goto syntax;
4584
4585 cur_loc = gfc_current_locus;
4586 m = match_implicit_range ();
4587
4588 if (m == MATCH_YES)
4589 {
4590 /* We may have <TYPE> (<RANGE>). */
4591 gfc_gobble_whitespace ();
4592 c = gfc_peek_ascii_char ();
4593 if (c == ',' || c == '\n' || c == ';' || c == '!')
4594 {
4595 /* Check for CHARACTER with no length parameter. */
4596 if (ts.type == BT_CHARACTER && !ts.u.cl)
4597 {
4598 ts.kind = gfc_default_character_kind;
4599 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4600 ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4601 NULL, 1);
4602 }
4603
4604 /* Record the Successful match. */
4605 if (!gfc_merge_new_implicit (&ts))
4606 return MATCH_ERROR;
4607 if (c == ',')
4608 c = gfc_next_ascii_char ();
4609 else if (gfc_match_eos () == MATCH_ERROR)
4610 goto error;
4611 continue;
4612 }
4613
4614 gfc_current_locus = cur_loc;
4615 }
4616
4617 /* Discard the (incorrectly) matched range. */
4618 gfc_clear_new_implicit ();
4619
4620 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4621 if (ts.type == BT_CHARACTER)
4622 m = gfc_match_char_spec (&ts);
4623 else
4624 {
4625 m = gfc_match_kind_spec (&ts, false);
4626 if (m == MATCH_NO)
4627 {
4628 m = gfc_match_old_kind_spec (&ts);
4629 if (m == MATCH_ERROR)
4630 goto error;
4631 if (m == MATCH_NO)
4632 goto syntax;
4633 }
4634 }
4635 if (m == MATCH_ERROR)
4636 goto error;
4637
4638 m = match_implicit_range ();
4639 if (m == MATCH_ERROR)
4640 goto error;
4641 if (m == MATCH_NO)
4642 goto syntax;
4643
4644 gfc_gobble_whitespace ();
4645 c = gfc_next_ascii_char ();
4646 if (c != ',' && gfc_match_eos () != MATCH_YES)
4647 goto syntax;
4648
4649 if (!gfc_merge_new_implicit (&ts))
4650 return MATCH_ERROR;
4651 }
4652 while (c == ',');
4653
4654 return MATCH_YES;
4655
4656 syntax:
4657 gfc_syntax_error (ST_IMPLICIT);
4658
4659 error:
4660 return MATCH_ERROR;
4661 }
4662
4663
4664 match
gfc_match_import(void)4665 gfc_match_import (void)
4666 {
4667 char name[GFC_MAX_SYMBOL_LEN + 1];
4668 match m;
4669 gfc_symbol *sym;
4670 gfc_symtree *st;
4671
4672 if (gfc_current_ns->proc_name == NULL
4673 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
4674 {
4675 gfc_error ("IMPORT statement at %C only permitted in "
4676 "an INTERFACE body");
4677 return MATCH_ERROR;
4678 }
4679
4680 if (gfc_current_ns->proc_name->attr.module_procedure)
4681 {
4682 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4683 "in a module procedure interface body");
4684 return MATCH_ERROR;
4685 }
4686
4687 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
4688 return MATCH_ERROR;
4689
4690 if (gfc_match_eos () == MATCH_YES)
4691 {
4692 /* All host variables should be imported. */
4693 gfc_current_ns->has_import_set = 1;
4694 return MATCH_YES;
4695 }
4696
4697 if (gfc_match (" ::") == MATCH_YES)
4698 {
4699 if (gfc_match_eos () == MATCH_YES)
4700 {
4701 gfc_error ("Expecting list of named entities at %C");
4702 return MATCH_ERROR;
4703 }
4704 }
4705
4706 for(;;)
4707 {
4708 sym = NULL;
4709 m = gfc_match (" %n", name);
4710 switch (m)
4711 {
4712 case MATCH_YES:
4713 if (gfc_current_ns->parent != NULL
4714 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
4715 {
4716 gfc_error ("Type name %qs at %C is ambiguous", name);
4717 return MATCH_ERROR;
4718 }
4719 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
4720 && gfc_find_symbol (name,
4721 gfc_current_ns->proc_name->ns->parent,
4722 1, &sym))
4723 {
4724 gfc_error ("Type name %qs at %C is ambiguous", name);
4725 return MATCH_ERROR;
4726 }
4727
4728 if (sym == NULL)
4729 {
4730 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4731 "at %C - does not exist.", name);
4732 return MATCH_ERROR;
4733 }
4734
4735 if (gfc_find_symtree (gfc_current_ns->sym_root, name))
4736 {
4737 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4738 "at %C", name);
4739 goto next_item;
4740 }
4741
4742 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
4743 st->n.sym = sym;
4744 sym->refs++;
4745 sym->attr.imported = 1;
4746
4747 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
4748 {
4749 /* The actual derived type is stored in a symtree with the first
4750 letter of the name capitalized; the symtree with the all
4751 lower-case name contains the associated generic function. */
4752 st = gfc_new_symtree (&gfc_current_ns->sym_root,
4753 gfc_dt_upper_string (name));
4754 st->n.sym = sym;
4755 sym->refs++;
4756 sym->attr.imported = 1;
4757 }
4758
4759 goto next_item;
4760
4761 case MATCH_NO:
4762 break;
4763
4764 case MATCH_ERROR:
4765 return MATCH_ERROR;
4766 }
4767
4768 next_item:
4769 if (gfc_match_eos () == MATCH_YES)
4770 break;
4771 if (gfc_match_char (',') != MATCH_YES)
4772 goto syntax;
4773 }
4774
4775 return MATCH_YES;
4776
4777 syntax:
4778 gfc_error ("Syntax error in IMPORT statement at %C");
4779 return MATCH_ERROR;
4780 }
4781
4782
4783 /* A minimal implementation of gfc_match without whitespace, escape
4784 characters or variable arguments. Returns true if the next
4785 characters match the TARGET template exactly. */
4786
4787 static bool
match_string_p(const char * target)4788 match_string_p (const char *target)
4789 {
4790 const char *p;
4791
4792 for (p = target; *p; p++)
4793 if ((char) gfc_next_ascii_char () != *p)
4794 return false;
4795 return true;
4796 }
4797
4798 /* Matches an attribute specification including array specs. If
4799 successful, leaves the variables current_attr and current_as
4800 holding the specification. Also sets the colon_seen variable for
4801 later use by matchers associated with initializations.
4802
4803 This subroutine is a little tricky in the sense that we don't know
4804 if we really have an attr-spec until we hit the double colon.
4805 Until that time, we can only return MATCH_NO. This forces us to
4806 check for duplicate specification at this level. */
4807
4808 static match
match_attr_spec(void)4809 match_attr_spec (void)
4810 {
4811 /* Modifiers that can exist in a type statement. */
4812 enum
4813 { GFC_DECL_BEGIN = 0,
4814 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
4815 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
4816 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
4817 DECL_STATIC, DECL_AUTOMATIC,
4818 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
4819 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
4820 DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
4821 };
4822
4823 /* GFC_DECL_END is the sentinel, index starts at 0. */
4824 #define NUM_DECL GFC_DECL_END
4825
4826 locus start, seen_at[NUM_DECL];
4827 int seen[NUM_DECL];
4828 unsigned int d;
4829 const char *attr;
4830 match m;
4831 bool t;
4832
4833 gfc_clear_attr (¤t_attr);
4834 start = gfc_current_locus;
4835
4836 current_as = NULL;
4837 colon_seen = 0;
4838 attr_seen = 0;
4839
4840 /* See if we get all of the keywords up to the final double colon. */
4841 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4842 seen[d] = 0;
4843
4844 for (;;)
4845 {
4846 char ch;
4847
4848 d = DECL_NONE;
4849 gfc_gobble_whitespace ();
4850
4851 ch = gfc_next_ascii_char ();
4852 if (ch == ':')
4853 {
4854 /* This is the successful exit condition for the loop. */
4855 if (gfc_next_ascii_char () == ':')
4856 break;
4857 }
4858 else if (ch == ',')
4859 {
4860 gfc_gobble_whitespace ();
4861 switch (gfc_peek_ascii_char ())
4862 {
4863 case 'a':
4864 gfc_next_ascii_char ();
4865 switch (gfc_next_ascii_char ())
4866 {
4867 case 'l':
4868 if (match_string_p ("locatable"))
4869 {
4870 /* Matched "allocatable". */
4871 d = DECL_ALLOCATABLE;
4872 }
4873 break;
4874
4875 case 's':
4876 if (match_string_p ("ynchronous"))
4877 {
4878 /* Matched "asynchronous". */
4879 d = DECL_ASYNCHRONOUS;
4880 }
4881 break;
4882
4883 case 'u':
4884 if (match_string_p ("tomatic"))
4885 {
4886 /* Matched "automatic". */
4887 d = DECL_AUTOMATIC;
4888 }
4889 break;
4890 }
4891 break;
4892
4893 case 'b':
4894 /* Try and match the bind(c). */
4895 m = gfc_match_bind_c (NULL, true);
4896 if (m == MATCH_YES)
4897 d = DECL_IS_BIND_C;
4898 else if (m == MATCH_ERROR)
4899 goto cleanup;
4900 break;
4901
4902 case 'c':
4903 gfc_next_ascii_char ();
4904 if ('o' != gfc_next_ascii_char ())
4905 break;
4906 switch (gfc_next_ascii_char ())
4907 {
4908 case 'd':
4909 if (match_string_p ("imension"))
4910 {
4911 d = DECL_CODIMENSION;
4912 break;
4913 }
4914 /* FALLTHRU */
4915 case 'n':
4916 if (match_string_p ("tiguous"))
4917 {
4918 d = DECL_CONTIGUOUS;
4919 break;
4920 }
4921 }
4922 break;
4923
4924 case 'd':
4925 if (match_string_p ("dimension"))
4926 d = DECL_DIMENSION;
4927 break;
4928
4929 case 'e':
4930 if (match_string_p ("external"))
4931 d = DECL_EXTERNAL;
4932 break;
4933
4934 case 'i':
4935 if (match_string_p ("int"))
4936 {
4937 ch = gfc_next_ascii_char ();
4938 if (ch == 'e')
4939 {
4940 if (match_string_p ("nt"))
4941 {
4942 /* Matched "intent". */
4943 /* TODO: Call match_intent_spec from here. */
4944 if (gfc_match (" ( in out )") == MATCH_YES)
4945 d = DECL_INOUT;
4946 else if (gfc_match (" ( in )") == MATCH_YES)
4947 d = DECL_IN;
4948 else if (gfc_match (" ( out )") == MATCH_YES)
4949 d = DECL_OUT;
4950 }
4951 }
4952 else if (ch == 'r')
4953 {
4954 if (match_string_p ("insic"))
4955 {
4956 /* Matched "intrinsic". */
4957 d = DECL_INTRINSIC;
4958 }
4959 }
4960 }
4961 break;
4962
4963 case 'k':
4964 if (match_string_p ("kind"))
4965 d = DECL_KIND;
4966 break;
4967
4968 case 'l':
4969 if (match_string_p ("len"))
4970 d = DECL_LEN;
4971 break;
4972
4973 case 'o':
4974 if (match_string_p ("optional"))
4975 d = DECL_OPTIONAL;
4976 break;
4977
4978 case 'p':
4979 gfc_next_ascii_char ();
4980 switch (gfc_next_ascii_char ())
4981 {
4982 case 'a':
4983 if (match_string_p ("rameter"))
4984 {
4985 /* Matched "parameter". */
4986 d = DECL_PARAMETER;
4987 }
4988 break;
4989
4990 case 'o':
4991 if (match_string_p ("inter"))
4992 {
4993 /* Matched "pointer". */
4994 d = DECL_POINTER;
4995 }
4996 break;
4997
4998 case 'r':
4999 ch = gfc_next_ascii_char ();
5000 if (ch == 'i')
5001 {
5002 if (match_string_p ("vate"))
5003 {
5004 /* Matched "private". */
5005 d = DECL_PRIVATE;
5006 }
5007 }
5008 else if (ch == 'o')
5009 {
5010 if (match_string_p ("tected"))
5011 {
5012 /* Matched "protected". */
5013 d = DECL_PROTECTED;
5014 }
5015 }
5016 break;
5017
5018 case 'u':
5019 if (match_string_p ("blic"))
5020 {
5021 /* Matched "public". */
5022 d = DECL_PUBLIC;
5023 }
5024 break;
5025 }
5026 break;
5027
5028 case 's':
5029 gfc_next_ascii_char ();
5030 switch (gfc_next_ascii_char ())
5031 {
5032 case 'a':
5033 if (match_string_p ("ve"))
5034 {
5035 /* Matched "save". */
5036 d = DECL_SAVE;
5037 }
5038 break;
5039
5040 case 't':
5041 if (match_string_p ("atic"))
5042 {
5043 /* Matched "static". */
5044 d = DECL_STATIC;
5045 }
5046 break;
5047 }
5048 break;
5049
5050 case 't':
5051 if (match_string_p ("target"))
5052 d = DECL_TARGET;
5053 break;
5054
5055 case 'v':
5056 gfc_next_ascii_char ();
5057 ch = gfc_next_ascii_char ();
5058 if (ch == 'a')
5059 {
5060 if (match_string_p ("lue"))
5061 {
5062 /* Matched "value". */
5063 d = DECL_VALUE;
5064 }
5065 }
5066 else if (ch == 'o')
5067 {
5068 if (match_string_p ("latile"))
5069 {
5070 /* Matched "volatile". */
5071 d = DECL_VOLATILE;
5072 }
5073 }
5074 break;
5075 }
5076 }
5077
5078 /* No double colon and no recognizable decl_type, so assume that
5079 we've been looking at something else the whole time. */
5080 if (d == DECL_NONE)
5081 {
5082 m = MATCH_NO;
5083 goto cleanup;
5084 }
5085
5086 /* Check to make sure any parens are paired up correctly. */
5087 if (gfc_match_parens () == MATCH_ERROR)
5088 {
5089 m = MATCH_ERROR;
5090 goto cleanup;
5091 }
5092
5093 seen[d]++;
5094 seen_at[d] = gfc_current_locus;
5095
5096 if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5097 {
5098 gfc_array_spec *as = NULL;
5099
5100 m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5101 d == DECL_CODIMENSION);
5102
5103 if (current_as == NULL)
5104 current_as = as;
5105 else if (m == MATCH_YES)
5106 {
5107 if (!merge_array_spec (as, current_as, false))
5108 m = MATCH_ERROR;
5109 free (as);
5110 }
5111
5112 if (m == MATCH_NO)
5113 {
5114 if (d == DECL_CODIMENSION)
5115 gfc_error ("Missing codimension specification at %C");
5116 else
5117 gfc_error ("Missing dimension specification at %C");
5118 m = MATCH_ERROR;
5119 }
5120
5121 if (m == MATCH_ERROR)
5122 goto cleanup;
5123 }
5124 }
5125
5126 /* Since we've seen a double colon, we have to be looking at an
5127 attr-spec. This means that we can now issue errors. */
5128 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5129 if (seen[d] > 1)
5130 {
5131 switch (d)
5132 {
5133 case DECL_ALLOCATABLE:
5134 attr = "ALLOCATABLE";
5135 break;
5136 case DECL_ASYNCHRONOUS:
5137 attr = "ASYNCHRONOUS";
5138 break;
5139 case DECL_CODIMENSION:
5140 attr = "CODIMENSION";
5141 break;
5142 case DECL_CONTIGUOUS:
5143 attr = "CONTIGUOUS";
5144 break;
5145 case DECL_DIMENSION:
5146 attr = "DIMENSION";
5147 break;
5148 case DECL_EXTERNAL:
5149 attr = "EXTERNAL";
5150 break;
5151 case DECL_IN:
5152 attr = "INTENT (IN)";
5153 break;
5154 case DECL_OUT:
5155 attr = "INTENT (OUT)";
5156 break;
5157 case DECL_INOUT:
5158 attr = "INTENT (IN OUT)";
5159 break;
5160 case DECL_INTRINSIC:
5161 attr = "INTRINSIC";
5162 break;
5163 case DECL_OPTIONAL:
5164 attr = "OPTIONAL";
5165 break;
5166 case DECL_KIND:
5167 attr = "KIND";
5168 break;
5169 case DECL_LEN:
5170 attr = "LEN";
5171 break;
5172 case DECL_PARAMETER:
5173 attr = "PARAMETER";
5174 break;
5175 case DECL_POINTER:
5176 attr = "POINTER";
5177 break;
5178 case DECL_PROTECTED:
5179 attr = "PROTECTED";
5180 break;
5181 case DECL_PRIVATE:
5182 attr = "PRIVATE";
5183 break;
5184 case DECL_PUBLIC:
5185 attr = "PUBLIC";
5186 break;
5187 case DECL_SAVE:
5188 attr = "SAVE";
5189 break;
5190 case DECL_STATIC:
5191 attr = "STATIC";
5192 break;
5193 case DECL_AUTOMATIC:
5194 attr = "AUTOMATIC";
5195 break;
5196 case DECL_TARGET:
5197 attr = "TARGET";
5198 break;
5199 case DECL_IS_BIND_C:
5200 attr = "IS_BIND_C";
5201 break;
5202 case DECL_VALUE:
5203 attr = "VALUE";
5204 break;
5205 case DECL_VOLATILE:
5206 attr = "VOLATILE";
5207 break;
5208 default:
5209 attr = NULL; /* This shouldn't happen. */
5210 }
5211
5212 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5213 m = MATCH_ERROR;
5214 goto cleanup;
5215 }
5216
5217 /* Now that we've dealt with duplicate attributes, add the attributes
5218 to the current attribute. */
5219 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5220 {
5221 if (seen[d] == 0)
5222 continue;
5223 else
5224 attr_seen = 1;
5225
5226 if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
5227 && !flag_dec_static)
5228 {
5229 gfc_error ("%s at %L is a DEC extension, enable with "
5230 "%<-fdec-static%>",
5231 d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5232 m = MATCH_ERROR;
5233 goto cleanup;
5234 }
5235 /* Allow SAVE with STATIC, but don't complain. */
5236 if (d == DECL_STATIC && seen[DECL_SAVE])
5237 continue;
5238
5239 if (gfc_current_state () == COMP_DERIVED
5240 && d != DECL_DIMENSION && d != DECL_CODIMENSION
5241 && d != DECL_POINTER && d != DECL_PRIVATE
5242 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5243 {
5244 if (d == DECL_ALLOCATABLE)
5245 {
5246 if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
5247 "attribute at %C in a TYPE definition"))
5248 {
5249 m = MATCH_ERROR;
5250 goto cleanup;
5251 }
5252 }
5253 else if (d == DECL_KIND)
5254 {
5255 if (!gfc_notify_std (GFC_STD_F2003, "KIND "
5256 "attribute at %C in a TYPE definition"))
5257 {
5258 m = MATCH_ERROR;
5259 goto cleanup;
5260 }
5261 if (current_ts.type != BT_INTEGER)
5262 {
5263 gfc_error ("Component with KIND attribute at %C must be "
5264 "INTEGER");
5265 m = MATCH_ERROR;
5266 goto cleanup;
5267 }
5268 if (current_ts.kind != gfc_default_integer_kind)
5269 {
5270 gfc_error ("Component with KIND attribute at %C must be "
5271 "default integer kind (%d)",
5272 gfc_default_integer_kind);
5273 m = MATCH_ERROR;
5274 goto cleanup;
5275 }
5276 }
5277 else if (d == DECL_LEN)
5278 {
5279 if (!gfc_notify_std (GFC_STD_F2003, "LEN "
5280 "attribute at %C in a TYPE definition"))
5281 {
5282 m = MATCH_ERROR;
5283 goto cleanup;
5284 }
5285 if (current_ts.type != BT_INTEGER)
5286 {
5287 gfc_error ("Component with LEN attribute at %C must be "
5288 "INTEGER");
5289 m = MATCH_ERROR;
5290 goto cleanup;
5291 }
5292 if (current_ts.kind != gfc_default_integer_kind)
5293 {
5294 gfc_error ("Component with LEN attribute at %C must be "
5295 "default integer kind (%d)",
5296 gfc_default_integer_kind);
5297 m = MATCH_ERROR;
5298 goto cleanup;
5299 }
5300 }
5301 else
5302 {
5303 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5304 &seen_at[d]);
5305 m = MATCH_ERROR;
5306 goto cleanup;
5307 }
5308 }
5309
5310 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5311 && gfc_current_state () != COMP_MODULE)
5312 {
5313 if (d == DECL_PRIVATE)
5314 attr = "PRIVATE";
5315 else
5316 attr = "PUBLIC";
5317 if (gfc_current_state () == COMP_DERIVED
5318 && gfc_state_stack->previous
5319 && gfc_state_stack->previous->state == COMP_MODULE)
5320 {
5321 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5322 "at %L in a TYPE definition", attr,
5323 &seen_at[d]))
5324 {
5325 m = MATCH_ERROR;
5326 goto cleanup;
5327 }
5328 }
5329 else
5330 {
5331 gfc_error ("%s attribute at %L is not allowed outside of the "
5332 "specification part of a module", attr, &seen_at[d]);
5333 m = MATCH_ERROR;
5334 goto cleanup;
5335 }
5336 }
5337
5338 if (gfc_current_state () != COMP_DERIVED
5339 && (d == DECL_KIND || d == DECL_LEN))
5340 {
5341 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5342 "definition", &seen_at[d]);
5343 m = MATCH_ERROR;
5344 goto cleanup;
5345 }
5346
5347 switch (d)
5348 {
5349 case DECL_ALLOCATABLE:
5350 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
5351 break;
5352
5353 case DECL_ASYNCHRONOUS:
5354 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5355 t = false;
5356 else
5357 t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
5358 break;
5359
5360 case DECL_CODIMENSION:
5361 t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
5362 break;
5363
5364 case DECL_CONTIGUOUS:
5365 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5366 t = false;
5367 else
5368 t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
5369 break;
5370
5371 case DECL_DIMENSION:
5372 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
5373 break;
5374
5375 case DECL_EXTERNAL:
5376 t = gfc_add_external (¤t_attr, &seen_at[d]);
5377 break;
5378
5379 case DECL_IN:
5380 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
5381 break;
5382
5383 case DECL_OUT:
5384 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
5385 break;
5386
5387 case DECL_INOUT:
5388 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
5389 break;
5390
5391 case DECL_INTRINSIC:
5392 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
5393 break;
5394
5395 case DECL_OPTIONAL:
5396 t = gfc_add_optional (¤t_attr, &seen_at[d]);
5397 break;
5398
5399 case DECL_KIND:
5400 t = gfc_add_kind (¤t_attr, &seen_at[d]);
5401 break;
5402
5403 case DECL_LEN:
5404 t = gfc_add_len (¤t_attr, &seen_at[d]);
5405 break;
5406
5407 case DECL_PARAMETER:
5408 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
5409 break;
5410
5411 case DECL_POINTER:
5412 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
5413 break;
5414
5415 case DECL_PROTECTED:
5416 if (gfc_current_state () != COMP_MODULE
5417 || (gfc_current_ns->proc_name
5418 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5419 {
5420 gfc_error ("PROTECTED at %C only allowed in specification "
5421 "part of a module");
5422 t = false;
5423 break;
5424 }
5425
5426 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5427 t = false;
5428 else
5429 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
5430 break;
5431
5432 case DECL_PRIVATE:
5433 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
5434 &seen_at[d]);
5435 break;
5436
5437 case DECL_PUBLIC:
5438 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
5439 &seen_at[d]);
5440 break;
5441
5442 case DECL_STATIC:
5443 case DECL_SAVE:
5444 t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5445 break;
5446
5447 case DECL_AUTOMATIC:
5448 t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
5449 break;
5450
5451 case DECL_TARGET:
5452 t = gfc_add_target (¤t_attr, &seen_at[d]);
5453 break;
5454
5455 case DECL_IS_BIND_C:
5456 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
5457 break;
5458
5459 case DECL_VALUE:
5460 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5461 t = false;
5462 else
5463 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
5464 break;
5465
5466 case DECL_VOLATILE:
5467 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5468 t = false;
5469 else
5470 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
5471 break;
5472
5473 default:
5474 gfc_internal_error ("match_attr_spec(): Bad attribute");
5475 }
5476
5477 if (!t)
5478 {
5479 m = MATCH_ERROR;
5480 goto cleanup;
5481 }
5482 }
5483
5484 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5485 if ((gfc_current_state () == COMP_MODULE
5486 || gfc_current_state () == COMP_SUBMODULE)
5487 && !current_attr.save
5488 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5489 current_attr.save = SAVE_IMPLICIT;
5490
5491 colon_seen = 1;
5492 return MATCH_YES;
5493
5494 cleanup:
5495 gfc_current_locus = start;
5496 gfc_free_array_spec (current_as);
5497 current_as = NULL;
5498 attr_seen = 0;
5499 return m;
5500 }
5501
5502
5503 /* Set the binding label, dest_label, either with the binding label
5504 stored in the given gfc_typespec, ts, or if none was provided, it
5505 will be the symbol name in all lower case, as required by the draft
5506 (J3/04-007, section 15.4.1). If a binding label was given and
5507 there is more than one argument (num_idents), it is an error. */
5508
5509 static bool
set_binding_label(const char ** dest_label,const char * sym_name,int num_idents)5510 set_binding_label (const char **dest_label, const char *sym_name,
5511 int num_idents)
5512 {
5513 if (num_idents > 1 && has_name_equals)
5514 {
5515 gfc_error ("Multiple identifiers provided with "
5516 "single NAME= specifier at %C");
5517 return false;
5518 }
5519
5520 if (curr_binding_label)
5521 /* Binding label given; store in temp holder till have sym. */
5522 *dest_label = curr_binding_label;
5523 else
5524 {
5525 /* No binding label given, and the NAME= specifier did not exist,
5526 which means there was no NAME="". */
5527 if (sym_name != NULL && has_name_equals == 0)
5528 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5529 }
5530
5531 return true;
5532 }
5533
5534
5535 /* Set the status of the given common block as being BIND(C) or not,
5536 depending on the given parameter, is_bind_c. */
5537
5538 void
set_com_block_bind_c(gfc_common_head * com_block,int is_bind_c)5539 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5540 {
5541 com_block->is_bind_c = is_bind_c;
5542 return;
5543 }
5544
5545
5546 /* Verify that the given gfc_typespec is for a C interoperable type. */
5547
5548 bool
gfc_verify_c_interop(gfc_typespec * ts)5549 gfc_verify_c_interop (gfc_typespec *ts)
5550 {
5551 if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5552 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5553 ? true : false;
5554 else if (ts->type == BT_CLASS)
5555 return false;
5556 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5557 return false;
5558
5559 return true;
5560 }
5561
5562
5563 /* Verify that the variables of a given common block, which has been
5564 defined with the attribute specifier bind(c), to be of a C
5565 interoperable type. Errors will be reported here, if
5566 encountered. */
5567
5568 bool
verify_com_block_vars_c_interop(gfc_common_head * com_block)5569 verify_com_block_vars_c_interop (gfc_common_head *com_block)
5570 {
5571 gfc_symbol *curr_sym = NULL;
5572 bool retval = true;
5573
5574 curr_sym = com_block->head;
5575
5576 /* Make sure we have at least one symbol. */
5577 if (curr_sym == NULL)
5578 return retval;
5579
5580 /* Here we know we have a symbol, so we'll execute this loop
5581 at least once. */
5582 do
5583 {
5584 /* The second to last param, 1, says this is in a common block. */
5585 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5586 curr_sym = curr_sym->common_next;
5587 } while (curr_sym != NULL);
5588
5589 return retval;
5590 }
5591
5592
5593 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5594 an appropriate error message is reported. */
5595
5596 bool
verify_bind_c_sym(gfc_symbol * tmp_sym,gfc_typespec * ts,int is_in_common,gfc_common_head * com_block)5597 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5598 int is_in_common, gfc_common_head *com_block)
5599 {
5600 bool bind_c_function = false;
5601 bool retval = true;
5602
5603 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5604 bind_c_function = true;
5605
5606 if (tmp_sym->attr.function && tmp_sym->result != NULL)
5607 {
5608 tmp_sym = tmp_sym->result;
5609 /* Make sure it wasn't an implicitly typed result. */
5610 if (tmp_sym->attr.implicit_type && warn_c_binding_type)
5611 {
5612 gfc_warning (OPT_Wc_binding_type,
5613 "Implicitly declared BIND(C) function %qs at "
5614 "%L may not be C interoperable", tmp_sym->name,
5615 &tmp_sym->declared_at);
5616 tmp_sym->ts.f90_type = tmp_sym->ts.type;
5617 /* Mark it as C interoperable to prevent duplicate warnings. */
5618 tmp_sym->ts.is_c_interop = 1;
5619 tmp_sym->attr.is_c_interop = 1;
5620 }
5621 }
5622
5623 /* Here, we know we have the bind(c) attribute, so if we have
5624 enough type info, then verify that it's a C interop kind.
5625 The info could be in the symbol already, or possibly still in
5626 the given ts (current_ts), so look in both. */
5627 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
5628 {
5629 if (!gfc_verify_c_interop (&(tmp_sym->ts)))
5630 {
5631 /* See if we're dealing with a sym in a common block or not. */
5632 if (is_in_common == 1 && warn_c_binding_type)
5633 {
5634 gfc_warning (OPT_Wc_binding_type,
5635 "Variable %qs in common block %qs at %L "
5636 "may not be a C interoperable "
5637 "kind though common block %qs is BIND(C)",
5638 tmp_sym->name, com_block->name,
5639 &(tmp_sym->declared_at), com_block->name);
5640 }
5641 else
5642 {
5643 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
5644 gfc_error ("Type declaration %qs at %L is not C "
5645 "interoperable but it is BIND(C)",
5646 tmp_sym->name, &(tmp_sym->declared_at));
5647 else if (warn_c_binding_type)
5648 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
5649 "may not be a C interoperable "
5650 "kind but it is BIND(C)",
5651 tmp_sym->name, &(tmp_sym->declared_at));
5652 }
5653 }
5654
5655 /* Variables declared w/in a common block can't be bind(c)
5656 since there's no way for C to see these variables, so there's
5657 semantically no reason for the attribute. */
5658 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
5659 {
5660 gfc_error ("Variable %qs in common block %qs at "
5661 "%L cannot be declared with BIND(C) "
5662 "since it is not a global",
5663 tmp_sym->name, com_block->name,
5664 &(tmp_sym->declared_at));
5665 retval = false;
5666 }
5667
5668 /* Scalar variables that are bind(c) can not have the pointer
5669 or allocatable attributes. */
5670 if (tmp_sym->attr.is_bind_c == 1)
5671 {
5672 if (tmp_sym->attr.pointer == 1)
5673 {
5674 gfc_error ("Variable %qs at %L cannot have both the "
5675 "POINTER and BIND(C) attributes",
5676 tmp_sym->name, &(tmp_sym->declared_at));
5677 retval = false;
5678 }
5679
5680 if (tmp_sym->attr.allocatable == 1)
5681 {
5682 gfc_error ("Variable %qs at %L cannot have both the "
5683 "ALLOCATABLE and BIND(C) attributes",
5684 tmp_sym->name, &(tmp_sym->declared_at));
5685 retval = false;
5686 }
5687
5688 }
5689
5690 /* If it is a BIND(C) function, make sure the return value is a
5691 scalar value. The previous tests in this function made sure
5692 the type is interoperable. */
5693 if (bind_c_function && tmp_sym->as != NULL)
5694 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5695 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
5696
5697 /* BIND(C) functions can not return a character string. */
5698 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
5699 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
5700 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5701 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
5702 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5703 "be a character string", tmp_sym->name,
5704 &(tmp_sym->declared_at));
5705 }
5706
5707 /* See if the symbol has been marked as private. If it has, make sure
5708 there is no binding label and warn the user if there is one. */
5709 if (tmp_sym->attr.access == ACCESS_PRIVATE
5710 && tmp_sym->binding_label)
5711 /* Use gfc_warning_now because we won't say that the symbol fails
5712 just because of this. */
5713 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5714 "given the binding label %qs", tmp_sym->name,
5715 &(tmp_sym->declared_at), tmp_sym->binding_label);
5716
5717 return retval;
5718 }
5719
5720
5721 /* Set the appropriate fields for a symbol that's been declared as
5722 BIND(C) (the is_bind_c flag and the binding label), and verify that
5723 the type is C interoperable. Errors are reported by the functions
5724 used to set/test these fields. */
5725
5726 bool
set_verify_bind_c_sym(gfc_symbol * tmp_sym,int num_idents)5727 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
5728 {
5729 bool retval = true;
5730
5731 /* TODO: Do we need to make sure the vars aren't marked private? */
5732
5733 /* Set the is_bind_c bit in symbol_attribute. */
5734 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
5735
5736 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
5737 return false;
5738
5739 return retval;
5740 }
5741
5742
5743 /* Set the fields marking the given common block as BIND(C), including
5744 a binding label, and report any errors encountered. */
5745
5746 bool
set_verify_bind_c_com_block(gfc_common_head * com_block,int num_idents)5747 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
5748 {
5749 bool retval = true;
5750
5751 /* destLabel, common name, typespec (which may have binding label). */
5752 if (!set_binding_label (&com_block->binding_label, com_block->name,
5753 num_idents))
5754 return false;
5755
5756 /* Set the given common block (com_block) to being bind(c) (1). */
5757 set_com_block_bind_c (com_block, 1);
5758
5759 return retval;
5760 }
5761
5762
5763 /* Retrieve the list of one or more identifiers that the given bind(c)
5764 attribute applies to. */
5765
5766 bool
get_bind_c_idents(void)5767 get_bind_c_idents (void)
5768 {
5769 char name[GFC_MAX_SYMBOL_LEN + 1];
5770 int num_idents = 0;
5771 gfc_symbol *tmp_sym = NULL;
5772 match found_id;
5773 gfc_common_head *com_block = NULL;
5774
5775 if (gfc_match_name (name) == MATCH_YES)
5776 {
5777 found_id = MATCH_YES;
5778 gfc_get_ha_symbol (name, &tmp_sym);
5779 }
5780 else if (match_common_name (name) == MATCH_YES)
5781 {
5782 found_id = MATCH_YES;
5783 com_block = gfc_get_common (name, 0);
5784 }
5785 else
5786 {
5787 gfc_error ("Need either entity or common block name for "
5788 "attribute specification statement at %C");
5789 return false;
5790 }
5791
5792 /* Save the current identifier and look for more. */
5793 do
5794 {
5795 /* Increment the number of identifiers found for this spec stmt. */
5796 num_idents++;
5797
5798 /* Make sure we have a sym or com block, and verify that it can
5799 be bind(c). Set the appropriate field(s) and look for more
5800 identifiers. */
5801 if (tmp_sym != NULL || com_block != NULL)
5802 {
5803 if (tmp_sym != NULL)
5804 {
5805 if (!set_verify_bind_c_sym (tmp_sym, num_idents))
5806 return false;
5807 }
5808 else
5809 {
5810 if (!set_verify_bind_c_com_block (com_block, num_idents))
5811 return false;
5812 }
5813
5814 /* Look to see if we have another identifier. */
5815 tmp_sym = NULL;
5816 if (gfc_match_eos () == MATCH_YES)
5817 found_id = MATCH_NO;
5818 else if (gfc_match_char (',') != MATCH_YES)
5819 found_id = MATCH_NO;
5820 else if (gfc_match_name (name) == MATCH_YES)
5821 {
5822 found_id = MATCH_YES;
5823 gfc_get_ha_symbol (name, &tmp_sym);
5824 }
5825 else if (match_common_name (name) == MATCH_YES)
5826 {
5827 found_id = MATCH_YES;
5828 com_block = gfc_get_common (name, 0);
5829 }
5830 else
5831 {
5832 gfc_error ("Missing entity or common block name for "
5833 "attribute specification statement at %C");
5834 return false;
5835 }
5836 }
5837 else
5838 {
5839 gfc_internal_error ("Missing symbol");
5840 }
5841 } while (found_id == MATCH_YES);
5842
5843 /* if we get here we were successful */
5844 return true;
5845 }
5846
5847
5848 /* Try and match a BIND(C) attribute specification statement. */
5849
5850 match
gfc_match_bind_c_stmt(void)5851 gfc_match_bind_c_stmt (void)
5852 {
5853 match found_match = MATCH_NO;
5854 gfc_typespec *ts;
5855
5856 ts = ¤t_ts;
5857
5858 /* This may not be necessary. */
5859 gfc_clear_ts (ts);
5860 /* Clear the temporary binding label holder. */
5861 curr_binding_label = NULL;
5862
5863 /* Look for the bind(c). */
5864 found_match = gfc_match_bind_c (NULL, true);
5865
5866 if (found_match == MATCH_YES)
5867 {
5868 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
5869 return MATCH_ERROR;
5870
5871 /* Look for the :: now, but it is not required. */
5872 gfc_match (" :: ");
5873
5874 /* Get the identifier(s) that needs to be updated. This may need to
5875 change to hand the flag(s) for the attr specified so all identifiers
5876 found can have all appropriate parts updated (assuming that the same
5877 spec stmt can have multiple attrs, such as both bind(c) and
5878 allocatable...). */
5879 if (!get_bind_c_idents ())
5880 /* Error message should have printed already. */
5881 return MATCH_ERROR;
5882 }
5883
5884 return found_match;
5885 }
5886
5887
5888 /* Match a data declaration statement. */
5889
5890 match
gfc_match_data_decl(void)5891 gfc_match_data_decl (void)
5892 {
5893 gfc_symbol *sym;
5894 match m;
5895 int elem;
5896
5897 type_param_spec_list = NULL;
5898 decl_type_param_list = NULL;
5899
5900 num_idents_on_line = 0;
5901
5902 m = gfc_match_decl_type_spec (¤t_ts, 0);
5903 if (m != MATCH_YES)
5904 return m;
5905
5906 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5907 && !gfc_comp_struct (gfc_current_state ()))
5908 {
5909 sym = gfc_use_derived (current_ts.u.derived);
5910
5911 if (sym == NULL)
5912 {
5913 m = MATCH_ERROR;
5914 goto cleanup;
5915 }
5916
5917 current_ts.u.derived = sym;
5918 }
5919
5920 m = match_attr_spec ();
5921 if (m == MATCH_ERROR)
5922 {
5923 m = MATCH_NO;
5924 goto cleanup;
5925 }
5926
5927 if (current_ts.type == BT_CLASS
5928 && current_ts.u.derived->attr.unlimited_polymorphic)
5929 goto ok;
5930
5931 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5932 && current_ts.u.derived->components == NULL
5933 && !current_ts.u.derived->attr.zero_comp)
5934 {
5935
5936 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
5937 goto ok;
5938
5939 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
5940 && current_ts.u.derived == gfc_current_block ())
5941 goto ok;
5942
5943 gfc_find_symbol (current_ts.u.derived->name,
5944 current_ts.u.derived->ns, 1, &sym);
5945
5946 /* Any symbol that we find had better be a type definition
5947 which has its components defined, or be a structure definition
5948 actively being parsed. */
5949 if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
5950 && (current_ts.u.derived->components != NULL
5951 || current_ts.u.derived->attr.zero_comp
5952 || current_ts.u.derived == gfc_new_block))
5953 goto ok;
5954
5955 gfc_error ("Derived type at %C has not been previously defined "
5956 "and so cannot appear in a derived type definition");
5957 m = MATCH_ERROR;
5958 goto cleanup;
5959 }
5960
5961 ok:
5962 /* If we have an old-style character declaration, and no new-style
5963 attribute specifications, then there a comma is optional between
5964 the type specification and the variable list. */
5965 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
5966 gfc_match_char (',');
5967
5968 /* Give the types/attributes to symbols that follow. Give the element
5969 a number so that repeat character length expressions can be copied. */
5970 elem = 1;
5971 for (;;)
5972 {
5973 num_idents_on_line++;
5974 m = variable_decl (elem++);
5975 if (m == MATCH_ERROR)
5976 goto cleanup;
5977 if (m == MATCH_NO)
5978 break;
5979
5980 if (gfc_match_eos () == MATCH_YES)
5981 goto cleanup;
5982 if (gfc_match_char (',') != MATCH_YES)
5983 break;
5984 }
5985
5986 if (!gfc_error_flag_test ())
5987 {
5988 /* An anonymous structure declaration is unambiguous; if we matched one
5989 according to gfc_match_structure_decl, we need to return MATCH_YES
5990 here to avoid confusing the remaining matchers, even if there was an
5991 error during variable_decl. We must flush any such errors. Note this
5992 causes the parser to gracefully continue parsing the remaining input
5993 as a structure body, which likely follows. */
5994 if (current_ts.type == BT_DERIVED && current_ts.u.derived
5995 && gfc_fl_struct (current_ts.u.derived->attr.flavor))
5996 {
5997 gfc_error_now ("Syntax error in anonymous structure declaration"
5998 " at %C");
5999 /* Skip the bad variable_decl and line up for the start of the
6000 structure body. */
6001 gfc_error_recovery ();
6002 m = MATCH_YES;
6003 goto cleanup;
6004 }
6005
6006 gfc_error ("Syntax error in data declaration at %C");
6007 }
6008
6009 m = MATCH_ERROR;
6010
6011 gfc_free_data_all (gfc_current_ns);
6012
6013 cleanup:
6014 if (saved_kind_expr)
6015 gfc_free_expr (saved_kind_expr);
6016 if (type_param_spec_list)
6017 gfc_free_actual_arglist (type_param_spec_list);
6018 if (decl_type_param_list)
6019 gfc_free_actual_arglist (decl_type_param_list);
6020 saved_kind_expr = NULL;
6021 gfc_free_array_spec (current_as);
6022 current_as = NULL;
6023 return m;
6024 }
6025
6026
6027 /* Match a prefix associated with a function or subroutine
6028 declaration. If the typespec pointer is nonnull, then a typespec
6029 can be matched. Note that if nothing matches, MATCH_YES is
6030 returned (the null string was matched). */
6031
6032 match
gfc_match_prefix(gfc_typespec * ts)6033 gfc_match_prefix (gfc_typespec *ts)
6034 {
6035 bool seen_type;
6036 bool seen_impure;
6037 bool found_prefix;
6038
6039 gfc_clear_attr (¤t_attr);
6040 seen_type = false;
6041 seen_impure = false;
6042
6043 gcc_assert (!gfc_matching_prefix);
6044 gfc_matching_prefix = true;
6045
6046 do
6047 {
6048 found_prefix = false;
6049
6050 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6051 corresponding attribute seems natural and distinguishes these
6052 procedures from procedure types of PROC_MODULE, which these are
6053 as well. */
6054 if (gfc_match ("module% ") == MATCH_YES)
6055 {
6056 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6057 goto error;
6058
6059 current_attr.module_procedure = 1;
6060 found_prefix = true;
6061 }
6062
6063 if (!seen_type && ts != NULL
6064 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
6065 && gfc_match_space () == MATCH_YES)
6066 {
6067
6068 seen_type = true;
6069 found_prefix = true;
6070 }
6071
6072 if (gfc_match ("elemental% ") == MATCH_YES)
6073 {
6074 if (!gfc_add_elemental (¤t_attr, NULL))
6075 goto error;
6076
6077 found_prefix = true;
6078 }
6079
6080 if (gfc_match ("pure% ") == MATCH_YES)
6081 {
6082 if (!gfc_add_pure (¤t_attr, NULL))
6083 goto error;
6084
6085 found_prefix = true;
6086 }
6087
6088 if (gfc_match ("recursive% ") == MATCH_YES)
6089 {
6090 if (!gfc_add_recursive (¤t_attr, NULL))
6091 goto error;
6092
6093 found_prefix = true;
6094 }
6095
6096 /* IMPURE is a somewhat special case, as it needs not set an actual
6097 attribute but rather only prevents ELEMENTAL routines from being
6098 automatically PURE. */
6099 if (gfc_match ("impure% ") == MATCH_YES)
6100 {
6101 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6102 goto error;
6103
6104 seen_impure = true;
6105 found_prefix = true;
6106 }
6107 }
6108 while (found_prefix);
6109
6110 /* IMPURE and PURE must not both appear, of course. */
6111 if (seen_impure && current_attr.pure)
6112 {
6113 gfc_error ("PURE and IMPURE must not appear both at %C");
6114 goto error;
6115 }
6116
6117 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6118 if (!seen_impure && current_attr.elemental && !current_attr.pure)
6119 {
6120 if (!gfc_add_pure (¤t_attr, NULL))
6121 goto error;
6122 }
6123
6124 /* At this point, the next item is not a prefix. */
6125 gcc_assert (gfc_matching_prefix);
6126
6127 gfc_matching_prefix = false;
6128 return MATCH_YES;
6129
6130 error:
6131 gcc_assert (gfc_matching_prefix);
6132 gfc_matching_prefix = false;
6133 return MATCH_ERROR;
6134 }
6135
6136
6137 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6138
6139 static bool
copy_prefix(symbol_attribute * dest,locus * where)6140 copy_prefix (symbol_attribute *dest, locus *where)
6141 {
6142 if (dest->module_procedure)
6143 {
6144 if (current_attr.elemental)
6145 dest->elemental = 1;
6146
6147 if (current_attr.pure)
6148 dest->pure = 1;
6149
6150 if (current_attr.recursive)
6151 dest->recursive = 1;
6152
6153 /* Module procedures are unusual in that the 'dest' is copied from
6154 the interface declaration. However, this is an oportunity to
6155 check that the submodule declaration is compliant with the
6156 interface. */
6157 if (dest->elemental && !current_attr.elemental)
6158 {
6159 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6160 "missing at %L", where);
6161 return false;
6162 }
6163
6164 if (dest->pure && !current_attr.pure)
6165 {
6166 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6167 "missing at %L", where);
6168 return false;
6169 }
6170
6171 if (dest->recursive && !current_attr.recursive)
6172 {
6173 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6174 "missing at %L", where);
6175 return false;
6176 }
6177
6178 return true;
6179 }
6180
6181 if (current_attr.elemental && !gfc_add_elemental (dest, where))
6182 return false;
6183
6184 if (current_attr.pure && !gfc_add_pure (dest, where))
6185 return false;
6186
6187 if (current_attr.recursive && !gfc_add_recursive (dest, where))
6188 return false;
6189
6190 return true;
6191 }
6192
6193
6194 /* Match a formal argument list or, if typeparam is true, a
6195 type_param_name_list. */
6196
6197 match
gfc_match_formal_arglist(gfc_symbol * progname,int st_flag,int null_flag,bool typeparam)6198 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6199 int null_flag, bool typeparam)
6200 {
6201 gfc_formal_arglist *head, *tail, *p, *q;
6202 char name[GFC_MAX_SYMBOL_LEN + 1];
6203 gfc_symbol *sym;
6204 match m;
6205 gfc_formal_arglist *formal = NULL;
6206
6207 head = tail = NULL;
6208
6209 /* Keep the interface formal argument list and null it so that the
6210 matching for the new declaration can be done. The numbers and
6211 names of the arguments are checked here. The interface formal
6212 arguments are retained in formal_arglist and the characteristics
6213 are compared in resolve.c(resolve_fl_procedure). See the remark
6214 in get_proc_name about the eventual need to copy the formal_arglist
6215 and populate the formal namespace of the interface symbol. */
6216 if (progname->attr.module_procedure
6217 && progname->attr.host_assoc)
6218 {
6219 formal = progname->formal;
6220 progname->formal = NULL;
6221 }
6222
6223 if (gfc_match_char ('(') != MATCH_YES)
6224 {
6225 if (null_flag)
6226 goto ok;
6227 return MATCH_NO;
6228 }
6229
6230 if (gfc_match_char (')') == MATCH_YES)
6231 goto ok;
6232
6233 for (;;)
6234 {
6235 if (gfc_match_char ('*') == MATCH_YES)
6236 {
6237 sym = NULL;
6238 if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6239 "Alternate-return argument at %C"))
6240 {
6241 m = MATCH_ERROR;
6242 goto cleanup;
6243 }
6244 else if (typeparam)
6245 gfc_error_now ("A parameter name is required at %C");
6246 }
6247 else
6248 {
6249 m = gfc_match_name (name);
6250 if (m != MATCH_YES)
6251 {
6252 if(typeparam)
6253 gfc_error_now ("A parameter name is required at %C");
6254 goto cleanup;
6255 }
6256
6257 if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6258 goto cleanup;
6259 else if (typeparam
6260 && gfc_get_symbol (name, progname->f2k_derived, &sym))
6261 goto cleanup;
6262 }
6263
6264 p = gfc_get_formal_arglist ();
6265
6266 if (head == NULL)
6267 head = tail = p;
6268 else
6269 {
6270 tail->next = p;
6271 tail = p;
6272 }
6273
6274 tail->sym = sym;
6275
6276 /* We don't add the VARIABLE flavor because the name could be a
6277 dummy procedure. We don't apply these attributes to formal
6278 arguments of statement functions. */
6279 if (sym != NULL && !st_flag
6280 && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6281 || !gfc_missing_attr (&sym->attr, NULL)))
6282 {
6283 m = MATCH_ERROR;
6284 goto cleanup;
6285 }
6286
6287 /* The name of a program unit can be in a different namespace,
6288 so check for it explicitly. After the statement is accepted,
6289 the name is checked for especially in gfc_get_symbol(). */
6290 if (gfc_new_block != NULL && sym != NULL && !typeparam
6291 && strcmp (sym->name, gfc_new_block->name) == 0)
6292 {
6293 gfc_error ("Name %qs at %C is the name of the procedure",
6294 sym->name);
6295 m = MATCH_ERROR;
6296 goto cleanup;
6297 }
6298
6299 if (gfc_match_char (')') == MATCH_YES)
6300 goto ok;
6301
6302 m = gfc_match_char (',');
6303 if (m != MATCH_YES)
6304 {
6305 if (typeparam)
6306 gfc_error_now ("Expected parameter list in type declaration "
6307 "at %C");
6308 else
6309 gfc_error ("Unexpected junk in formal argument list at %C");
6310 goto cleanup;
6311 }
6312 }
6313
6314 ok:
6315 /* Check for duplicate symbols in the formal argument list. */
6316 if (head != NULL)
6317 {
6318 for (p = head; p->next; p = p->next)
6319 {
6320 if (p->sym == NULL)
6321 continue;
6322
6323 for (q = p->next; q; q = q->next)
6324 if (p->sym == q->sym)
6325 {
6326 if (typeparam)
6327 gfc_error_now ("Duplicate name %qs in parameter "
6328 "list at %C", p->sym->name);
6329 else
6330 gfc_error ("Duplicate symbol %qs in formal argument "
6331 "list at %C", p->sym->name);
6332
6333 m = MATCH_ERROR;
6334 goto cleanup;
6335 }
6336 }
6337 }
6338
6339 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6340 {
6341 m = MATCH_ERROR;
6342 goto cleanup;
6343 }
6344
6345 /* gfc_error_now used in following and return with MATCH_YES because
6346 doing otherwise results in a cascade of extraneous errors and in
6347 some cases an ICE in symbol.c(gfc_release_symbol). */
6348 if (progname->attr.module_procedure && progname->attr.host_assoc)
6349 {
6350 bool arg_count_mismatch = false;
6351
6352 if (!formal && head)
6353 arg_count_mismatch = true;
6354
6355 /* Abbreviated module procedure declaration is not meant to have any
6356 formal arguments! */
6357 if (!progname->abr_modproc_decl && formal && !head)
6358 arg_count_mismatch = true;
6359
6360 for (p = formal, q = head; p && q; p = p->next, q = q->next)
6361 {
6362 if ((p->next != NULL && q->next == NULL)
6363 || (p->next == NULL && q->next != NULL))
6364 arg_count_mismatch = true;
6365 else if ((p->sym == NULL && q->sym == NULL)
6366 || strcmp (p->sym->name, q->sym->name) == 0)
6367 continue;
6368 else
6369 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6370 "argument names (%s/%s) at %C",
6371 p->sym->name, q->sym->name);
6372 }
6373
6374 if (arg_count_mismatch)
6375 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6376 "formal arguments at %C");
6377 }
6378
6379 return MATCH_YES;
6380
6381 cleanup:
6382 gfc_free_formal_arglist (head);
6383 return m;
6384 }
6385
6386
6387 /* Match a RESULT specification following a function declaration or
6388 ENTRY statement. Also matches the end-of-statement. */
6389
6390 static match
match_result(gfc_symbol * function,gfc_symbol ** result)6391 match_result (gfc_symbol *function, gfc_symbol **result)
6392 {
6393 char name[GFC_MAX_SYMBOL_LEN + 1];
6394 gfc_symbol *r;
6395 match m;
6396
6397 if (gfc_match (" result (") != MATCH_YES)
6398 return MATCH_NO;
6399
6400 m = gfc_match_name (name);
6401 if (m != MATCH_YES)
6402 return m;
6403
6404 /* Get the right paren, and that's it because there could be the
6405 bind(c) attribute after the result clause. */
6406 if (gfc_match_char (')') != MATCH_YES)
6407 {
6408 /* TODO: should report the missing right paren here. */
6409 return MATCH_ERROR;
6410 }
6411
6412 if (strcmp (function->name, name) == 0)
6413 {
6414 gfc_error ("RESULT variable at %C must be different than function name");
6415 return MATCH_ERROR;
6416 }
6417
6418 if (gfc_get_symbol (name, NULL, &r))
6419 return MATCH_ERROR;
6420
6421 if (!gfc_add_result (&r->attr, r->name, NULL))
6422 return MATCH_ERROR;
6423
6424 *result = r;
6425
6426 return MATCH_YES;
6427 }
6428
6429
6430 /* Match a function suffix, which could be a combination of a result
6431 clause and BIND(C), either one, or neither. The draft does not
6432 require them to come in a specific order. */
6433
6434 match
gfc_match_suffix(gfc_symbol * sym,gfc_symbol ** result)6435 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6436 {
6437 match is_bind_c; /* Found bind(c). */
6438 match is_result; /* Found result clause. */
6439 match found_match; /* Status of whether we've found a good match. */
6440 char peek_char; /* Character we're going to peek at. */
6441 bool allow_binding_name;
6442
6443 /* Initialize to having found nothing. */
6444 found_match = MATCH_NO;
6445 is_bind_c = MATCH_NO;
6446 is_result = MATCH_NO;
6447
6448 /* Get the next char to narrow between result and bind(c). */
6449 gfc_gobble_whitespace ();
6450 peek_char = gfc_peek_ascii_char ();
6451
6452 /* C binding names are not allowed for internal procedures. */
6453 if (gfc_current_state () == COMP_CONTAINS
6454 && sym->ns->proc_name->attr.flavor != FL_MODULE)
6455 allow_binding_name = false;
6456 else
6457 allow_binding_name = true;
6458
6459 switch (peek_char)
6460 {
6461 case 'r':
6462 /* Look for result clause. */
6463 is_result = match_result (sym, result);
6464 if (is_result == MATCH_YES)
6465 {
6466 /* Now see if there is a bind(c) after it. */
6467 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6468 /* We've found the result clause and possibly bind(c). */
6469 found_match = MATCH_YES;
6470 }
6471 else
6472 /* This should only be MATCH_ERROR. */
6473 found_match = is_result;
6474 break;
6475 case 'b':
6476 /* Look for bind(c) first. */
6477 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6478 if (is_bind_c == MATCH_YES)
6479 {
6480 /* Now see if a result clause followed it. */
6481 is_result = match_result (sym, result);
6482 found_match = MATCH_YES;
6483 }
6484 else
6485 {
6486 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6487 found_match = MATCH_ERROR;
6488 }
6489 break;
6490 default:
6491 gfc_error ("Unexpected junk after function declaration at %C");
6492 found_match = MATCH_ERROR;
6493 break;
6494 }
6495
6496 if (is_bind_c == MATCH_YES)
6497 {
6498 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6499 if (gfc_current_state () == COMP_CONTAINS
6500 && sym->ns->proc_name->attr.flavor != FL_MODULE
6501 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6502 "at %L may not be specified for an internal "
6503 "procedure", &gfc_current_locus))
6504 return MATCH_ERROR;
6505
6506 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6507 return MATCH_ERROR;
6508 }
6509
6510 return found_match;
6511 }
6512
6513
6514 /* Procedure pointer return value without RESULT statement:
6515 Add "hidden" result variable named "ppr@". */
6516
6517 static bool
add_hidden_procptr_result(gfc_symbol * sym)6518 add_hidden_procptr_result (gfc_symbol *sym)
6519 {
6520 bool case1,case2;
6521
6522 if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6523 return false;
6524
6525 /* First usage case: PROCEDURE and EXTERNAL statements. */
6526 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6527 && strcmp (gfc_current_block ()->name, sym->name) == 0
6528 && sym->attr.external;
6529 /* Second usage case: INTERFACE statements. */
6530 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6531 && gfc_state_stack->previous->state == COMP_FUNCTION
6532 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
6533
6534 if (case1 || case2)
6535 {
6536 gfc_symtree *stree;
6537 if (case1)
6538 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
6539 else if (case2)
6540 {
6541 gfc_symtree *st2;
6542 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
6543 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
6544 st2->n.sym = stree->n.sym;
6545 stree->n.sym->refs++;
6546 }
6547 sym->result = stree->n.sym;
6548
6549 sym->result->attr.proc_pointer = sym->attr.proc_pointer;
6550 sym->result->attr.pointer = sym->attr.pointer;
6551 sym->result->attr.external = sym->attr.external;
6552 sym->result->attr.referenced = sym->attr.referenced;
6553 sym->result->ts = sym->ts;
6554 sym->attr.proc_pointer = 0;
6555 sym->attr.pointer = 0;
6556 sym->attr.external = 0;
6557 if (sym->result->attr.external && sym->result->attr.pointer)
6558 {
6559 sym->result->attr.pointer = 0;
6560 sym->result->attr.proc_pointer = 1;
6561 }
6562
6563 return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
6564 }
6565 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6566 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
6567 && sym->result && sym->result != sym && sym->result->attr.external
6568 && sym == gfc_current_ns->proc_name
6569 && sym == sym->result->ns->proc_name
6570 && strcmp ("ppr@", sym->result->name) == 0)
6571 {
6572 sym->result->attr.proc_pointer = 1;
6573 sym->attr.pointer = 0;
6574 return true;
6575 }
6576 else
6577 return false;
6578 }
6579
6580
6581 /* Match the interface for a PROCEDURE declaration,
6582 including brackets (R1212). */
6583
6584 static match
match_procedure_interface(gfc_symbol ** proc_if)6585 match_procedure_interface (gfc_symbol **proc_if)
6586 {
6587 match m;
6588 gfc_symtree *st;
6589 locus old_loc, entry_loc;
6590 gfc_namespace *old_ns = gfc_current_ns;
6591 char name[GFC_MAX_SYMBOL_LEN + 1];
6592
6593 old_loc = entry_loc = gfc_current_locus;
6594 gfc_clear_ts (¤t_ts);
6595
6596 if (gfc_match (" (") != MATCH_YES)
6597 {
6598 gfc_current_locus = entry_loc;
6599 return MATCH_NO;
6600 }
6601
6602 /* Get the type spec. for the procedure interface. */
6603 old_loc = gfc_current_locus;
6604 m = gfc_match_decl_type_spec (¤t_ts, 0);
6605 gfc_gobble_whitespace ();
6606 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
6607 goto got_ts;
6608
6609 if (m == MATCH_ERROR)
6610 return m;
6611
6612 /* Procedure interface is itself a procedure. */
6613 gfc_current_locus = old_loc;
6614 m = gfc_match_name (name);
6615
6616 /* First look to see if it is already accessible in the current
6617 namespace because it is use associated or contained. */
6618 st = NULL;
6619 if (gfc_find_sym_tree (name, NULL, 0, &st))
6620 return MATCH_ERROR;
6621
6622 /* If it is still not found, then try the parent namespace, if it
6623 exists and create the symbol there if it is still not found. */
6624 if (gfc_current_ns->parent)
6625 gfc_current_ns = gfc_current_ns->parent;
6626 if (st == NULL && gfc_get_ha_sym_tree (name, &st))
6627 return MATCH_ERROR;
6628
6629 gfc_current_ns = old_ns;
6630 *proc_if = st->n.sym;
6631
6632 if (*proc_if)
6633 {
6634 (*proc_if)->refs++;
6635 /* Resolve interface if possible. That way, attr.procedure is only set
6636 if it is declared by a later procedure-declaration-stmt, which is
6637 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6638 while ((*proc_if)->ts.interface
6639 && *proc_if != (*proc_if)->ts.interface)
6640 *proc_if = (*proc_if)->ts.interface;
6641
6642 if ((*proc_if)->attr.flavor == FL_UNKNOWN
6643 && (*proc_if)->ts.type == BT_UNKNOWN
6644 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
6645 (*proc_if)->name, NULL))
6646 return MATCH_ERROR;
6647 }
6648
6649 got_ts:
6650 if (gfc_match (" )") != MATCH_YES)
6651 {
6652 gfc_current_locus = entry_loc;
6653 return MATCH_NO;
6654 }
6655
6656 return MATCH_YES;
6657 }
6658
6659
6660 /* Match a PROCEDURE declaration (R1211). */
6661
6662 static match
match_procedure_decl(void)6663 match_procedure_decl (void)
6664 {
6665 match m;
6666 gfc_symbol *sym, *proc_if = NULL;
6667 int num;
6668 gfc_expr *initializer = NULL;
6669
6670 /* Parse interface (with brackets). */
6671 m = match_procedure_interface (&proc_if);
6672 if (m != MATCH_YES)
6673 return m;
6674
6675 /* Parse attributes (with colons). */
6676 m = match_attr_spec();
6677 if (m == MATCH_ERROR)
6678 return MATCH_ERROR;
6679
6680 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
6681 {
6682 current_attr.is_bind_c = 1;
6683 has_name_equals = 0;
6684 curr_binding_label = NULL;
6685 }
6686
6687 /* Get procedure symbols. */
6688 for(num=1;;num++)
6689 {
6690 m = gfc_match_symbol (&sym, 0);
6691 if (m == MATCH_NO)
6692 goto syntax;
6693 else if (m == MATCH_ERROR)
6694 return m;
6695
6696 /* Add current_attr to the symbol attributes. */
6697 if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
6698 return MATCH_ERROR;
6699
6700 if (sym->attr.is_bind_c)
6701 {
6702 /* Check for C1218. */
6703 if (!proc_if || !proc_if->attr.is_bind_c)
6704 {
6705 gfc_error ("BIND(C) attribute at %C requires "
6706 "an interface with BIND(C)");
6707 return MATCH_ERROR;
6708 }
6709 /* Check for C1217. */
6710 if (has_name_equals && sym->attr.pointer)
6711 {
6712 gfc_error ("BIND(C) procedure with NAME may not have "
6713 "POINTER attribute at %C");
6714 return MATCH_ERROR;
6715 }
6716 if (has_name_equals && sym->attr.dummy)
6717 {
6718 gfc_error ("Dummy procedure at %C may not have "
6719 "BIND(C) attribute with NAME");
6720 return MATCH_ERROR;
6721 }
6722 /* Set binding label for BIND(C). */
6723 if (!set_binding_label (&sym->binding_label, sym->name, num))
6724 return MATCH_ERROR;
6725 }
6726
6727 if (!gfc_add_external (&sym->attr, NULL))
6728 return MATCH_ERROR;
6729
6730 if (add_hidden_procptr_result (sym))
6731 sym = sym->result;
6732
6733 if (!gfc_add_proc (&sym->attr, sym->name, NULL))
6734 return MATCH_ERROR;
6735
6736 /* Set interface. */
6737 if (proc_if != NULL)
6738 {
6739 if (sym->ts.type != BT_UNKNOWN)
6740 {
6741 gfc_error ("Procedure %qs at %L already has basic type of %s",
6742 sym->name, &gfc_current_locus,
6743 gfc_basic_typename (sym->ts.type));
6744 return MATCH_ERROR;
6745 }
6746 sym->ts.interface = proc_if;
6747 sym->attr.untyped = 1;
6748 sym->attr.if_source = IFSRC_IFBODY;
6749 }
6750 else if (current_ts.type != BT_UNKNOWN)
6751 {
6752 if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
6753 return MATCH_ERROR;
6754 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6755 sym->ts.interface->ts = current_ts;
6756 sym->ts.interface->attr.flavor = FL_PROCEDURE;
6757 sym->ts.interface->attr.function = 1;
6758 sym->attr.function = 1;
6759 sym->attr.if_source = IFSRC_UNKNOWN;
6760 }
6761
6762 if (gfc_match (" =>") == MATCH_YES)
6763 {
6764 if (!current_attr.pointer)
6765 {
6766 gfc_error ("Initialization at %C isn't for a pointer variable");
6767 m = MATCH_ERROR;
6768 goto cleanup;
6769 }
6770
6771 m = match_pointer_init (&initializer, 1);
6772 if (m != MATCH_YES)
6773 goto cleanup;
6774
6775 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
6776 goto cleanup;
6777
6778 }
6779
6780 if (gfc_match_eos () == MATCH_YES)
6781 return MATCH_YES;
6782 if (gfc_match_char (',') != MATCH_YES)
6783 goto syntax;
6784 }
6785
6786 syntax:
6787 gfc_error ("Syntax error in PROCEDURE statement at %C");
6788 return MATCH_ERROR;
6789
6790 cleanup:
6791 /* Free stuff up and return. */
6792 gfc_free_expr (initializer);
6793 return m;
6794 }
6795
6796
6797 static match
6798 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
6799
6800
6801 /* Match a procedure pointer component declaration (R445). */
6802
6803 static match
match_ppc_decl(void)6804 match_ppc_decl (void)
6805 {
6806 match m;
6807 gfc_symbol *proc_if = NULL;
6808 gfc_typespec ts;
6809 int num;
6810 gfc_component *c;
6811 gfc_expr *initializer = NULL;
6812 gfc_typebound_proc* tb;
6813 char name[GFC_MAX_SYMBOL_LEN + 1];
6814
6815 /* Parse interface (with brackets). */
6816 m = match_procedure_interface (&proc_if);
6817 if (m != MATCH_YES)
6818 goto syntax;
6819
6820 /* Parse attributes. */
6821 tb = XCNEW (gfc_typebound_proc);
6822 tb->where = gfc_current_locus;
6823 m = match_binding_attributes (tb, false, true);
6824 if (m == MATCH_ERROR)
6825 return m;
6826
6827 gfc_clear_attr (¤t_attr);
6828 current_attr.procedure = 1;
6829 current_attr.proc_pointer = 1;
6830 current_attr.access = tb->access;
6831 current_attr.flavor = FL_PROCEDURE;
6832
6833 /* Match the colons (required). */
6834 if (gfc_match (" ::") != MATCH_YES)
6835 {
6836 gfc_error ("Expected %<::%> after binding-attributes at %C");
6837 return MATCH_ERROR;
6838 }
6839
6840 /* Check for C450. */
6841 if (!tb->nopass && proc_if == NULL)
6842 {
6843 gfc_error("NOPASS or explicit interface required at %C");
6844 return MATCH_ERROR;
6845 }
6846
6847 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
6848 return MATCH_ERROR;
6849
6850 /* Match PPC names. */
6851 ts = current_ts;
6852 for(num=1;;num++)
6853 {
6854 m = gfc_match_name (name);
6855 if (m == MATCH_NO)
6856 goto syntax;
6857 else if (m == MATCH_ERROR)
6858 return m;
6859
6860 if (!gfc_add_component (gfc_current_block(), name, &c))
6861 return MATCH_ERROR;
6862
6863 /* Add current_attr to the symbol attributes. */
6864 if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
6865 return MATCH_ERROR;
6866
6867 if (!gfc_add_external (&c->attr, NULL))
6868 return MATCH_ERROR;
6869
6870 if (!gfc_add_proc (&c->attr, name, NULL))
6871 return MATCH_ERROR;
6872
6873 if (num == 1)
6874 c->tb = tb;
6875 else
6876 {
6877 c->tb = XCNEW (gfc_typebound_proc);
6878 c->tb->where = gfc_current_locus;
6879 *c->tb = *tb;
6880 }
6881
6882 /* Set interface. */
6883 if (proc_if != NULL)
6884 {
6885 c->ts.interface = proc_if;
6886 c->attr.untyped = 1;
6887 c->attr.if_source = IFSRC_IFBODY;
6888 }
6889 else if (ts.type != BT_UNKNOWN)
6890 {
6891 c->ts = ts;
6892 c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6893 c->ts.interface->result = c->ts.interface;
6894 c->ts.interface->ts = ts;
6895 c->ts.interface->attr.flavor = FL_PROCEDURE;
6896 c->ts.interface->attr.function = 1;
6897 c->attr.function = 1;
6898 c->attr.if_source = IFSRC_UNKNOWN;
6899 }
6900
6901 if (gfc_match (" =>") == MATCH_YES)
6902 {
6903 m = match_pointer_init (&initializer, 1);
6904 if (m != MATCH_YES)
6905 {
6906 gfc_free_expr (initializer);
6907 return m;
6908 }
6909 c->initializer = initializer;
6910 }
6911
6912 if (gfc_match_eos () == MATCH_YES)
6913 return MATCH_YES;
6914 if (gfc_match_char (',') != MATCH_YES)
6915 goto syntax;
6916 }
6917
6918 syntax:
6919 gfc_error ("Syntax error in procedure pointer component at %C");
6920 return MATCH_ERROR;
6921 }
6922
6923
6924 /* Match a PROCEDURE declaration inside an interface (R1206). */
6925
6926 static match
match_procedure_in_interface(void)6927 match_procedure_in_interface (void)
6928 {
6929 match m;
6930 gfc_symbol *sym;
6931 char name[GFC_MAX_SYMBOL_LEN + 1];
6932 locus old_locus;
6933
6934 if (current_interface.type == INTERFACE_NAMELESS
6935 || current_interface.type == INTERFACE_ABSTRACT)
6936 {
6937 gfc_error ("PROCEDURE at %C must be in a generic interface");
6938 return MATCH_ERROR;
6939 }
6940
6941 /* Check if the F2008 optional double colon appears. */
6942 gfc_gobble_whitespace ();
6943 old_locus = gfc_current_locus;
6944 if (gfc_match ("::") == MATCH_YES)
6945 {
6946 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
6947 "MODULE PROCEDURE statement at %L", &old_locus))
6948 return MATCH_ERROR;
6949 }
6950 else
6951 gfc_current_locus = old_locus;
6952
6953 for(;;)
6954 {
6955 m = gfc_match_name (name);
6956 if (m == MATCH_NO)
6957 goto syntax;
6958 else if (m == MATCH_ERROR)
6959 return m;
6960 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
6961 return MATCH_ERROR;
6962
6963 if (!gfc_add_interface (sym))
6964 return MATCH_ERROR;
6965
6966 if (gfc_match_eos () == MATCH_YES)
6967 break;
6968 if (gfc_match_char (',') != MATCH_YES)
6969 goto syntax;
6970 }
6971
6972 return MATCH_YES;
6973
6974 syntax:
6975 gfc_error ("Syntax error in PROCEDURE statement at %C");
6976 return MATCH_ERROR;
6977 }
6978
6979
6980 /* General matcher for PROCEDURE declarations. */
6981
6982 static match match_procedure_in_type (void);
6983
6984 match
gfc_match_procedure(void)6985 gfc_match_procedure (void)
6986 {
6987 match m;
6988
6989 switch (gfc_current_state ())
6990 {
6991 case COMP_NONE:
6992 case COMP_PROGRAM:
6993 case COMP_MODULE:
6994 case COMP_SUBMODULE:
6995 case COMP_SUBROUTINE:
6996 case COMP_FUNCTION:
6997 case COMP_BLOCK:
6998 m = match_procedure_decl ();
6999 break;
7000 case COMP_INTERFACE:
7001 m = match_procedure_in_interface ();
7002 break;
7003 case COMP_DERIVED:
7004 m = match_ppc_decl ();
7005 break;
7006 case COMP_DERIVED_CONTAINS:
7007 m = match_procedure_in_type ();
7008 break;
7009 default:
7010 return MATCH_NO;
7011 }
7012
7013 if (m != MATCH_YES)
7014 return m;
7015
7016 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7017 return MATCH_ERROR;
7018
7019 return m;
7020 }
7021
7022
7023 /* Warn if a matched procedure has the same name as an intrinsic; this is
7024 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7025 parser-state-stack to find out whether we're in a module. */
7026
7027 static void
do_warn_intrinsic_shadow(const gfc_symbol * sym,bool func)7028 do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7029 {
7030 bool in_module;
7031
7032 in_module = (gfc_state_stack->previous
7033 && (gfc_state_stack->previous->state == COMP_MODULE
7034 || gfc_state_stack->previous->state == COMP_SUBMODULE));
7035
7036 gfc_warn_intrinsic_shadow (sym, in_module, func);
7037 }
7038
7039
7040 /* Match a function declaration. */
7041
7042 match
gfc_match_function_decl(void)7043 gfc_match_function_decl (void)
7044 {
7045 char name[GFC_MAX_SYMBOL_LEN + 1];
7046 gfc_symbol *sym, *result;
7047 locus old_loc;
7048 match m;
7049 match suffix_match;
7050 match found_match; /* Status returned by match func. */
7051
7052 if (gfc_current_state () != COMP_NONE
7053 && gfc_current_state () != COMP_INTERFACE
7054 && gfc_current_state () != COMP_CONTAINS)
7055 return MATCH_NO;
7056
7057 gfc_clear_ts (¤t_ts);
7058
7059 old_loc = gfc_current_locus;
7060
7061 m = gfc_match_prefix (¤t_ts);
7062 if (m != MATCH_YES)
7063 {
7064 gfc_current_locus = old_loc;
7065 return m;
7066 }
7067
7068 if (gfc_match ("function% %n", name) != MATCH_YES)
7069 {
7070 gfc_current_locus = old_loc;
7071 return MATCH_NO;
7072 }
7073
7074 if (get_proc_name (name, &sym, false))
7075 return MATCH_ERROR;
7076
7077 if (add_hidden_procptr_result (sym))
7078 sym = sym->result;
7079
7080 if (current_attr.module_procedure)
7081 sym->attr.module_procedure = 1;
7082
7083 gfc_new_block = sym;
7084
7085 m = gfc_match_formal_arglist (sym, 0, 0);
7086 if (m == MATCH_NO)
7087 {
7088 gfc_error ("Expected formal argument list in function "
7089 "definition at %C");
7090 m = MATCH_ERROR;
7091 goto cleanup;
7092 }
7093 else if (m == MATCH_ERROR)
7094 goto cleanup;
7095
7096 result = NULL;
7097
7098 /* According to the draft, the bind(c) and result clause can
7099 come in either order after the formal_arg_list (i.e., either
7100 can be first, both can exist together or by themselves or neither
7101 one). Therefore, the match_result can't match the end of the
7102 string, and check for the bind(c) or result clause in either order. */
7103 found_match = gfc_match_eos ();
7104
7105 /* Make sure that it isn't already declared as BIND(C). If it is, it
7106 must have been marked BIND(C) with a BIND(C) attribute and that is
7107 not allowed for procedures. */
7108 if (sym->attr.is_bind_c == 1)
7109 {
7110 sym->attr.is_bind_c = 0;
7111 if (sym->old_symbol != NULL)
7112 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7113 "variables or common blocks",
7114 &(sym->old_symbol->declared_at));
7115 else
7116 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7117 "variables or common blocks", &gfc_current_locus);
7118 }
7119
7120 if (found_match != MATCH_YES)
7121 {
7122 /* If we haven't found the end-of-statement, look for a suffix. */
7123 suffix_match = gfc_match_suffix (sym, &result);
7124 if (suffix_match == MATCH_YES)
7125 /* Need to get the eos now. */
7126 found_match = gfc_match_eos ();
7127 else
7128 found_match = suffix_match;
7129 }
7130
7131 if(found_match != MATCH_YES)
7132 m = MATCH_ERROR;
7133 else
7134 {
7135 /* Make changes to the symbol. */
7136 m = MATCH_ERROR;
7137
7138 if (!gfc_add_function (&sym->attr, sym->name, NULL))
7139 goto cleanup;
7140
7141 if (!gfc_missing_attr (&sym->attr, NULL))
7142 goto cleanup;
7143
7144 if (!copy_prefix (&sym->attr, &sym->declared_at))
7145 {
7146 if(!sym->attr.module_procedure)
7147 goto cleanup;
7148 else
7149 gfc_error_check ();
7150 }
7151
7152 /* Delay matching the function characteristics until after the
7153 specification block by signalling kind=-1. */
7154 sym->declared_at = old_loc;
7155 if (current_ts.type != BT_UNKNOWN)
7156 current_ts.kind = -1;
7157 else
7158 current_ts.kind = 0;
7159
7160 if (result == NULL)
7161 {
7162 if (current_ts.type != BT_UNKNOWN
7163 && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7164 goto cleanup;
7165 sym->result = sym;
7166 }
7167 else
7168 {
7169 if (current_ts.type != BT_UNKNOWN
7170 && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
7171 goto cleanup;
7172 sym->result = result;
7173 }
7174
7175 /* Warn if this procedure has the same name as an intrinsic. */
7176 do_warn_intrinsic_shadow (sym, true);
7177
7178 return MATCH_YES;
7179 }
7180
7181 cleanup:
7182 gfc_current_locus = old_loc;
7183 return m;
7184 }
7185
7186
7187 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7188 pass the name of the entry, rather than the gfc_current_block name, and
7189 to return false upon finding an existing global entry. */
7190
7191 static bool
add_global_entry(const char * name,const char * binding_label,bool sub,locus * where)7192 add_global_entry (const char *name, const char *binding_label, bool sub,
7193 locus *where)
7194 {
7195 gfc_gsymbol *s;
7196 enum gfc_symbol_type type;
7197
7198 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7199
7200 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7201 name is a global identifier. */
7202 if (!binding_label || gfc_notification_std (GFC_STD_F2008))
7203 {
7204 s = gfc_get_gsymbol (name, false);
7205
7206 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7207 {
7208 gfc_global_used (s, where);
7209 return false;
7210 }
7211 else
7212 {
7213 s->type = type;
7214 s->sym_name = name;
7215 s->where = *where;
7216 s->defined = 1;
7217 s->ns = gfc_current_ns;
7218 }
7219 }
7220
7221 /* Don't add the symbol multiple times. */
7222 if (binding_label
7223 && (!gfc_notification_std (GFC_STD_F2008)
7224 || strcmp (name, binding_label) != 0))
7225 {
7226 s = gfc_get_gsymbol (binding_label, true);
7227
7228 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7229 {
7230 gfc_global_used (s, where);
7231 return false;
7232 }
7233 else
7234 {
7235 s->type = type;
7236 s->sym_name = name;
7237 s->binding_label = binding_label;
7238 s->where = *where;
7239 s->defined = 1;
7240 s->ns = gfc_current_ns;
7241 }
7242 }
7243
7244 return true;
7245 }
7246
7247
7248 /* Match an ENTRY statement. */
7249
7250 match
gfc_match_entry(void)7251 gfc_match_entry (void)
7252 {
7253 gfc_symbol *proc;
7254 gfc_symbol *result;
7255 gfc_symbol *entry;
7256 char name[GFC_MAX_SYMBOL_LEN + 1];
7257 gfc_compile_state state;
7258 match m;
7259 gfc_entry_list *el;
7260 locus old_loc;
7261 bool module_procedure;
7262 char peek_char;
7263 match is_bind_c;
7264
7265 m = gfc_match_name (name);
7266 if (m != MATCH_YES)
7267 return m;
7268
7269 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
7270 return MATCH_ERROR;
7271
7272 state = gfc_current_state ();
7273 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
7274 {
7275 switch (state)
7276 {
7277 case COMP_PROGRAM:
7278 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7279 break;
7280 case COMP_MODULE:
7281 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7282 break;
7283 case COMP_SUBMODULE:
7284 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7285 break;
7286 case COMP_BLOCK_DATA:
7287 gfc_error ("ENTRY statement at %C cannot appear within "
7288 "a BLOCK DATA");
7289 break;
7290 case COMP_INTERFACE:
7291 gfc_error ("ENTRY statement at %C cannot appear within "
7292 "an INTERFACE");
7293 break;
7294 case COMP_STRUCTURE:
7295 gfc_error ("ENTRY statement at %C cannot appear within "
7296 "a STRUCTURE block");
7297 break;
7298 case COMP_DERIVED:
7299 gfc_error ("ENTRY statement at %C cannot appear within "
7300 "a DERIVED TYPE block");
7301 break;
7302 case COMP_IF:
7303 gfc_error ("ENTRY statement at %C cannot appear within "
7304 "an IF-THEN block");
7305 break;
7306 case COMP_DO:
7307 case COMP_DO_CONCURRENT:
7308 gfc_error ("ENTRY statement at %C cannot appear within "
7309 "a DO block");
7310 break;
7311 case COMP_SELECT:
7312 gfc_error ("ENTRY statement at %C cannot appear within "
7313 "a SELECT block");
7314 break;
7315 case COMP_FORALL:
7316 gfc_error ("ENTRY statement at %C cannot appear within "
7317 "a FORALL block");
7318 break;
7319 case COMP_WHERE:
7320 gfc_error ("ENTRY statement at %C cannot appear within "
7321 "a WHERE block");
7322 break;
7323 case COMP_CONTAINS:
7324 gfc_error ("ENTRY statement at %C cannot appear within "
7325 "a contained subprogram");
7326 break;
7327 default:
7328 gfc_error ("Unexpected ENTRY statement at %C");
7329 }
7330 return MATCH_ERROR;
7331 }
7332
7333 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
7334 && gfc_state_stack->previous->state == COMP_INTERFACE)
7335 {
7336 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7337 return MATCH_ERROR;
7338 }
7339
7340 module_procedure = gfc_current_ns->parent != NULL
7341 && gfc_current_ns->parent->proc_name
7342 && gfc_current_ns->parent->proc_name->attr.flavor
7343 == FL_MODULE;
7344
7345 if (gfc_current_ns->parent != NULL
7346 && gfc_current_ns->parent->proc_name
7347 && !module_procedure)
7348 {
7349 gfc_error("ENTRY statement at %C cannot appear in a "
7350 "contained procedure");
7351 return MATCH_ERROR;
7352 }
7353
7354 /* Module function entries need special care in get_proc_name
7355 because previous references within the function will have
7356 created symbols attached to the current namespace. */
7357 if (get_proc_name (name, &entry,
7358 gfc_current_ns->parent != NULL
7359 && module_procedure))
7360 return MATCH_ERROR;
7361
7362 proc = gfc_current_block ();
7363
7364 /* Make sure that it isn't already declared as BIND(C). If it is, it
7365 must have been marked BIND(C) with a BIND(C) attribute and that is
7366 not allowed for procedures. */
7367 if (entry->attr.is_bind_c == 1)
7368 {
7369 entry->attr.is_bind_c = 0;
7370 if (entry->old_symbol != NULL)
7371 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7372 "variables or common blocks",
7373 &(entry->old_symbol->declared_at));
7374 else
7375 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7376 "variables or common blocks", &gfc_current_locus);
7377 }
7378
7379 /* Check what next non-whitespace character is so we can tell if there
7380 is the required parens if we have a BIND(C). */
7381 old_loc = gfc_current_locus;
7382 gfc_gobble_whitespace ();
7383 peek_char = gfc_peek_ascii_char ();
7384
7385 if (state == COMP_SUBROUTINE)
7386 {
7387 m = gfc_match_formal_arglist (entry, 0, 1);
7388 if (m != MATCH_YES)
7389 return MATCH_ERROR;
7390
7391 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7392 never be an internal procedure. */
7393 is_bind_c = gfc_match_bind_c (entry, true);
7394 if (is_bind_c == MATCH_ERROR)
7395 return MATCH_ERROR;
7396 if (is_bind_c == MATCH_YES)
7397 {
7398 if (peek_char != '(')
7399 {
7400 gfc_error ("Missing required parentheses before BIND(C) at %C");
7401 return MATCH_ERROR;
7402 }
7403
7404 if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
7405 &(entry->declared_at), 1))
7406 return MATCH_ERROR;
7407
7408 }
7409
7410 if (!gfc_current_ns->parent
7411 && !add_global_entry (name, entry->binding_label, true,
7412 &old_loc))
7413 return MATCH_ERROR;
7414
7415 /* An entry in a subroutine. */
7416 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7417 || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
7418 return MATCH_ERROR;
7419 }
7420 else
7421 {
7422 /* An entry in a function.
7423 We need to take special care because writing
7424 ENTRY f()
7425 as
7426 ENTRY f
7427 is allowed, whereas
7428 ENTRY f() RESULT (r)
7429 can't be written as
7430 ENTRY f RESULT (r). */
7431 if (gfc_match_eos () == MATCH_YES)
7432 {
7433 gfc_current_locus = old_loc;
7434 /* Match the empty argument list, and add the interface to
7435 the symbol. */
7436 m = gfc_match_formal_arglist (entry, 0, 1);
7437 }
7438 else
7439 m = gfc_match_formal_arglist (entry, 0, 0);
7440
7441 if (m != MATCH_YES)
7442 return MATCH_ERROR;
7443
7444 result = NULL;
7445
7446 if (gfc_match_eos () == MATCH_YES)
7447 {
7448 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7449 || !gfc_add_function (&entry->attr, entry->name, NULL))
7450 return MATCH_ERROR;
7451
7452 entry->result = entry;
7453 }
7454 else
7455 {
7456 m = gfc_match_suffix (entry, &result);
7457 if (m == MATCH_NO)
7458 gfc_syntax_error (ST_ENTRY);
7459 if (m != MATCH_YES)
7460 return MATCH_ERROR;
7461
7462 if (result)
7463 {
7464 if (!gfc_add_result (&result->attr, result->name, NULL)
7465 || !gfc_add_entry (&entry->attr, result->name, NULL)
7466 || !gfc_add_function (&entry->attr, result->name, NULL))
7467 return MATCH_ERROR;
7468 entry->result = result;
7469 }
7470 else
7471 {
7472 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7473 || !gfc_add_function (&entry->attr, entry->name, NULL))
7474 return MATCH_ERROR;
7475 entry->result = entry;
7476 }
7477 }
7478
7479 if (!gfc_current_ns->parent
7480 && !add_global_entry (name, entry->binding_label, false,
7481 &old_loc))
7482 return MATCH_ERROR;
7483 }
7484
7485 if (gfc_match_eos () != MATCH_YES)
7486 {
7487 gfc_syntax_error (ST_ENTRY);
7488 return MATCH_ERROR;
7489 }
7490
7491 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7492 if (proc->attr.elemental && entry->attr.is_bind_c)
7493 {
7494 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7495 "elemental procedure", &entry->declared_at);
7496 return MATCH_ERROR;
7497 }
7498
7499 entry->attr.recursive = proc->attr.recursive;
7500 entry->attr.elemental = proc->attr.elemental;
7501 entry->attr.pure = proc->attr.pure;
7502
7503 el = gfc_get_entry_list ();
7504 el->sym = entry;
7505 el->next = gfc_current_ns->entries;
7506 gfc_current_ns->entries = el;
7507 if (el->next)
7508 el->id = el->next->id + 1;
7509 else
7510 el->id = 1;
7511
7512 new_st.op = EXEC_ENTRY;
7513 new_st.ext.entry = el;
7514
7515 return MATCH_YES;
7516 }
7517
7518
7519 /* Match a subroutine statement, including optional prefixes. */
7520
7521 match
gfc_match_subroutine(void)7522 gfc_match_subroutine (void)
7523 {
7524 char name[GFC_MAX_SYMBOL_LEN + 1];
7525 gfc_symbol *sym;
7526 match m;
7527 match is_bind_c;
7528 char peek_char;
7529 bool allow_binding_name;
7530
7531 if (gfc_current_state () != COMP_NONE
7532 && gfc_current_state () != COMP_INTERFACE
7533 && gfc_current_state () != COMP_CONTAINS)
7534 return MATCH_NO;
7535
7536 m = gfc_match_prefix (NULL);
7537 if (m != MATCH_YES)
7538 return m;
7539
7540 m = gfc_match ("subroutine% %n", name);
7541 if (m != MATCH_YES)
7542 return m;
7543
7544 if (get_proc_name (name, &sym, false))
7545 return MATCH_ERROR;
7546
7547 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7548 the symbol existed before. */
7549 sym->declared_at = gfc_current_locus;
7550
7551 if (current_attr.module_procedure)
7552 sym->attr.module_procedure = 1;
7553
7554 if (add_hidden_procptr_result (sym))
7555 sym = sym->result;
7556
7557 gfc_new_block = sym;
7558
7559 /* Check what next non-whitespace character is so we can tell if there
7560 is the required parens if we have a BIND(C). */
7561 gfc_gobble_whitespace ();
7562 peek_char = gfc_peek_ascii_char ();
7563
7564 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
7565 return MATCH_ERROR;
7566
7567 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
7568 return MATCH_ERROR;
7569
7570 /* Make sure that it isn't already declared as BIND(C). If it is, it
7571 must have been marked BIND(C) with a BIND(C) attribute and that is
7572 not allowed for procedures. */
7573 if (sym->attr.is_bind_c == 1)
7574 {
7575 sym->attr.is_bind_c = 0;
7576 if (sym->old_symbol != NULL)
7577 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7578 "variables or common blocks",
7579 &(sym->old_symbol->declared_at));
7580 else
7581 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7582 "variables or common blocks", &gfc_current_locus);
7583 }
7584
7585 /* C binding names are not allowed for internal procedures. */
7586 if (gfc_current_state () == COMP_CONTAINS
7587 && sym->ns->proc_name->attr.flavor != FL_MODULE)
7588 allow_binding_name = false;
7589 else
7590 allow_binding_name = true;
7591
7592 /* Here, we are just checking if it has the bind(c) attribute, and if
7593 so, then we need to make sure it's all correct. If it doesn't,
7594 we still need to continue matching the rest of the subroutine line. */
7595 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7596 if (is_bind_c == MATCH_ERROR)
7597 {
7598 /* There was an attempt at the bind(c), but it was wrong. An
7599 error message should have been printed w/in the gfc_match_bind_c
7600 so here we'll just return the MATCH_ERROR. */
7601 return MATCH_ERROR;
7602 }
7603
7604 if (is_bind_c == MATCH_YES)
7605 {
7606 /* The following is allowed in the Fortran 2008 draft. */
7607 if (gfc_current_state () == COMP_CONTAINS
7608 && sym->ns->proc_name->attr.flavor != FL_MODULE
7609 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7610 "at %L may not be specified for an internal "
7611 "procedure", &gfc_current_locus))
7612 return MATCH_ERROR;
7613
7614 if (peek_char != '(')
7615 {
7616 gfc_error ("Missing required parentheses before BIND(C) at %C");
7617 return MATCH_ERROR;
7618 }
7619 if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
7620 &(sym->declared_at), 1))
7621 return MATCH_ERROR;
7622 }
7623
7624 if (gfc_match_eos () != MATCH_YES)
7625 {
7626 gfc_syntax_error (ST_SUBROUTINE);
7627 return MATCH_ERROR;
7628 }
7629
7630 if (!copy_prefix (&sym->attr, &sym->declared_at))
7631 {
7632 if(!sym->attr.module_procedure)
7633 return MATCH_ERROR;
7634 else
7635 gfc_error_check ();
7636 }
7637
7638 /* Warn if it has the same name as an intrinsic. */
7639 do_warn_intrinsic_shadow (sym, false);
7640
7641 return MATCH_YES;
7642 }
7643
7644
7645 /* Check that the NAME identifier in a BIND attribute or statement
7646 is conform to C identifier rules. */
7647
7648 match
check_bind_name_identifier(char ** name)7649 check_bind_name_identifier (char **name)
7650 {
7651 char *n = *name, *p;
7652
7653 /* Remove leading spaces. */
7654 while (*n == ' ')
7655 n++;
7656
7657 /* On an empty string, free memory and set name to NULL. */
7658 if (*n == '\0')
7659 {
7660 free (*name);
7661 *name = NULL;
7662 return MATCH_YES;
7663 }
7664
7665 /* Remove trailing spaces. */
7666 p = n + strlen(n) - 1;
7667 while (*p == ' ')
7668 *(p--) = '\0';
7669
7670 /* Insert the identifier into the symbol table. */
7671 p = xstrdup (n);
7672 free (*name);
7673 *name = p;
7674
7675 /* Now check that identifier is valid under C rules. */
7676 if (ISDIGIT (*p))
7677 {
7678 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7679 return MATCH_ERROR;
7680 }
7681
7682 for (; *p; p++)
7683 if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
7684 {
7685 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7686 return MATCH_ERROR;
7687 }
7688
7689 return MATCH_YES;
7690 }
7691
7692
7693 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7694 given, and set the binding label in either the given symbol (if not
7695 NULL), or in the current_ts. The symbol may be NULL because we may
7696 encounter the BIND(C) before the declaration itself. Return
7697 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7698 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7699 or MATCH_YES if the specifier was correct and the binding label and
7700 bind(c) fields were set correctly for the given symbol or the
7701 current_ts. If allow_binding_name is false, no binding name may be
7702 given. */
7703
7704 match
gfc_match_bind_c(gfc_symbol * sym,bool allow_binding_name)7705 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
7706 {
7707 char *binding_label = NULL;
7708 gfc_expr *e = NULL;
7709
7710 /* Initialize the flag that specifies whether we encountered a NAME=
7711 specifier or not. */
7712 has_name_equals = 0;
7713
7714 /* This much we have to be able to match, in this order, if
7715 there is a bind(c) label. */
7716 if (gfc_match (" bind ( c ") != MATCH_YES)
7717 return MATCH_NO;
7718
7719 /* Now see if there is a binding label, or if we've reached the
7720 end of the bind(c) attribute without one. */
7721 if (gfc_match_char (',') == MATCH_YES)
7722 {
7723 if (gfc_match (" name = ") != MATCH_YES)
7724 {
7725 gfc_error ("Syntax error in NAME= specifier for binding label "
7726 "at %C");
7727 /* should give an error message here */
7728 return MATCH_ERROR;
7729 }
7730
7731 has_name_equals = 1;
7732
7733 if (gfc_match_init_expr (&e) != MATCH_YES)
7734 {
7735 gfc_free_expr (e);
7736 return MATCH_ERROR;
7737 }
7738
7739 if (!gfc_simplify_expr(e, 0))
7740 {
7741 gfc_error ("NAME= specifier at %C should be a constant expression");
7742 gfc_free_expr (e);
7743 return MATCH_ERROR;
7744 }
7745
7746 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
7747 || e->ts.kind != gfc_default_character_kind || e->rank != 0)
7748 {
7749 gfc_error ("NAME= specifier at %C should be a scalar of "
7750 "default character kind");
7751 gfc_free_expr(e);
7752 return MATCH_ERROR;
7753 }
7754
7755 // Get a C string from the Fortran string constant
7756 binding_label = gfc_widechar_to_char (e->value.character.string,
7757 e->value.character.length);
7758 gfc_free_expr(e);
7759
7760 // Check that it is valid (old gfc_match_name_C)
7761 if (check_bind_name_identifier (&binding_label) != MATCH_YES)
7762 return MATCH_ERROR;
7763 }
7764
7765 /* Get the required right paren. */
7766 if (gfc_match_char (')') != MATCH_YES)
7767 {
7768 gfc_error ("Missing closing paren for binding label at %C");
7769 return MATCH_ERROR;
7770 }
7771
7772 if (has_name_equals && !allow_binding_name)
7773 {
7774 gfc_error ("No binding name is allowed in BIND(C) at %C");
7775 return MATCH_ERROR;
7776 }
7777
7778 if (has_name_equals && sym != NULL && sym->attr.dummy)
7779 {
7780 gfc_error ("For dummy procedure %s, no binding name is "
7781 "allowed in BIND(C) at %C", sym->name);
7782 return MATCH_ERROR;
7783 }
7784
7785
7786 /* Save the binding label to the symbol. If sym is null, we're
7787 probably matching the typespec attributes of a declaration and
7788 haven't gotten the name yet, and therefore, no symbol yet. */
7789 if (binding_label)
7790 {
7791 if (sym != NULL)
7792 sym->binding_label = binding_label;
7793 else
7794 curr_binding_label = binding_label;
7795 }
7796 else if (allow_binding_name)
7797 {
7798 /* No binding label, but if symbol isn't null, we
7799 can set the label for it here.
7800 If name="" or allow_binding_name is false, no C binding name is
7801 created. */
7802 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
7803 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
7804 }
7805
7806 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
7807 && current_interface.type == INTERFACE_ABSTRACT)
7808 {
7809 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7810 return MATCH_ERROR;
7811 }
7812
7813 return MATCH_YES;
7814 }
7815
7816
7817 /* Return nonzero if we're currently compiling a contained procedure. */
7818
7819 static int
contained_procedure(void)7820 contained_procedure (void)
7821 {
7822 gfc_state_data *s = gfc_state_stack;
7823
7824 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
7825 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
7826 return 1;
7827
7828 return 0;
7829 }
7830
7831 /* Set the kind of each enumerator. The kind is selected such that it is
7832 interoperable with the corresponding C enumeration type, making
7833 sure that -fshort-enums is honored. */
7834
7835 static void
set_enum_kind(void)7836 set_enum_kind(void)
7837 {
7838 enumerator_history *current_history = NULL;
7839 int kind;
7840 int i;
7841
7842 if (max_enum == NULL || enum_history == NULL)
7843 return;
7844
7845 if (!flag_short_enums)
7846 return;
7847
7848 i = 0;
7849 do
7850 {
7851 kind = gfc_integer_kinds[i++].kind;
7852 }
7853 while (kind < gfc_c_int_kind
7854 && gfc_check_integer_range (max_enum->initializer->value.integer,
7855 kind) != ARITH_OK);
7856
7857 current_history = enum_history;
7858 while (current_history != NULL)
7859 {
7860 current_history->sym->ts.kind = kind;
7861 current_history = current_history->next;
7862 }
7863 }
7864
7865
7866 /* Match any of the various end-block statements. Returns the type of
7867 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7868 and END BLOCK statements cannot be replaced by a single END statement. */
7869
7870 match
gfc_match_end(gfc_statement * st)7871 gfc_match_end (gfc_statement *st)
7872 {
7873 char name[GFC_MAX_SYMBOL_LEN + 1];
7874 gfc_compile_state state;
7875 locus old_loc;
7876 const char *block_name;
7877 const char *target;
7878 int eos_ok;
7879 match m;
7880 gfc_namespace *parent_ns, *ns, *prev_ns;
7881 gfc_namespace **nsp;
7882 bool abreviated_modproc_decl = false;
7883 bool got_matching_end = false;
7884
7885 old_loc = gfc_current_locus;
7886 if (gfc_match ("end") != MATCH_YES)
7887 return MATCH_NO;
7888
7889 state = gfc_current_state ();
7890 block_name = gfc_current_block () == NULL
7891 ? NULL : gfc_current_block ()->name;
7892
7893 switch (state)
7894 {
7895 case COMP_ASSOCIATE:
7896 case COMP_BLOCK:
7897 if (!strncmp (block_name, "block@", strlen("block@")))
7898 block_name = NULL;
7899 break;
7900
7901 case COMP_CONTAINS:
7902 case COMP_DERIVED_CONTAINS:
7903 state = gfc_state_stack->previous->state;
7904 block_name = gfc_state_stack->previous->sym == NULL
7905 ? NULL : gfc_state_stack->previous->sym->name;
7906 abreviated_modproc_decl = gfc_state_stack->previous->sym
7907 && gfc_state_stack->previous->sym->abr_modproc_decl;
7908 break;
7909
7910 default:
7911 break;
7912 }
7913
7914 if (!abreviated_modproc_decl)
7915 abreviated_modproc_decl = gfc_current_block ()
7916 && gfc_current_block ()->abr_modproc_decl;
7917
7918 switch (state)
7919 {
7920 case COMP_NONE:
7921 case COMP_PROGRAM:
7922 *st = ST_END_PROGRAM;
7923 target = " program";
7924 eos_ok = 1;
7925 break;
7926
7927 case COMP_SUBROUTINE:
7928 *st = ST_END_SUBROUTINE;
7929 if (!abreviated_modproc_decl)
7930 target = " subroutine";
7931 else
7932 target = " procedure";
7933 eos_ok = !contained_procedure ();
7934 break;
7935
7936 case COMP_FUNCTION:
7937 *st = ST_END_FUNCTION;
7938 if (!abreviated_modproc_decl)
7939 target = " function";
7940 else
7941 target = " procedure";
7942 eos_ok = !contained_procedure ();
7943 break;
7944
7945 case COMP_BLOCK_DATA:
7946 *st = ST_END_BLOCK_DATA;
7947 target = " block data";
7948 eos_ok = 1;
7949 break;
7950
7951 case COMP_MODULE:
7952 *st = ST_END_MODULE;
7953 target = " module";
7954 eos_ok = 1;
7955 break;
7956
7957 case COMP_SUBMODULE:
7958 *st = ST_END_SUBMODULE;
7959 target = " submodule";
7960 eos_ok = 1;
7961 break;
7962
7963 case COMP_INTERFACE:
7964 *st = ST_END_INTERFACE;
7965 target = " interface";
7966 eos_ok = 0;
7967 break;
7968
7969 case COMP_MAP:
7970 *st = ST_END_MAP;
7971 target = " map";
7972 eos_ok = 0;
7973 break;
7974
7975 case COMP_UNION:
7976 *st = ST_END_UNION;
7977 target = " union";
7978 eos_ok = 0;
7979 break;
7980
7981 case COMP_STRUCTURE:
7982 *st = ST_END_STRUCTURE;
7983 target = " structure";
7984 eos_ok = 0;
7985 break;
7986
7987 case COMP_DERIVED:
7988 case COMP_DERIVED_CONTAINS:
7989 *st = ST_END_TYPE;
7990 target = " type";
7991 eos_ok = 0;
7992 break;
7993
7994 case COMP_ASSOCIATE:
7995 *st = ST_END_ASSOCIATE;
7996 target = " associate";
7997 eos_ok = 0;
7998 break;
7999
8000 case COMP_BLOCK:
8001 *st = ST_END_BLOCK;
8002 target = " block";
8003 eos_ok = 0;
8004 break;
8005
8006 case COMP_IF:
8007 *st = ST_ENDIF;
8008 target = " if";
8009 eos_ok = 0;
8010 break;
8011
8012 case COMP_DO:
8013 case COMP_DO_CONCURRENT:
8014 *st = ST_ENDDO;
8015 target = " do";
8016 eos_ok = 0;
8017 break;
8018
8019 case COMP_CRITICAL:
8020 *st = ST_END_CRITICAL;
8021 target = " critical";
8022 eos_ok = 0;
8023 break;
8024
8025 case COMP_SELECT:
8026 case COMP_SELECT_TYPE:
8027 *st = ST_END_SELECT;
8028 target = " select";
8029 eos_ok = 0;
8030 break;
8031
8032 case COMP_FORALL:
8033 *st = ST_END_FORALL;
8034 target = " forall";
8035 eos_ok = 0;
8036 break;
8037
8038 case COMP_WHERE:
8039 *st = ST_END_WHERE;
8040 target = " where";
8041 eos_ok = 0;
8042 break;
8043
8044 case COMP_ENUM:
8045 *st = ST_END_ENUM;
8046 target = " enum";
8047 eos_ok = 0;
8048 last_initializer = NULL;
8049 set_enum_kind ();
8050 gfc_free_enum_history ();
8051 break;
8052
8053 default:
8054 gfc_error ("Unexpected END statement at %C");
8055 goto cleanup;
8056 }
8057
8058 old_loc = gfc_current_locus;
8059 if (gfc_match_eos () == MATCH_YES)
8060 {
8061 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
8062 {
8063 if (!gfc_notify_std (GFC_STD_F2008, "END statement "
8064 "instead of %s statement at %L",
8065 abreviated_modproc_decl ? "END PROCEDURE"
8066 : gfc_ascii_statement(*st), &old_loc))
8067 goto cleanup;
8068 }
8069 else if (!eos_ok)
8070 {
8071 /* We would have required END [something]. */
8072 gfc_error ("%s statement expected at %L",
8073 gfc_ascii_statement (*st), &old_loc);
8074 goto cleanup;
8075 }
8076
8077 return MATCH_YES;
8078 }
8079
8080 /* Verify that we've got the sort of end-block that we're expecting. */
8081 if (gfc_match (target) != MATCH_YES)
8082 {
8083 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8084 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
8085 goto cleanup;
8086 }
8087 else
8088 got_matching_end = true;
8089
8090 old_loc = gfc_current_locus;
8091 /* If we're at the end, make sure a block name wasn't required. */
8092 if (gfc_match_eos () == MATCH_YES)
8093 {
8094
8095 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
8096 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
8097 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
8098 return MATCH_YES;
8099
8100 if (!block_name)
8101 return MATCH_YES;
8102
8103 gfc_error ("Expected block name of %qs in %s statement at %L",
8104 block_name, gfc_ascii_statement (*st), &old_loc);
8105
8106 return MATCH_ERROR;
8107 }
8108
8109 /* END INTERFACE has a special handler for its several possible endings. */
8110 if (*st == ST_END_INTERFACE)
8111 return gfc_match_end_interface ();
8112
8113 /* We haven't hit the end of statement, so what is left must be an
8114 end-name. */
8115 m = gfc_match_space ();
8116 if (m == MATCH_YES)
8117 m = gfc_match_name (name);
8118
8119 if (m == MATCH_NO)
8120 gfc_error ("Expected terminating name at %C");
8121 if (m != MATCH_YES)
8122 goto cleanup;
8123
8124 if (block_name == NULL)
8125 goto syntax;
8126
8127 /* We have to pick out the declared submodule name from the composite
8128 required by F2008:11.2.3 para 2, which ends in the declared name. */
8129 if (state == COMP_SUBMODULE)
8130 block_name = strchr (block_name, '.') + 1;
8131
8132 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
8133 {
8134 gfc_error ("Expected label %qs for %s statement at %C", block_name,
8135 gfc_ascii_statement (*st));
8136 goto cleanup;
8137 }
8138 /* Procedure pointer as function result. */
8139 else if (strcmp (block_name, "ppr@") == 0
8140 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
8141 {
8142 gfc_error ("Expected label %qs for %s statement at %C",
8143 gfc_current_block ()->ns->proc_name->name,
8144 gfc_ascii_statement (*st));
8145 goto cleanup;
8146 }
8147
8148 if (gfc_match_eos () == MATCH_YES)
8149 return MATCH_YES;
8150
8151 syntax:
8152 gfc_syntax_error (*st);
8153
8154 cleanup:
8155 gfc_current_locus = old_loc;
8156
8157 /* If we are missing an END BLOCK, we created a half-ready namespace.
8158 Remove it from the parent namespace's sibling list. */
8159
8160 while (state == COMP_BLOCK && !got_matching_end)
8161 {
8162 parent_ns = gfc_current_ns->parent;
8163
8164 nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
8165
8166 prev_ns = NULL;
8167 ns = *nsp;
8168 while (ns)
8169 {
8170 if (ns == gfc_current_ns)
8171 {
8172 if (prev_ns == NULL)
8173 *nsp = NULL;
8174 else
8175 prev_ns->sibling = ns->sibling;
8176 }
8177 prev_ns = ns;
8178 ns = ns->sibling;
8179 }
8180
8181 gfc_free_namespace (gfc_current_ns);
8182 gfc_current_ns = parent_ns;
8183 gfc_state_stack = gfc_state_stack->previous;
8184 state = gfc_current_state ();
8185 }
8186
8187 return MATCH_ERROR;
8188 }
8189
8190
8191
8192 /***************** Attribute declaration statements ****************/
8193
8194 /* Set the attribute of a single variable. */
8195
8196 static match
attr_decl1(void)8197 attr_decl1 (void)
8198 {
8199 char name[GFC_MAX_SYMBOL_LEN + 1];
8200 gfc_array_spec *as;
8201
8202 /* Workaround -Wmaybe-uninitialized false positive during
8203 profiledbootstrap by initializing them. */
8204 gfc_symbol *sym = NULL;
8205 locus var_locus;
8206 match m;
8207
8208 as = NULL;
8209
8210 m = gfc_match_name (name);
8211 if (m != MATCH_YES)
8212 goto cleanup;
8213
8214 if (find_special (name, &sym, false))
8215 return MATCH_ERROR;
8216
8217 if (!check_function_name (name))
8218 {
8219 m = MATCH_ERROR;
8220 goto cleanup;
8221 }
8222
8223 var_locus = gfc_current_locus;
8224
8225 /* Deal with possible array specification for certain attributes. */
8226 if (current_attr.dimension
8227 || current_attr.codimension
8228 || current_attr.allocatable
8229 || current_attr.pointer
8230 || current_attr.target)
8231 {
8232 m = gfc_match_array_spec (&as, !current_attr.codimension,
8233 !current_attr.dimension
8234 && !current_attr.pointer
8235 && !current_attr.target);
8236 if (m == MATCH_ERROR)
8237 goto cleanup;
8238
8239 if (current_attr.dimension && m == MATCH_NO)
8240 {
8241 gfc_error ("Missing array specification at %L in DIMENSION "
8242 "statement", &var_locus);
8243 m = MATCH_ERROR;
8244 goto cleanup;
8245 }
8246
8247 if (current_attr.dimension && sym->value)
8248 {
8249 gfc_error ("Dimensions specified for %s at %L after its "
8250 "initialization", sym->name, &var_locus);
8251 m = MATCH_ERROR;
8252 goto cleanup;
8253 }
8254
8255 if (current_attr.codimension && m == MATCH_NO)
8256 {
8257 gfc_error ("Missing array specification at %L in CODIMENSION "
8258 "statement", &var_locus);
8259 m = MATCH_ERROR;
8260 goto cleanup;
8261 }
8262
8263 if ((current_attr.allocatable || current_attr.pointer)
8264 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
8265 {
8266 gfc_error ("Array specification must be deferred at %L", &var_locus);
8267 m = MATCH_ERROR;
8268 goto cleanup;
8269 }
8270 }
8271
8272 /* Update symbol table. DIMENSION attribute is set in
8273 gfc_set_array_spec(). For CLASS variables, this must be applied
8274 to the first component, or '_data' field. */
8275 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
8276 {
8277 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus))
8278 {
8279 m = MATCH_ERROR;
8280 goto cleanup;
8281 }
8282 }
8283 else
8284 {
8285 if (current_attr.dimension == 0 && current_attr.codimension == 0
8286 && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
8287 {
8288 m = MATCH_ERROR;
8289 goto cleanup;
8290 }
8291 }
8292
8293 if (sym->ts.type == BT_CLASS
8294 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
8295 {
8296 m = MATCH_ERROR;
8297 goto cleanup;
8298 }
8299
8300 if (!gfc_set_array_spec (sym, as, &var_locus))
8301 {
8302 m = MATCH_ERROR;
8303 goto cleanup;
8304 }
8305
8306 if (sym->attr.cray_pointee && sym->as != NULL)
8307 {
8308 /* Fix the array spec. */
8309 m = gfc_mod_pointee_as (sym->as);
8310 if (m == MATCH_ERROR)
8311 goto cleanup;
8312 }
8313
8314 if (!gfc_add_attribute (&sym->attr, &var_locus))
8315 {
8316 m = MATCH_ERROR;
8317 goto cleanup;
8318 }
8319
8320 if ((current_attr.external || current_attr.intrinsic)
8321 && sym->attr.flavor != FL_PROCEDURE
8322 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
8323 {
8324 m = MATCH_ERROR;
8325 goto cleanup;
8326 }
8327
8328 add_hidden_procptr_result (sym);
8329
8330 return MATCH_YES;
8331
8332 cleanup:
8333 gfc_free_array_spec (as);
8334 return m;
8335 }
8336
8337
8338 /* Generic attribute declaration subroutine. Used for attributes that
8339 just have a list of names. */
8340
8341 static match
attr_decl(void)8342 attr_decl (void)
8343 {
8344 match m;
8345
8346 /* Gobble the optional double colon, by simply ignoring the result
8347 of gfc_match(). */
8348 gfc_match (" ::");
8349
8350 for (;;)
8351 {
8352 m = attr_decl1 ();
8353 if (m != MATCH_YES)
8354 break;
8355
8356 if (gfc_match_eos () == MATCH_YES)
8357 {
8358 m = MATCH_YES;
8359 break;
8360 }
8361
8362 if (gfc_match_char (',') != MATCH_YES)
8363 {
8364 gfc_error ("Unexpected character in variable list at %C");
8365 m = MATCH_ERROR;
8366 break;
8367 }
8368 }
8369
8370 return m;
8371 }
8372
8373
8374 /* This routine matches Cray Pointer declarations of the form:
8375 pointer ( <pointer>, <pointee> )
8376 or
8377 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8378 The pointer, if already declared, should be an integer. Otherwise, we
8379 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8380 be either a scalar, or an array declaration. No space is allocated for
8381 the pointee. For the statement
8382 pointer (ipt, ar(10))
8383 any subsequent uses of ar will be translated (in C-notation) as
8384 ar(i) => ((<type> *) ipt)(i)
8385 After gimplification, pointee variable will disappear in the code. */
8386
8387 static match
cray_pointer_decl(void)8388 cray_pointer_decl (void)
8389 {
8390 match m;
8391 gfc_array_spec *as = NULL;
8392 gfc_symbol *cptr; /* Pointer symbol. */
8393 gfc_symbol *cpte; /* Pointee symbol. */
8394 locus var_locus;
8395 bool done = false;
8396
8397 while (!done)
8398 {
8399 if (gfc_match_char ('(') != MATCH_YES)
8400 {
8401 gfc_error ("Expected %<(%> at %C");
8402 return MATCH_ERROR;
8403 }
8404
8405 /* Match pointer. */
8406 var_locus = gfc_current_locus;
8407 gfc_clear_attr (¤t_attr);
8408 gfc_add_cray_pointer (¤t_attr, &var_locus);
8409 current_ts.type = BT_INTEGER;
8410 current_ts.kind = gfc_index_integer_kind;
8411
8412 m = gfc_match_symbol (&cptr, 0);
8413 if (m != MATCH_YES)
8414 {
8415 gfc_error ("Expected variable name at %C");
8416 return m;
8417 }
8418
8419 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
8420 return MATCH_ERROR;
8421
8422 gfc_set_sym_referenced (cptr);
8423
8424 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
8425 {
8426 cptr->ts.type = BT_INTEGER;
8427 cptr->ts.kind = gfc_index_integer_kind;
8428 }
8429 else if (cptr->ts.type != BT_INTEGER)
8430 {
8431 gfc_error ("Cray pointer at %C must be an integer");
8432 return MATCH_ERROR;
8433 }
8434 else if (cptr->ts.kind < gfc_index_integer_kind)
8435 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8436 " memory addresses require %d bytes",
8437 cptr->ts.kind, gfc_index_integer_kind);
8438
8439 if (gfc_match_char (',') != MATCH_YES)
8440 {
8441 gfc_error ("Expected \",\" at %C");
8442 return MATCH_ERROR;
8443 }
8444
8445 /* Match Pointee. */
8446 var_locus = gfc_current_locus;
8447 gfc_clear_attr (¤t_attr);
8448 gfc_add_cray_pointee (¤t_attr, &var_locus);
8449 current_ts.type = BT_UNKNOWN;
8450 current_ts.kind = 0;
8451
8452 m = gfc_match_symbol (&cpte, 0);
8453 if (m != MATCH_YES)
8454 {
8455 gfc_error ("Expected variable name at %C");
8456 return m;
8457 }
8458
8459 /* Check for an optional array spec. */
8460 m = gfc_match_array_spec (&as, true, false);
8461 if (m == MATCH_ERROR)
8462 {
8463 gfc_free_array_spec (as);
8464 return m;
8465 }
8466 else if (m == MATCH_NO)
8467 {
8468 gfc_free_array_spec (as);
8469 as = NULL;
8470 }
8471
8472 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
8473 return MATCH_ERROR;
8474
8475 gfc_set_sym_referenced (cpte);
8476
8477 if (cpte->as == NULL)
8478 {
8479 if (!gfc_set_array_spec (cpte, as, &var_locus))
8480 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8481 }
8482 else if (as != NULL)
8483 {
8484 gfc_error ("Duplicate array spec for Cray pointee at %C");
8485 gfc_free_array_spec (as);
8486 return MATCH_ERROR;
8487 }
8488
8489 as = NULL;
8490
8491 if (cpte->as != NULL)
8492 {
8493 /* Fix array spec. */
8494 m = gfc_mod_pointee_as (cpte->as);
8495 if (m == MATCH_ERROR)
8496 return m;
8497 }
8498
8499 /* Point the Pointee at the Pointer. */
8500 cpte->cp_pointer = cptr;
8501
8502 if (gfc_match_char (')') != MATCH_YES)
8503 {
8504 gfc_error ("Expected \")\" at %C");
8505 return MATCH_ERROR;
8506 }
8507 m = gfc_match_char (',');
8508 if (m != MATCH_YES)
8509 done = true; /* Stop searching for more declarations. */
8510
8511 }
8512
8513 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
8514 || gfc_match_eos () != MATCH_YES)
8515 {
8516 gfc_error ("Expected %<,%> or end of statement at %C");
8517 return MATCH_ERROR;
8518 }
8519 return MATCH_YES;
8520 }
8521
8522
8523 match
gfc_match_external(void)8524 gfc_match_external (void)
8525 {
8526
8527 gfc_clear_attr (¤t_attr);
8528 current_attr.external = 1;
8529
8530 return attr_decl ();
8531 }
8532
8533
8534 match
gfc_match_intent(void)8535 gfc_match_intent (void)
8536 {
8537 sym_intent intent;
8538
8539 /* This is not allowed within a BLOCK construct! */
8540 if (gfc_current_state () == COMP_BLOCK)
8541 {
8542 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8543 return MATCH_ERROR;
8544 }
8545
8546 intent = match_intent_spec ();
8547 if (intent == INTENT_UNKNOWN)
8548 return MATCH_ERROR;
8549
8550 gfc_clear_attr (¤t_attr);
8551 current_attr.intent = intent;
8552
8553 return attr_decl ();
8554 }
8555
8556
8557 match
gfc_match_intrinsic(void)8558 gfc_match_intrinsic (void)
8559 {
8560
8561 gfc_clear_attr (¤t_attr);
8562 current_attr.intrinsic = 1;
8563
8564 return attr_decl ();
8565 }
8566
8567
8568 match
gfc_match_optional(void)8569 gfc_match_optional (void)
8570 {
8571 /* This is not allowed within a BLOCK construct! */
8572 if (gfc_current_state () == COMP_BLOCK)
8573 {
8574 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8575 return MATCH_ERROR;
8576 }
8577
8578 gfc_clear_attr (¤t_attr);
8579 current_attr.optional = 1;
8580
8581 return attr_decl ();
8582 }
8583
8584
8585 match
gfc_match_pointer(void)8586 gfc_match_pointer (void)
8587 {
8588 gfc_gobble_whitespace ();
8589 if (gfc_peek_ascii_char () == '(')
8590 {
8591 if (!flag_cray_pointer)
8592 {
8593 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8594 "flag");
8595 return MATCH_ERROR;
8596 }
8597 return cray_pointer_decl ();
8598 }
8599 else
8600 {
8601 gfc_clear_attr (¤t_attr);
8602 current_attr.pointer = 1;
8603
8604 return attr_decl ();
8605 }
8606 }
8607
8608
8609 match
gfc_match_allocatable(void)8610 gfc_match_allocatable (void)
8611 {
8612 gfc_clear_attr (¤t_attr);
8613 current_attr.allocatable = 1;
8614
8615 return attr_decl ();
8616 }
8617
8618
8619 match
gfc_match_codimension(void)8620 gfc_match_codimension (void)
8621 {
8622 gfc_clear_attr (¤t_attr);
8623 current_attr.codimension = 1;
8624
8625 return attr_decl ();
8626 }
8627
8628
8629 match
gfc_match_contiguous(void)8630 gfc_match_contiguous (void)
8631 {
8632 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
8633 return MATCH_ERROR;
8634
8635 gfc_clear_attr (¤t_attr);
8636 current_attr.contiguous = 1;
8637
8638 return attr_decl ();
8639 }
8640
8641
8642 match
gfc_match_dimension(void)8643 gfc_match_dimension (void)
8644 {
8645 gfc_clear_attr (¤t_attr);
8646 current_attr.dimension = 1;
8647
8648 return attr_decl ();
8649 }
8650
8651
8652 match
gfc_match_target(void)8653 gfc_match_target (void)
8654 {
8655 gfc_clear_attr (¤t_attr);
8656 current_attr.target = 1;
8657
8658 return attr_decl ();
8659 }
8660
8661
8662 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8663 statement. */
8664
8665 static match
access_attr_decl(gfc_statement st)8666 access_attr_decl (gfc_statement st)
8667 {
8668 char name[GFC_MAX_SYMBOL_LEN + 1];
8669 interface_type type;
8670 gfc_user_op *uop;
8671 gfc_symbol *sym, *dt_sym;
8672 gfc_intrinsic_op op;
8673 match m;
8674
8675 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8676 goto done;
8677
8678 for (;;)
8679 {
8680 m = gfc_match_generic_spec (&type, name, &op);
8681 if (m == MATCH_NO)
8682 goto syntax;
8683 if (m == MATCH_ERROR)
8684 return MATCH_ERROR;
8685
8686 switch (type)
8687 {
8688 case INTERFACE_NAMELESS:
8689 case INTERFACE_ABSTRACT:
8690 goto syntax;
8691
8692 case INTERFACE_GENERIC:
8693 case INTERFACE_DTIO:
8694
8695 if (gfc_get_symbol (name, NULL, &sym))
8696 goto done;
8697
8698 if (type == INTERFACE_DTIO
8699 && gfc_current_ns->proc_name
8700 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
8701 && sym->attr.flavor == FL_UNKNOWN)
8702 sym->attr.flavor = FL_PROCEDURE;
8703
8704 if (!gfc_add_access (&sym->attr,
8705 (st == ST_PUBLIC)
8706 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8707 sym->name, NULL))
8708 return MATCH_ERROR;
8709
8710 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
8711 && !gfc_add_access (&dt_sym->attr,
8712 (st == ST_PUBLIC)
8713 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8714 sym->name, NULL))
8715 return MATCH_ERROR;
8716
8717 break;
8718
8719 case INTERFACE_INTRINSIC_OP:
8720 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
8721 {
8722 gfc_intrinsic_op other_op;
8723
8724 gfc_current_ns->operator_access[op] =
8725 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8726
8727 /* Handle the case if there is another op with the same
8728 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8729 other_op = gfc_equivalent_op (op);
8730
8731 if (other_op != INTRINSIC_NONE)
8732 gfc_current_ns->operator_access[other_op] =
8733 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8734
8735 }
8736 else
8737 {
8738 gfc_error ("Access specification of the %s operator at %C has "
8739 "already been specified", gfc_op2string (op));
8740 goto done;
8741 }
8742
8743 break;
8744
8745 case INTERFACE_USER_OP:
8746 uop = gfc_get_uop (name);
8747
8748 if (uop->access == ACCESS_UNKNOWN)
8749 {
8750 uop->access = (st == ST_PUBLIC)
8751 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8752 }
8753 else
8754 {
8755 gfc_error ("Access specification of the .%s. operator at %C "
8756 "has already been specified", sym->name);
8757 goto done;
8758 }
8759
8760 break;
8761 }
8762
8763 if (gfc_match_char (',') == MATCH_NO)
8764 break;
8765 }
8766
8767 if (gfc_match_eos () != MATCH_YES)
8768 goto syntax;
8769 return MATCH_YES;
8770
8771 syntax:
8772 gfc_syntax_error (st);
8773
8774 done:
8775 return MATCH_ERROR;
8776 }
8777
8778
8779 match
gfc_match_protected(void)8780 gfc_match_protected (void)
8781 {
8782 gfc_symbol *sym;
8783 match m;
8784
8785 if (!gfc_current_ns->proc_name
8786 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
8787 {
8788 gfc_error ("PROTECTED at %C only allowed in specification "
8789 "part of a module");
8790 return MATCH_ERROR;
8791
8792 }
8793
8794 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
8795 return MATCH_ERROR;
8796
8797 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8798 {
8799 return MATCH_ERROR;
8800 }
8801
8802 if (gfc_match_eos () == MATCH_YES)
8803 goto syntax;
8804
8805 for(;;)
8806 {
8807 m = gfc_match_symbol (&sym, 0);
8808 switch (m)
8809 {
8810 case MATCH_YES:
8811 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
8812 return MATCH_ERROR;
8813 goto next_item;
8814
8815 case MATCH_NO:
8816 break;
8817
8818 case MATCH_ERROR:
8819 return MATCH_ERROR;
8820 }
8821
8822 next_item:
8823 if (gfc_match_eos () == MATCH_YES)
8824 break;
8825 if (gfc_match_char (',') != MATCH_YES)
8826 goto syntax;
8827 }
8828
8829 return MATCH_YES;
8830
8831 syntax:
8832 gfc_error ("Syntax error in PROTECTED statement at %C");
8833 return MATCH_ERROR;
8834 }
8835
8836
8837 /* The PRIVATE statement is a bit weird in that it can be an attribute
8838 declaration, but also works as a standalone statement inside of a
8839 type declaration or a module. */
8840
8841 match
gfc_match_private(gfc_statement * st)8842 gfc_match_private (gfc_statement *st)
8843 {
8844
8845 if (gfc_match ("private") != MATCH_YES)
8846 return MATCH_NO;
8847
8848 if (gfc_current_state () != COMP_MODULE
8849 && !(gfc_current_state () == COMP_DERIVED
8850 && gfc_state_stack->previous
8851 && gfc_state_stack->previous->state == COMP_MODULE)
8852 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8853 && gfc_state_stack->previous && gfc_state_stack->previous->previous
8854 && gfc_state_stack->previous->previous->state == COMP_MODULE))
8855 {
8856 gfc_error ("PRIVATE statement at %C is only allowed in the "
8857 "specification part of a module");
8858 return MATCH_ERROR;
8859 }
8860
8861 if (gfc_current_state () == COMP_DERIVED)
8862 {
8863 if (gfc_match_eos () == MATCH_YES)
8864 {
8865 *st = ST_PRIVATE;
8866 return MATCH_YES;
8867 }
8868
8869 gfc_syntax_error (ST_PRIVATE);
8870 return MATCH_ERROR;
8871 }
8872
8873 if (gfc_match_eos () == MATCH_YES)
8874 {
8875 *st = ST_PRIVATE;
8876 return MATCH_YES;
8877 }
8878
8879 *st = ST_ATTR_DECL;
8880 return access_attr_decl (ST_PRIVATE);
8881 }
8882
8883
8884 match
gfc_match_public(gfc_statement * st)8885 gfc_match_public (gfc_statement *st)
8886 {
8887
8888 if (gfc_match ("public") != MATCH_YES)
8889 return MATCH_NO;
8890
8891 if (gfc_current_state () != COMP_MODULE)
8892 {
8893 gfc_error ("PUBLIC statement at %C is only allowed in the "
8894 "specification part of a module");
8895 return MATCH_ERROR;
8896 }
8897
8898 if (gfc_match_eos () == MATCH_YES)
8899 {
8900 *st = ST_PUBLIC;
8901 return MATCH_YES;
8902 }
8903
8904 *st = ST_ATTR_DECL;
8905 return access_attr_decl (ST_PUBLIC);
8906 }
8907
8908
8909 /* Workhorse for gfc_match_parameter. */
8910
8911 static match
do_parm(void)8912 do_parm (void)
8913 {
8914 gfc_symbol *sym;
8915 gfc_expr *init;
8916 match m;
8917 bool t;
8918
8919 m = gfc_match_symbol (&sym, 0);
8920 if (m == MATCH_NO)
8921 gfc_error ("Expected variable name at %C in PARAMETER statement");
8922
8923 if (m != MATCH_YES)
8924 return m;
8925
8926 if (gfc_match_char ('=') == MATCH_NO)
8927 {
8928 gfc_error ("Expected = sign in PARAMETER statement at %C");
8929 return MATCH_ERROR;
8930 }
8931
8932 m = gfc_match_init_expr (&init);
8933 if (m == MATCH_NO)
8934 gfc_error ("Expected expression at %C in PARAMETER statement");
8935 if (m != MATCH_YES)
8936 return m;
8937
8938 if (sym->ts.type == BT_UNKNOWN
8939 && !gfc_set_default_type (sym, 1, NULL))
8940 {
8941 m = MATCH_ERROR;
8942 goto cleanup;
8943 }
8944
8945 if (!gfc_check_assign_symbol (sym, NULL, init)
8946 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
8947 {
8948 m = MATCH_ERROR;
8949 goto cleanup;
8950 }
8951
8952 if (sym->value)
8953 {
8954 gfc_error ("Initializing already initialized variable at %C");
8955 m = MATCH_ERROR;
8956 goto cleanup;
8957 }
8958
8959 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
8960 return (t) ? MATCH_YES : MATCH_ERROR;
8961
8962 cleanup:
8963 gfc_free_expr (init);
8964 return m;
8965 }
8966
8967
8968 /* Match a parameter statement, with the weird syntax that these have. */
8969
8970 match
gfc_match_parameter(void)8971 gfc_match_parameter (void)
8972 {
8973 const char *term = " )%t";
8974 match m;
8975
8976 if (gfc_match_char ('(') == MATCH_NO)
8977 {
8978 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8979 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
8980 return MATCH_NO;
8981 term = " %t";
8982 }
8983
8984 for (;;)
8985 {
8986 m = do_parm ();
8987 if (m != MATCH_YES)
8988 break;
8989
8990 if (gfc_match (term) == MATCH_YES)
8991 break;
8992
8993 if (gfc_match_char (',') != MATCH_YES)
8994 {
8995 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8996 m = MATCH_ERROR;
8997 break;
8998 }
8999 }
9000
9001 return m;
9002 }
9003
9004
9005 match
gfc_match_automatic(void)9006 gfc_match_automatic (void)
9007 {
9008 gfc_symbol *sym;
9009 match m;
9010 bool seen_symbol = false;
9011
9012 if (!flag_dec_static)
9013 {
9014 gfc_error ("%s at %C is a DEC extension, enable with "
9015 "%<-fdec-static%>",
9016 "AUTOMATIC"
9017 );
9018 return MATCH_ERROR;
9019 }
9020
9021 gfc_match (" ::");
9022
9023 for (;;)
9024 {
9025 m = gfc_match_symbol (&sym, 0);
9026 switch (m)
9027 {
9028 case MATCH_NO:
9029 break;
9030
9031 case MATCH_ERROR:
9032 return MATCH_ERROR;
9033
9034 case MATCH_YES:
9035 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
9036 return MATCH_ERROR;
9037 seen_symbol = true;
9038 break;
9039 }
9040
9041 if (gfc_match_eos () == MATCH_YES)
9042 break;
9043 if (gfc_match_char (',') != MATCH_YES)
9044 goto syntax;
9045 }
9046
9047 if (!seen_symbol)
9048 {
9049 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9050 return MATCH_ERROR;
9051 }
9052
9053 return MATCH_YES;
9054
9055 syntax:
9056 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9057 return MATCH_ERROR;
9058 }
9059
9060
9061 match
gfc_match_static(void)9062 gfc_match_static (void)
9063 {
9064 gfc_symbol *sym;
9065 match m;
9066 bool seen_symbol = false;
9067
9068 if (!flag_dec_static)
9069 {
9070 gfc_error ("%s at %C is a DEC extension, enable with "
9071 "%<-fdec-static%>",
9072 "STATIC");
9073 return MATCH_ERROR;
9074 }
9075
9076 gfc_match (" ::");
9077
9078 for (;;)
9079 {
9080 m = gfc_match_symbol (&sym, 0);
9081 switch (m)
9082 {
9083 case MATCH_NO:
9084 break;
9085
9086 case MATCH_ERROR:
9087 return MATCH_ERROR;
9088
9089 case MATCH_YES:
9090 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9091 &gfc_current_locus))
9092 return MATCH_ERROR;
9093 seen_symbol = true;
9094 break;
9095 }
9096
9097 if (gfc_match_eos () == MATCH_YES)
9098 break;
9099 if (gfc_match_char (',') != MATCH_YES)
9100 goto syntax;
9101 }
9102
9103 if (!seen_symbol)
9104 {
9105 gfc_error ("Expected entity-list in STATIC statement at %C");
9106 return MATCH_ERROR;
9107 }
9108
9109 return MATCH_YES;
9110
9111 syntax:
9112 gfc_error ("Syntax error in STATIC statement at %C");
9113 return MATCH_ERROR;
9114 }
9115
9116
9117 /* Save statements have a special syntax. */
9118
9119 match
gfc_match_save(void)9120 gfc_match_save (void)
9121 {
9122 char n[GFC_MAX_SYMBOL_LEN+1];
9123 gfc_common_head *c;
9124 gfc_symbol *sym;
9125 match m;
9126
9127 if (gfc_match_eos () == MATCH_YES)
9128 {
9129 if (gfc_current_ns->seen_save)
9130 {
9131 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
9132 "follows previous SAVE statement"))
9133 return MATCH_ERROR;
9134 }
9135
9136 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
9137 return MATCH_YES;
9138 }
9139
9140 if (gfc_current_ns->save_all)
9141 {
9142 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
9143 "blanket SAVE statement"))
9144 return MATCH_ERROR;
9145 }
9146
9147 gfc_match (" ::");
9148
9149 for (;;)
9150 {
9151 m = gfc_match_symbol (&sym, 0);
9152 switch (m)
9153 {
9154 case MATCH_YES:
9155 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9156 &gfc_current_locus))
9157 return MATCH_ERROR;
9158 goto next_item;
9159
9160 case MATCH_NO:
9161 break;
9162
9163 case MATCH_ERROR:
9164 return MATCH_ERROR;
9165 }
9166
9167 m = gfc_match (" / %n /", &n);
9168 if (m == MATCH_ERROR)
9169 return MATCH_ERROR;
9170 if (m == MATCH_NO)
9171 goto syntax;
9172
9173 c = gfc_get_common (n, 0);
9174 c->saved = 1;
9175
9176 gfc_current_ns->seen_save = 1;
9177
9178 next_item:
9179 if (gfc_match_eos () == MATCH_YES)
9180 break;
9181 if (gfc_match_char (',') != MATCH_YES)
9182 goto syntax;
9183 }
9184
9185 return MATCH_YES;
9186
9187 syntax:
9188 gfc_error ("Syntax error in SAVE statement at %C");
9189 return MATCH_ERROR;
9190 }
9191
9192
9193 match
gfc_match_value(void)9194 gfc_match_value (void)
9195 {
9196 gfc_symbol *sym;
9197 match m;
9198
9199 /* This is not allowed within a BLOCK construct! */
9200 if (gfc_current_state () == COMP_BLOCK)
9201 {
9202 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9203 return MATCH_ERROR;
9204 }
9205
9206 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
9207 return MATCH_ERROR;
9208
9209 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9210 {
9211 return MATCH_ERROR;
9212 }
9213
9214 if (gfc_match_eos () == MATCH_YES)
9215 goto syntax;
9216
9217 for(;;)
9218 {
9219 m = gfc_match_symbol (&sym, 0);
9220 switch (m)
9221 {
9222 case MATCH_YES:
9223 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
9224 return MATCH_ERROR;
9225 goto next_item;
9226
9227 case MATCH_NO:
9228 break;
9229
9230 case MATCH_ERROR:
9231 return MATCH_ERROR;
9232 }
9233
9234 next_item:
9235 if (gfc_match_eos () == MATCH_YES)
9236 break;
9237 if (gfc_match_char (',') != MATCH_YES)
9238 goto syntax;
9239 }
9240
9241 return MATCH_YES;
9242
9243 syntax:
9244 gfc_error ("Syntax error in VALUE statement at %C");
9245 return MATCH_ERROR;
9246 }
9247
9248
9249 match
gfc_match_volatile(void)9250 gfc_match_volatile (void)
9251 {
9252 gfc_symbol *sym;
9253 char *name;
9254 match m;
9255
9256 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
9257 return MATCH_ERROR;
9258
9259 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9260 {
9261 return MATCH_ERROR;
9262 }
9263
9264 if (gfc_match_eos () == MATCH_YES)
9265 goto syntax;
9266
9267 for(;;)
9268 {
9269 /* VOLATILE is special because it can be added to host-associated
9270 symbols locally. Except for coarrays. */
9271 m = gfc_match_symbol (&sym, 1);
9272 switch (m)
9273 {
9274 case MATCH_YES:
9275 name = XCNEWVAR (char, strlen (sym->name) + 1);
9276 strcpy (name, sym->name);
9277 if (!check_function_name (name))
9278 return MATCH_ERROR;
9279 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9280 for variable in a BLOCK which is defined outside of the BLOCK. */
9281 if (sym->ns != gfc_current_ns && sym->attr.codimension)
9282 {
9283 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9284 "%C, which is use-/host-associated", sym->name);
9285 return MATCH_ERROR;
9286 }
9287 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
9288 return MATCH_ERROR;
9289 goto next_item;
9290
9291 case MATCH_NO:
9292 break;
9293
9294 case MATCH_ERROR:
9295 return MATCH_ERROR;
9296 }
9297
9298 next_item:
9299 if (gfc_match_eos () == MATCH_YES)
9300 break;
9301 if (gfc_match_char (',') != MATCH_YES)
9302 goto syntax;
9303 }
9304
9305 return MATCH_YES;
9306
9307 syntax:
9308 gfc_error ("Syntax error in VOLATILE statement at %C");
9309 return MATCH_ERROR;
9310 }
9311
9312
9313 match
gfc_match_asynchronous(void)9314 gfc_match_asynchronous (void)
9315 {
9316 gfc_symbol *sym;
9317 char *name;
9318 match m;
9319
9320 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
9321 return MATCH_ERROR;
9322
9323 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9324 {
9325 return MATCH_ERROR;
9326 }
9327
9328 if (gfc_match_eos () == MATCH_YES)
9329 goto syntax;
9330
9331 for(;;)
9332 {
9333 /* ASYNCHRONOUS is special because it can be added to host-associated
9334 symbols locally. */
9335 m = gfc_match_symbol (&sym, 1);
9336 switch (m)
9337 {
9338 case MATCH_YES:
9339 name = XCNEWVAR (char, strlen (sym->name) + 1);
9340 strcpy (name, sym->name);
9341 if (!check_function_name (name))
9342 return MATCH_ERROR;
9343 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
9344 return MATCH_ERROR;
9345 goto next_item;
9346
9347 case MATCH_NO:
9348 break;
9349
9350 case MATCH_ERROR:
9351 return MATCH_ERROR;
9352 }
9353
9354 next_item:
9355 if (gfc_match_eos () == MATCH_YES)
9356 break;
9357 if (gfc_match_char (',') != MATCH_YES)
9358 goto syntax;
9359 }
9360
9361 return MATCH_YES;
9362
9363 syntax:
9364 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9365 return MATCH_ERROR;
9366 }
9367
9368
9369 /* Match a module procedure statement in a submodule. */
9370
9371 match
gfc_match_submod_proc(void)9372 gfc_match_submod_proc (void)
9373 {
9374 char name[GFC_MAX_SYMBOL_LEN + 1];
9375 gfc_symbol *sym, *fsym;
9376 match m;
9377 gfc_formal_arglist *formal, *head, *tail;
9378
9379 if (gfc_current_state () != COMP_CONTAINS
9380 || !(gfc_state_stack->previous
9381 && (gfc_state_stack->previous->state == COMP_SUBMODULE
9382 || gfc_state_stack->previous->state == COMP_MODULE)))
9383 return MATCH_NO;
9384
9385 m = gfc_match (" module% procedure% %n", name);
9386 if (m != MATCH_YES)
9387 return m;
9388
9389 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
9390 "at %C"))
9391 return MATCH_ERROR;
9392
9393 if (get_proc_name (name, &sym, false))
9394 return MATCH_ERROR;
9395
9396 /* Make sure that the result field is appropriately filled, even though
9397 the result symbol will be replaced later on. */
9398 if (sym->tlink && sym->tlink->attr.function)
9399 {
9400 if (sym->tlink->result
9401 && sym->tlink->result != sym->tlink)
9402 sym->result= sym->tlink->result;
9403 else
9404 sym->result = sym;
9405 }
9406
9407 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9408 the symbol existed before. */
9409 sym->declared_at = gfc_current_locus;
9410
9411 if (!sym->attr.module_procedure)
9412 return MATCH_ERROR;
9413
9414 /* Signal match_end to expect "end procedure". */
9415 sym->abr_modproc_decl = 1;
9416
9417 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9418 sym->attr.if_source = IFSRC_DECL;
9419
9420 gfc_new_block = sym;
9421
9422 /* Make a new formal arglist with the symbols in the procedure
9423 namespace. */
9424 head = tail = NULL;
9425 for (formal = sym->formal; formal && formal->sym; formal = formal->next)
9426 {
9427 if (formal == sym->formal)
9428 head = tail = gfc_get_formal_arglist ();
9429 else
9430 {
9431 tail->next = gfc_get_formal_arglist ();
9432 tail = tail->next;
9433 }
9434
9435 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
9436 goto cleanup;
9437
9438 tail->sym = fsym;
9439 gfc_set_sym_referenced (fsym);
9440 }
9441
9442 /* The dummy symbols get cleaned up, when the formal_namespace of the
9443 interface declaration is cleared. This allows us to add the
9444 explicit interface as is done for other type of procedure. */
9445 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
9446 &gfc_current_locus))
9447 return MATCH_ERROR;
9448
9449 if (gfc_match_eos () != MATCH_YES)
9450 {
9451 gfc_syntax_error (ST_MODULE_PROC);
9452 return MATCH_ERROR;
9453 }
9454
9455 return MATCH_YES;
9456
9457 cleanup:
9458 gfc_free_formal_arglist (head);
9459 return MATCH_ERROR;
9460 }
9461
9462
9463 /* Match a module procedure statement. Note that we have to modify
9464 symbols in the parent's namespace because the current one was there
9465 to receive symbols that are in an interface's formal argument list. */
9466
9467 match
gfc_match_modproc(void)9468 gfc_match_modproc (void)
9469 {
9470 char name[GFC_MAX_SYMBOL_LEN + 1];
9471 gfc_symbol *sym;
9472 match m;
9473 locus old_locus;
9474 gfc_namespace *module_ns;
9475 gfc_interface *old_interface_head, *interface;
9476
9477 if (gfc_state_stack->state != COMP_INTERFACE
9478 || gfc_state_stack->previous == NULL
9479 || current_interface.type == INTERFACE_NAMELESS
9480 || current_interface.type == INTERFACE_ABSTRACT)
9481 {
9482 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9483 "interface");
9484 return MATCH_ERROR;
9485 }
9486
9487 module_ns = gfc_current_ns->parent;
9488 for (; module_ns; module_ns = module_ns->parent)
9489 if (module_ns->proc_name->attr.flavor == FL_MODULE
9490 || module_ns->proc_name->attr.flavor == FL_PROGRAM
9491 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
9492 && !module_ns->proc_name->attr.contained))
9493 break;
9494
9495 if (module_ns == NULL)
9496 return MATCH_ERROR;
9497
9498 /* Store the current state of the interface. We will need it if we
9499 end up with a syntax error and need to recover. */
9500 old_interface_head = gfc_current_interface_head ();
9501
9502 /* Check if the F2008 optional double colon appears. */
9503 gfc_gobble_whitespace ();
9504 old_locus = gfc_current_locus;
9505 if (gfc_match ("::") == MATCH_YES)
9506 {
9507 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
9508 "MODULE PROCEDURE statement at %L", &old_locus))
9509 return MATCH_ERROR;
9510 }
9511 else
9512 gfc_current_locus = old_locus;
9513
9514 for (;;)
9515 {
9516 bool last = false;
9517 old_locus = gfc_current_locus;
9518
9519 m = gfc_match_name (name);
9520 if (m == MATCH_NO)
9521 goto syntax;
9522 if (m != MATCH_YES)
9523 return MATCH_ERROR;
9524
9525 /* Check for syntax error before starting to add symbols to the
9526 current namespace. */
9527 if (gfc_match_eos () == MATCH_YES)
9528 last = true;
9529
9530 if (!last && gfc_match_char (',') != MATCH_YES)
9531 goto syntax;
9532
9533 /* Now we're sure the syntax is valid, we process this item
9534 further. */
9535 if (gfc_get_symbol (name, module_ns, &sym))
9536 return MATCH_ERROR;
9537
9538 if (sym->attr.intrinsic)
9539 {
9540 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9541 "PROCEDURE", &old_locus);
9542 return MATCH_ERROR;
9543 }
9544
9545 if (sym->attr.proc != PROC_MODULE
9546 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
9547 return MATCH_ERROR;
9548
9549 if (!gfc_add_interface (sym))
9550 return MATCH_ERROR;
9551
9552 sym->attr.mod_proc = 1;
9553 sym->declared_at = old_locus;
9554
9555 if (last)
9556 break;
9557 }
9558
9559 return MATCH_YES;
9560
9561 syntax:
9562 /* Restore the previous state of the interface. */
9563 interface = gfc_current_interface_head ();
9564 gfc_set_current_interface_head (old_interface_head);
9565
9566 /* Free the new interfaces. */
9567 while (interface != old_interface_head)
9568 {
9569 gfc_interface *i = interface->next;
9570 free (interface);
9571 interface = i;
9572 }
9573
9574 /* And issue a syntax error. */
9575 gfc_syntax_error (ST_MODULE_PROC);
9576 return MATCH_ERROR;
9577 }
9578
9579
9580 /* Check a derived type that is being extended. */
9581
9582 static gfc_symbol*
check_extended_derived_type(char * name)9583 check_extended_derived_type (char *name)
9584 {
9585 gfc_symbol *extended;
9586
9587 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
9588 {
9589 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9590 return NULL;
9591 }
9592
9593 extended = gfc_find_dt_in_generic (extended);
9594
9595 /* F08:C428. */
9596 if (!extended)
9597 {
9598 gfc_error ("Symbol %qs at %C has not been previously defined", name);
9599 return NULL;
9600 }
9601
9602 if (extended->attr.flavor != FL_DERIVED)
9603 {
9604 gfc_error ("%qs in EXTENDS expression at %C is not a "
9605 "derived type", name);
9606 return NULL;
9607 }
9608
9609 if (extended->attr.is_bind_c)
9610 {
9611 gfc_error ("%qs cannot be extended at %C because it "
9612 "is BIND(C)", extended->name);
9613 return NULL;
9614 }
9615
9616 if (extended->attr.sequence)
9617 {
9618 gfc_error ("%qs cannot be extended at %C because it "
9619 "is a SEQUENCE type", extended->name);
9620 return NULL;
9621 }
9622
9623 return extended;
9624 }
9625
9626
9627 /* Match the optional attribute specifiers for a type declaration.
9628 Return MATCH_ERROR if an error is encountered in one of the handled
9629 attributes (public, private, bind(c)), MATCH_NO if what's found is
9630 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9631 checking on attribute conflicts needs to be done. */
9632
9633 match
gfc_get_type_attr_spec(symbol_attribute * attr,char * name)9634 gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
9635 {
9636 /* See if the derived type is marked as private. */
9637 if (gfc_match (" , private") == MATCH_YES)
9638 {
9639 if (gfc_current_state () != COMP_MODULE)
9640 {
9641 gfc_error ("Derived type at %C can only be PRIVATE in the "
9642 "specification part of a module");
9643 return MATCH_ERROR;
9644 }
9645
9646 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
9647 return MATCH_ERROR;
9648 }
9649 else if (gfc_match (" , public") == MATCH_YES)
9650 {
9651 if (gfc_current_state () != COMP_MODULE)
9652 {
9653 gfc_error ("Derived type at %C can only be PUBLIC in the "
9654 "specification part of a module");
9655 return MATCH_ERROR;
9656 }
9657
9658 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
9659 return MATCH_ERROR;
9660 }
9661 else if (gfc_match (" , bind ( c )") == MATCH_YES)
9662 {
9663 /* If the type is defined to be bind(c) it then needs to make
9664 sure that all fields are interoperable. This will
9665 need to be a semantic check on the finished derived type.
9666 See 15.2.3 (lines 9-12) of F2003 draft. */
9667 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
9668 return MATCH_ERROR;
9669
9670 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9671 }
9672 else if (gfc_match (" , abstract") == MATCH_YES)
9673 {
9674 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
9675 return MATCH_ERROR;
9676
9677 if (!gfc_add_abstract (attr, &gfc_current_locus))
9678 return MATCH_ERROR;
9679 }
9680 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
9681 {
9682 if (!gfc_add_extension (attr, &gfc_current_locus))
9683 return MATCH_ERROR;
9684 }
9685 else
9686 return MATCH_NO;
9687
9688 /* If we get here, something matched. */
9689 return MATCH_YES;
9690 }
9691
9692
9693 /* Common function for type declaration blocks similar to derived types, such
9694 as STRUCTURES and MAPs. Unlike derived types, a structure type
9695 does NOT have a generic symbol matching the name given by the user.
9696 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9697 for the creation of an independent symbol.
9698 Other parameters are a message to prefix errors with, the name of the new
9699 type to be created, and the flavor to add to the resulting symbol. */
9700
9701 static bool
get_struct_decl(const char * name,sym_flavor fl,locus * decl,gfc_symbol ** result)9702 get_struct_decl (const char *name, sym_flavor fl, locus *decl,
9703 gfc_symbol **result)
9704 {
9705 gfc_symbol *sym;
9706 locus where;
9707
9708 gcc_assert (name[0] == (char) TOUPPER (name[0]));
9709
9710 if (decl)
9711 where = *decl;
9712 else
9713 where = gfc_current_locus;
9714
9715 if (gfc_get_symbol (name, NULL, &sym))
9716 return false;
9717
9718 if (!sym)
9719 {
9720 gfc_internal_error ("Failed to create structure type '%s' at %C", name);
9721 return false;
9722 }
9723
9724 if (sym->components != NULL || sym->attr.zero_comp)
9725 {
9726 gfc_error ("Type definition of %qs at %C was already defined at %L",
9727 sym->name, &sym->declared_at);
9728 return false;
9729 }
9730
9731 sym->declared_at = where;
9732
9733 if (sym->attr.flavor != fl
9734 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
9735 return false;
9736
9737 if (!sym->hash_value)
9738 /* Set the hash for the compound name for this type. */
9739 sym->hash_value = gfc_hash_value (sym);
9740
9741 /* Normally the type is expected to have been completely parsed by the time
9742 a field declaration with this type is seen. For unions, maps, and nested
9743 structure declarations, we need to indicate that it is okay that we
9744 haven't seen any components yet. This will be updated after the structure
9745 is fully parsed. */
9746 sym->attr.zero_comp = 0;
9747
9748 /* Structures always act like derived-types with the SEQUENCE attribute */
9749 gfc_add_sequence (&sym->attr, sym->name, NULL);
9750
9751 if (result) *result = sym;
9752
9753 return true;
9754 }
9755
9756
9757 /* Match the opening of a MAP block. Like a struct within a union in C;
9758 behaves identical to STRUCTURE blocks. */
9759
9760 match
gfc_match_map(void)9761 gfc_match_map (void)
9762 {
9763 /* Counter used to give unique internal names to map structures. */
9764 static unsigned int gfc_map_id = 0;
9765 char name[GFC_MAX_SYMBOL_LEN + 1];
9766 gfc_symbol *sym;
9767 locus old_loc;
9768
9769 old_loc = gfc_current_locus;
9770
9771 if (gfc_match_eos () != MATCH_YES)
9772 {
9773 gfc_error ("Junk after MAP statement at %C");
9774 gfc_current_locus = old_loc;
9775 return MATCH_ERROR;
9776 }
9777
9778 /* Map blocks are anonymous so we make up unique names for the symbol table
9779 which are invalid Fortran identifiers. */
9780 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
9781
9782 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
9783 return MATCH_ERROR;
9784
9785 gfc_new_block = sym;
9786
9787 return MATCH_YES;
9788 }
9789
9790
9791 /* Match the opening of a UNION block. */
9792
9793 match
gfc_match_union(void)9794 gfc_match_union (void)
9795 {
9796 /* Counter used to give unique internal names to union types. */
9797 static unsigned int gfc_union_id = 0;
9798 char name[GFC_MAX_SYMBOL_LEN + 1];
9799 gfc_symbol *sym;
9800 locus old_loc;
9801
9802 old_loc = gfc_current_locus;
9803
9804 if (gfc_match_eos () != MATCH_YES)
9805 {
9806 gfc_error ("Junk after UNION statement at %C");
9807 gfc_current_locus = old_loc;
9808 return MATCH_ERROR;
9809 }
9810
9811 /* Unions are anonymous so we make up unique names for the symbol table
9812 which are invalid Fortran identifiers. */
9813 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
9814
9815 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
9816 return MATCH_ERROR;
9817
9818 gfc_new_block = sym;
9819
9820 return MATCH_YES;
9821 }
9822
9823
9824 /* Match the beginning of a STRUCTURE declaration. This is similar to
9825 matching the beginning of a derived type declaration with a few
9826 twists. The resulting type symbol has no access control or other
9827 interesting attributes. */
9828
9829 match
gfc_match_structure_decl(void)9830 gfc_match_structure_decl (void)
9831 {
9832 /* Counter used to give unique internal names to anonymous structures. */
9833 static unsigned int gfc_structure_id = 0;
9834 char name[GFC_MAX_SYMBOL_LEN + 1];
9835 gfc_symbol *sym;
9836 match m;
9837 locus where;
9838
9839 if (!flag_dec_structure)
9840 {
9841 gfc_error ("%s at %C is a DEC extension, enable with "
9842 "%<-fdec-structure%>",
9843 "STRUCTURE");
9844 return MATCH_ERROR;
9845 }
9846
9847 name[0] = '\0';
9848
9849 m = gfc_match (" /%n/", name);
9850 if (m != MATCH_YES)
9851 {
9852 /* Non-nested structure declarations require a structure name. */
9853 if (!gfc_comp_struct (gfc_current_state ()))
9854 {
9855 gfc_error ("Structure name expected in non-nested structure "
9856 "declaration at %C");
9857 return MATCH_ERROR;
9858 }
9859 /* This is an anonymous structure; make up a unique name for it
9860 (upper-case letters never make it to symbol names from the source).
9861 The important thing is initializing the type variable
9862 and setting gfc_new_symbol, which is immediately used by
9863 parse_structure () and variable_decl () to add components of
9864 this type. */
9865 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
9866 }
9867
9868 where = gfc_current_locus;
9869 /* No field list allowed after non-nested structure declaration. */
9870 if (!gfc_comp_struct (gfc_current_state ())
9871 && gfc_match_eos () != MATCH_YES)
9872 {
9873 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9874 return MATCH_ERROR;
9875 }
9876
9877 /* Make sure the name is not the name of an intrinsic type. */
9878 if (gfc_is_intrinsic_typename (name))
9879 {
9880 gfc_error ("Structure name %qs at %C cannot be the same as an"
9881 " intrinsic type", name);
9882 return MATCH_ERROR;
9883 }
9884
9885 /* Store the actual type symbol for the structure with an upper-case first
9886 letter (an invalid Fortran identifier). */
9887
9888 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
9889 return MATCH_ERROR;
9890
9891 gfc_new_block = sym;
9892 return MATCH_YES;
9893 }
9894
9895
9896 /* This function does some work to determine which matcher should be used to
9897 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9898 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9899 * and [parameterized] derived type declarations. */
9900
9901 match
gfc_match_type(gfc_statement * st)9902 gfc_match_type (gfc_statement *st)
9903 {
9904 char name[GFC_MAX_SYMBOL_LEN + 1];
9905 match m;
9906 locus old_loc;
9907
9908 /* Requires -fdec. */
9909 if (!flag_dec)
9910 return MATCH_NO;
9911
9912 m = gfc_match ("type");
9913 if (m != MATCH_YES)
9914 return m;
9915 /* If we already have an error in the buffer, it is probably from failing to
9916 * match a derived type data declaration. Let it happen. */
9917 else if (gfc_error_flag_test ())
9918 return MATCH_NO;
9919
9920 old_loc = gfc_current_locus;
9921 *st = ST_NONE;
9922
9923 /* If we see an attribute list before anything else it's definitely a derived
9924 * type declaration. */
9925 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
9926 goto derived;
9927
9928 /* By now "TYPE" has already been matched. If we do not see a name, this may
9929 * be something like "TYPE *" or "TYPE <fmt>". */
9930 m = gfc_match_name (name);
9931 if (m != MATCH_YES)
9932 {
9933 /* Let print match if it can, otherwise throw an error from
9934 * gfc_match_derived_decl. */
9935 gfc_current_locus = old_loc;
9936 if (gfc_match_print () == MATCH_YES)
9937 {
9938 *st = ST_WRITE;
9939 return MATCH_YES;
9940 }
9941 goto derived;
9942 }
9943
9944 /* Check for EOS. */
9945 if (gfc_match_eos () == MATCH_YES)
9946 {
9947 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9948 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9949 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9950 * symbol which can be printed. */
9951 gfc_current_locus = old_loc;
9952 m = gfc_match_derived_decl ();
9953 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
9954 {
9955 *st = ST_DERIVED_DECL;
9956 return m;
9957 }
9958 }
9959 else
9960 {
9961 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9962 like <type name(parameter)>. */
9963 gfc_gobble_whitespace ();
9964 bool paren = gfc_peek_ascii_char () == '(';
9965 if (paren)
9966 {
9967 if (strcmp ("is", name) == 0)
9968 goto typeis;
9969 else
9970 goto derived;
9971 }
9972 }
9973
9974 /* Treat TYPE... like PRINT... */
9975 gfc_current_locus = old_loc;
9976 *st = ST_WRITE;
9977 return gfc_match_print ();
9978
9979 derived:
9980 gfc_current_locus = old_loc;
9981 *st = ST_DERIVED_DECL;
9982 return gfc_match_derived_decl ();
9983
9984 typeis:
9985 gfc_current_locus = old_loc;
9986 *st = ST_TYPE_IS;
9987 return gfc_match_type_is ();
9988 }
9989
9990
9991 /* Match the beginning of a derived type declaration. If a type name
9992 was the result of a function, then it is possible to have a symbol
9993 already to be known as a derived type yet have no components. */
9994
9995 match
gfc_match_derived_decl(void)9996 gfc_match_derived_decl (void)
9997 {
9998 char name[GFC_MAX_SYMBOL_LEN + 1];
9999 char parent[GFC_MAX_SYMBOL_LEN + 1];
10000 symbol_attribute attr;
10001 gfc_symbol *sym, *gensym;
10002 gfc_symbol *extended;
10003 match m;
10004 match is_type_attr_spec = MATCH_NO;
10005 bool seen_attr = false;
10006 gfc_interface *intr = NULL, *head;
10007 bool parameterized_type = false;
10008 bool seen_colons = false;
10009
10010 if (gfc_comp_struct (gfc_current_state ()))
10011 return MATCH_NO;
10012
10013 name[0] = '\0';
10014 parent[0] = '\0';
10015 gfc_clear_attr (&attr);
10016 extended = NULL;
10017
10018 do
10019 {
10020 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
10021 if (is_type_attr_spec == MATCH_ERROR)
10022 return MATCH_ERROR;
10023 if (is_type_attr_spec == MATCH_YES)
10024 seen_attr = true;
10025 } while (is_type_attr_spec == MATCH_YES);
10026
10027 /* Deal with derived type extensions. The extension attribute has
10028 been added to 'attr' but now the parent type must be found and
10029 checked. */
10030 if (parent[0])
10031 extended = check_extended_derived_type (parent);
10032
10033 if (parent[0] && !extended)
10034 return MATCH_ERROR;
10035
10036 m = gfc_match (" ::");
10037 if (m == MATCH_YES)
10038 {
10039 seen_colons = true;
10040 }
10041 else if (seen_attr)
10042 {
10043 gfc_error ("Expected :: in TYPE definition at %C");
10044 return MATCH_ERROR;
10045 }
10046
10047 m = gfc_match (" %n ", name);
10048 if (m != MATCH_YES)
10049 return m;
10050
10051 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10052 derived type named 'is'.
10053 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10054 and checking if this is a(n intrinsic) typename. his picks up
10055 misplaced TYPE IS statements such as in select_type_1.f03. */
10056 if (gfc_peek_ascii_char () == '(')
10057 {
10058 if (gfc_current_state () == COMP_SELECT_TYPE
10059 || (!seen_colons && !strcmp (name, "is")))
10060 return MATCH_NO;
10061 parameterized_type = true;
10062 }
10063
10064 m = gfc_match_eos ();
10065 if (m != MATCH_YES && !parameterized_type)
10066 return m;
10067
10068 /* Make sure the name is not the name of an intrinsic type. */
10069 if (gfc_is_intrinsic_typename (name))
10070 {
10071 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10072 "type", name);
10073 return MATCH_ERROR;
10074 }
10075
10076 if (gfc_get_symbol (name, NULL, &gensym))
10077 return MATCH_ERROR;
10078
10079 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
10080 {
10081 if (gensym->ts.u.derived)
10082 gfc_error ("Derived type name %qs at %C already has a basic type "
10083 "of %s", gensym->name, gfc_typename (&gensym->ts));
10084 else
10085 gfc_error ("Derived type name %qs at %C already has a basic type",
10086 gensym->name);
10087 return MATCH_ERROR;
10088 }
10089
10090 if (!gensym->attr.generic
10091 && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
10092 return MATCH_ERROR;
10093
10094 if (!gensym->attr.function
10095 && !gfc_add_function (&gensym->attr, gensym->name, NULL))
10096 return MATCH_ERROR;
10097
10098 sym = gfc_find_dt_in_generic (gensym);
10099
10100 if (sym && (sym->components != NULL || sym->attr.zero_comp))
10101 {
10102 gfc_error ("Derived type definition of %qs at %C has already been "
10103 "defined", sym->name);
10104 return MATCH_ERROR;
10105 }
10106
10107 if (!sym)
10108 {
10109 /* Use upper case to save the actual derived-type symbol. */
10110 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
10111 sym->name = gfc_get_string ("%s", gensym->name);
10112 head = gensym->generic;
10113 intr = gfc_get_interface ();
10114 intr->sym = sym;
10115 intr->where = gfc_current_locus;
10116 intr->sym->declared_at = gfc_current_locus;
10117 intr->next = head;
10118 gensym->generic = intr;
10119 gensym->attr.if_source = IFSRC_DECL;
10120 }
10121
10122 /* The symbol may already have the derived attribute without the
10123 components. The ways this can happen is via a function
10124 definition, an INTRINSIC statement or a subtype in another
10125 derived type that is a pointer. The first part of the AND clause
10126 is true if the symbol is not the return value of a function. */
10127 if (sym->attr.flavor != FL_DERIVED
10128 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
10129 return MATCH_ERROR;
10130
10131 if (attr.access != ACCESS_UNKNOWN
10132 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
10133 return MATCH_ERROR;
10134 else if (sym->attr.access == ACCESS_UNKNOWN
10135 && gensym->attr.access != ACCESS_UNKNOWN
10136 && !gfc_add_access (&sym->attr, gensym->attr.access,
10137 sym->name, NULL))
10138 return MATCH_ERROR;
10139
10140 if (sym->attr.access != ACCESS_UNKNOWN
10141 && gensym->attr.access == ACCESS_UNKNOWN)
10142 gensym->attr.access = sym->attr.access;
10143
10144 /* See if the derived type was labeled as bind(c). */
10145 if (attr.is_bind_c != 0)
10146 sym->attr.is_bind_c = attr.is_bind_c;
10147
10148 /* Construct the f2k_derived namespace if it is not yet there. */
10149 if (!sym->f2k_derived)
10150 sym->f2k_derived = gfc_get_namespace (NULL, 0);
10151
10152 if (parameterized_type)
10153 {
10154 /* Ignore error or mismatches by going to the end of the statement
10155 in order to avoid the component declarations causing problems. */
10156 m = gfc_match_formal_arglist (sym, 0, 0, true);
10157 if (m != MATCH_YES)
10158 gfc_error_recovery ();
10159 m = gfc_match_eos ();
10160 if (m != MATCH_YES)
10161 {
10162 gfc_error_recovery ();
10163 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10164 }
10165 sym->attr.pdt_template = 1;
10166 }
10167
10168 if (extended && !sym->components)
10169 {
10170 gfc_component *p;
10171 gfc_formal_arglist *f, *g, *h;
10172
10173 /* Add the extended derived type as the first component. */
10174 gfc_add_component (sym, parent, &p);
10175 extended->refs++;
10176 gfc_set_sym_referenced (extended);
10177
10178 p->ts.type = BT_DERIVED;
10179 p->ts.u.derived = extended;
10180 p->initializer = gfc_default_initializer (&p->ts);
10181
10182 /* Set extension level. */
10183 if (extended->attr.extension == 255)
10184 {
10185 /* Since the extension field is 8 bit wide, we can only have
10186 up to 255 extension levels. */
10187 gfc_error ("Maximum extension level reached with type %qs at %L",
10188 extended->name, &extended->declared_at);
10189 return MATCH_ERROR;
10190 }
10191 sym->attr.extension = extended->attr.extension + 1;
10192
10193 /* Provide the links between the extended type and its extension. */
10194 if (!extended->f2k_derived)
10195 extended->f2k_derived = gfc_get_namespace (NULL, 0);
10196
10197 /* Copy the extended type-param-name-list from the extended type,
10198 append those of the extension and add the whole lot to the
10199 extension. */
10200 if (extended->attr.pdt_template)
10201 {
10202 g = h = NULL;
10203 sym->attr.pdt_template = 1;
10204 for (f = extended->formal; f; f = f->next)
10205 {
10206 if (f == extended->formal)
10207 {
10208 g = gfc_get_formal_arglist ();
10209 h = g;
10210 }
10211 else
10212 {
10213 g->next = gfc_get_formal_arglist ();
10214 g = g->next;
10215 }
10216 g->sym = f->sym;
10217 }
10218 g->next = sym->formal;
10219 sym->formal = h;
10220 }
10221 }
10222
10223 if (!sym->hash_value)
10224 /* Set the hash for the compound name for this type. */
10225 sym->hash_value = gfc_hash_value (sym);
10226
10227 /* Take over the ABSTRACT attribute. */
10228 sym->attr.abstract = attr.abstract;
10229
10230 gfc_new_block = sym;
10231
10232 return MATCH_YES;
10233 }
10234
10235
10236 /* Cray Pointees can be declared as:
10237 pointer (ipt, a (n,m,...,*)) */
10238
10239 match
gfc_mod_pointee_as(gfc_array_spec * as)10240 gfc_mod_pointee_as (gfc_array_spec *as)
10241 {
10242 as->cray_pointee = true; /* This will be useful to know later. */
10243 if (as->type == AS_ASSUMED_SIZE)
10244 as->cp_was_assumed = true;
10245 else if (as->type == AS_ASSUMED_SHAPE)
10246 {
10247 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10248 return MATCH_ERROR;
10249 }
10250 return MATCH_YES;
10251 }
10252
10253
10254 /* Match the enum definition statement, here we are trying to match
10255 the first line of enum definition statement.
10256 Returns MATCH_YES if match is found. */
10257
10258 match
gfc_match_enum(void)10259 gfc_match_enum (void)
10260 {
10261 match m;
10262
10263 m = gfc_match_eos ();
10264 if (m != MATCH_YES)
10265 return m;
10266
10267 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
10268 return MATCH_ERROR;
10269
10270 return MATCH_YES;
10271 }
10272
10273
10274 /* Returns an initializer whose value is one higher than the value of the
10275 LAST_INITIALIZER argument. If the argument is NULL, the
10276 initializers value will be set to zero. The initializer's kind
10277 will be set to gfc_c_int_kind.
10278
10279 If -fshort-enums is given, the appropriate kind will be selected
10280 later after all enumerators have been parsed. A warning is issued
10281 here if an initializer exceeds gfc_c_int_kind. */
10282
10283 static gfc_expr *
enum_initializer(gfc_expr * last_initializer,locus where)10284 enum_initializer (gfc_expr *last_initializer, locus where)
10285 {
10286 gfc_expr *result;
10287 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
10288
10289 mpz_init (result->value.integer);
10290
10291 if (last_initializer != NULL)
10292 {
10293 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
10294 result->where = last_initializer->where;
10295
10296 if (gfc_check_integer_range (result->value.integer,
10297 gfc_c_int_kind) != ARITH_OK)
10298 {
10299 gfc_error ("Enumerator exceeds the C integer type at %C");
10300 return NULL;
10301 }
10302 }
10303 else
10304 {
10305 /* Control comes here, if it's the very first enumerator and no
10306 initializer has been given. It will be initialized to zero. */
10307 mpz_set_si (result->value.integer, 0);
10308 }
10309
10310 return result;
10311 }
10312
10313
10314 /* Match a variable name with an optional initializer. When this
10315 subroutine is called, a variable is expected to be parsed next.
10316 Depending on what is happening at the moment, updates either the
10317 symbol table or the current interface. */
10318
10319 static match
enumerator_decl(void)10320 enumerator_decl (void)
10321 {
10322 char name[GFC_MAX_SYMBOL_LEN + 1];
10323 gfc_expr *initializer;
10324 gfc_array_spec *as = NULL;
10325 gfc_symbol *sym;
10326 locus var_locus;
10327 match m;
10328 bool t;
10329 locus old_locus;
10330
10331 initializer = NULL;
10332 old_locus = gfc_current_locus;
10333
10334 /* When we get here, we've just matched a list of attributes and
10335 maybe a type and a double colon. The next thing we expect to see
10336 is the name of the symbol. */
10337 m = gfc_match_name (name);
10338 if (m != MATCH_YES)
10339 goto cleanup;
10340
10341 var_locus = gfc_current_locus;
10342
10343 /* OK, we've successfully matched the declaration. Now put the
10344 symbol in the current namespace. If we fail to create the symbol,
10345 bail out. */
10346 if (!build_sym (name, NULL, false, &as, &var_locus))
10347 {
10348 m = MATCH_ERROR;
10349 goto cleanup;
10350 }
10351
10352 /* The double colon must be present in order to have initializers.
10353 Otherwise the statement is ambiguous with an assignment statement. */
10354 if (colon_seen)
10355 {
10356 if (gfc_match_char ('=') == MATCH_YES)
10357 {
10358 m = gfc_match_init_expr (&initializer);
10359 if (m == MATCH_NO)
10360 {
10361 gfc_error ("Expected an initialization expression at %C");
10362 m = MATCH_ERROR;
10363 }
10364
10365 if (m != MATCH_YES)
10366 goto cleanup;
10367 }
10368 }
10369
10370 /* If we do not have an initializer, the initialization value of the
10371 previous enumerator (stored in last_initializer) is incremented
10372 by 1 and is used to initialize the current enumerator. */
10373 if (initializer == NULL)
10374 initializer = enum_initializer (last_initializer, old_locus);
10375
10376 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
10377 {
10378 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10379 &var_locus);
10380 m = MATCH_ERROR;
10381 goto cleanup;
10382 }
10383
10384 /* Store this current initializer, for the next enumerator variable
10385 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10386 use last_initializer below. */
10387 last_initializer = initializer;
10388 t = add_init_expr_to_sym (name, &initializer, &var_locus);
10389
10390 /* Maintain enumerator history. */
10391 gfc_find_symbol (name, NULL, 0, &sym);
10392 create_enum_history (sym, last_initializer);
10393
10394 return (t) ? MATCH_YES : MATCH_ERROR;
10395
10396 cleanup:
10397 /* Free stuff up and return. */
10398 gfc_free_expr (initializer);
10399
10400 return m;
10401 }
10402
10403
10404 /* Match the enumerator definition statement. */
10405
10406 match
gfc_match_enumerator_def(void)10407 gfc_match_enumerator_def (void)
10408 {
10409 match m;
10410 bool t;
10411
10412 gfc_clear_ts (¤t_ts);
10413
10414 m = gfc_match (" enumerator");
10415 if (m != MATCH_YES)
10416 return m;
10417
10418 m = gfc_match (" :: ");
10419 if (m == MATCH_ERROR)
10420 return m;
10421
10422 colon_seen = (m == MATCH_YES);
10423
10424 if (gfc_current_state () != COMP_ENUM)
10425 {
10426 gfc_error ("ENUM definition statement expected before %C");
10427 gfc_free_enum_history ();
10428 return MATCH_ERROR;
10429 }
10430
10431 (¤t_ts)->type = BT_INTEGER;
10432 (¤t_ts)->kind = gfc_c_int_kind;
10433
10434 gfc_clear_attr (¤t_attr);
10435 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
10436 if (!t)
10437 {
10438 m = MATCH_ERROR;
10439 goto cleanup;
10440 }
10441
10442 for (;;)
10443 {
10444 m = enumerator_decl ();
10445 if (m == MATCH_ERROR)
10446 {
10447 gfc_free_enum_history ();
10448 goto cleanup;
10449 }
10450 if (m == MATCH_NO)
10451 break;
10452
10453 if (gfc_match_eos () == MATCH_YES)
10454 goto cleanup;
10455 if (gfc_match_char (',') != MATCH_YES)
10456 break;
10457 }
10458
10459 if (gfc_current_state () == COMP_ENUM)
10460 {
10461 gfc_free_enum_history ();
10462 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10463 m = MATCH_ERROR;
10464 }
10465
10466 cleanup:
10467 gfc_free_array_spec (current_as);
10468 current_as = NULL;
10469 return m;
10470
10471 }
10472
10473
10474 /* Match binding attributes. */
10475
10476 static match
match_binding_attributes(gfc_typebound_proc * ba,bool generic,bool ppc)10477 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
10478 {
10479 bool found_passing = false;
10480 bool seen_ptr = false;
10481 match m = MATCH_YES;
10482
10483 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10484 this case the defaults are in there. */
10485 ba->access = ACCESS_UNKNOWN;
10486 ba->pass_arg = NULL;
10487 ba->pass_arg_num = 0;
10488 ba->nopass = 0;
10489 ba->non_overridable = 0;
10490 ba->deferred = 0;
10491 ba->ppc = ppc;
10492
10493 /* If we find a comma, we believe there are binding attributes. */
10494 m = gfc_match_char (',');
10495 if (m == MATCH_NO)
10496 goto done;
10497
10498 do
10499 {
10500 /* Access specifier. */
10501
10502 m = gfc_match (" public");
10503 if (m == MATCH_ERROR)
10504 goto error;
10505 if (m == MATCH_YES)
10506 {
10507 if (ba->access != ACCESS_UNKNOWN)
10508 {
10509 gfc_error ("Duplicate access-specifier at %C");
10510 goto error;
10511 }
10512
10513 ba->access = ACCESS_PUBLIC;
10514 continue;
10515 }
10516
10517 m = gfc_match (" private");
10518 if (m == MATCH_ERROR)
10519 goto error;
10520 if (m == MATCH_YES)
10521 {
10522 if (ba->access != ACCESS_UNKNOWN)
10523 {
10524 gfc_error ("Duplicate access-specifier at %C");
10525 goto error;
10526 }
10527
10528 ba->access = ACCESS_PRIVATE;
10529 continue;
10530 }
10531
10532 /* If inside GENERIC, the following is not allowed. */
10533 if (!generic)
10534 {
10535
10536 /* NOPASS flag. */
10537 m = gfc_match (" nopass");
10538 if (m == MATCH_ERROR)
10539 goto error;
10540 if (m == MATCH_YES)
10541 {
10542 if (found_passing)
10543 {
10544 gfc_error ("Binding attributes already specify passing,"
10545 " illegal NOPASS at %C");
10546 goto error;
10547 }
10548
10549 found_passing = true;
10550 ba->nopass = 1;
10551 continue;
10552 }
10553
10554 /* PASS possibly including argument. */
10555 m = gfc_match (" pass");
10556 if (m == MATCH_ERROR)
10557 goto error;
10558 if (m == MATCH_YES)
10559 {
10560 char arg[GFC_MAX_SYMBOL_LEN + 1];
10561
10562 if (found_passing)
10563 {
10564 gfc_error ("Binding attributes already specify passing,"
10565 " illegal PASS at %C");
10566 goto error;
10567 }
10568
10569 m = gfc_match (" ( %n )", arg);
10570 if (m == MATCH_ERROR)
10571 goto error;
10572 if (m == MATCH_YES)
10573 ba->pass_arg = gfc_get_string ("%s", arg);
10574 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
10575
10576 found_passing = true;
10577 ba->nopass = 0;
10578 continue;
10579 }
10580
10581 if (ppc)
10582 {
10583 /* POINTER flag. */
10584 m = gfc_match (" pointer");
10585 if (m == MATCH_ERROR)
10586 goto error;
10587 if (m == MATCH_YES)
10588 {
10589 if (seen_ptr)
10590 {
10591 gfc_error ("Duplicate POINTER attribute at %C");
10592 goto error;
10593 }
10594
10595 seen_ptr = true;
10596 continue;
10597 }
10598 }
10599 else
10600 {
10601 /* NON_OVERRIDABLE flag. */
10602 m = gfc_match (" non_overridable");
10603 if (m == MATCH_ERROR)
10604 goto error;
10605 if (m == MATCH_YES)
10606 {
10607 if (ba->non_overridable)
10608 {
10609 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10610 goto error;
10611 }
10612
10613 ba->non_overridable = 1;
10614 continue;
10615 }
10616
10617 /* DEFERRED flag. */
10618 m = gfc_match (" deferred");
10619 if (m == MATCH_ERROR)
10620 goto error;
10621 if (m == MATCH_YES)
10622 {
10623 if (ba->deferred)
10624 {
10625 gfc_error ("Duplicate DEFERRED at %C");
10626 goto error;
10627 }
10628
10629 ba->deferred = 1;
10630 continue;
10631 }
10632 }
10633
10634 }
10635
10636 /* Nothing matching found. */
10637 if (generic)
10638 gfc_error ("Expected access-specifier at %C");
10639 else
10640 gfc_error ("Expected binding attribute at %C");
10641 goto error;
10642 }
10643 while (gfc_match_char (',') == MATCH_YES);
10644
10645 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10646 if (ba->non_overridable && ba->deferred)
10647 {
10648 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10649 goto error;
10650 }
10651
10652 m = MATCH_YES;
10653
10654 done:
10655 if (ba->access == ACCESS_UNKNOWN)
10656 ba->access = ppc ? gfc_current_block()->component_access
10657 : gfc_typebound_default_access;
10658
10659 if (ppc && !seen_ptr)
10660 {
10661 gfc_error ("POINTER attribute is required for procedure pointer component"
10662 " at %C");
10663 goto error;
10664 }
10665
10666 return m;
10667
10668 error:
10669 return MATCH_ERROR;
10670 }
10671
10672
10673 /* Match a PROCEDURE specific binding inside a derived type. */
10674
10675 static match
match_procedure_in_type(void)10676 match_procedure_in_type (void)
10677 {
10678 char name[GFC_MAX_SYMBOL_LEN + 1];
10679 char target_buf[GFC_MAX_SYMBOL_LEN + 1];
10680 char* target = NULL, *ifc = NULL;
10681 gfc_typebound_proc tb;
10682 bool seen_colons;
10683 bool seen_attrs;
10684 match m;
10685 gfc_symtree* stree;
10686 gfc_namespace* ns;
10687 gfc_symbol* block;
10688 int num;
10689
10690 /* Check current state. */
10691 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
10692 block = gfc_state_stack->previous->sym;
10693 gcc_assert (block);
10694
10695 /* Try to match PROCEDURE(interface). */
10696 if (gfc_match (" (") == MATCH_YES)
10697 {
10698 m = gfc_match_name (target_buf);
10699 if (m == MATCH_ERROR)
10700 return m;
10701 if (m != MATCH_YES)
10702 {
10703 gfc_error ("Interface-name expected after %<(%> at %C");
10704 return MATCH_ERROR;
10705 }
10706
10707 if (gfc_match (" )") != MATCH_YES)
10708 {
10709 gfc_error ("%<)%> expected at %C");
10710 return MATCH_ERROR;
10711 }
10712
10713 ifc = target_buf;
10714 }
10715
10716 /* Construct the data structure. */
10717 memset (&tb, 0, sizeof (tb));
10718 tb.where = gfc_current_locus;
10719
10720 /* Match binding attributes. */
10721 m = match_binding_attributes (&tb, false, false);
10722 if (m == MATCH_ERROR)
10723 return m;
10724 seen_attrs = (m == MATCH_YES);
10725
10726 /* Check that attribute DEFERRED is given if an interface is specified. */
10727 if (tb.deferred && !ifc)
10728 {
10729 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10730 return MATCH_ERROR;
10731 }
10732 if (ifc && !tb.deferred)
10733 {
10734 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10735 return MATCH_ERROR;
10736 }
10737
10738 /* Match the colons. */
10739 m = gfc_match (" ::");
10740 if (m == MATCH_ERROR)
10741 return m;
10742 seen_colons = (m == MATCH_YES);
10743 if (seen_attrs && !seen_colons)
10744 {
10745 gfc_error ("Expected %<::%> after binding-attributes at %C");
10746 return MATCH_ERROR;
10747 }
10748
10749 /* Match the binding names. */
10750 for(num=1;;num++)
10751 {
10752 m = gfc_match_name (name);
10753 if (m == MATCH_ERROR)
10754 return m;
10755 if (m == MATCH_NO)
10756 {
10757 gfc_error ("Expected binding name at %C");
10758 return MATCH_ERROR;
10759 }
10760
10761 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
10762 return MATCH_ERROR;
10763
10764 /* Try to match the '=> target', if it's there. */
10765 target = ifc;
10766 m = gfc_match (" =>");
10767 if (m == MATCH_ERROR)
10768 return m;
10769 if (m == MATCH_YES)
10770 {
10771 if (tb.deferred)
10772 {
10773 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10774 return MATCH_ERROR;
10775 }
10776
10777 if (!seen_colons)
10778 {
10779 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10780 " at %C");
10781 return MATCH_ERROR;
10782 }
10783
10784 m = gfc_match_name (target_buf);
10785 if (m == MATCH_ERROR)
10786 return m;
10787 if (m == MATCH_NO)
10788 {
10789 gfc_error ("Expected binding target after %<=>%> at %C");
10790 return MATCH_ERROR;
10791 }
10792 target = target_buf;
10793 }
10794
10795 /* If no target was found, it has the same name as the binding. */
10796 if (!target)
10797 target = name;
10798
10799 /* Get the namespace to insert the symbols into. */
10800 ns = block->f2k_derived;
10801 gcc_assert (ns);
10802
10803 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10804 if (tb.deferred && !block->attr.abstract)
10805 {
10806 gfc_error ("Type %qs containing DEFERRED binding at %C "
10807 "is not ABSTRACT", block->name);
10808 return MATCH_ERROR;
10809 }
10810
10811 /* See if we already have a binding with this name in the symtree which
10812 would be an error. If a GENERIC already targeted this binding, it may
10813 be already there but then typebound is still NULL. */
10814 stree = gfc_find_symtree (ns->tb_sym_root, name);
10815 if (stree && stree->n.tb)
10816 {
10817 gfc_error ("There is already a procedure with binding name %qs for "
10818 "the derived type %qs at %C", name, block->name);
10819 return MATCH_ERROR;
10820 }
10821
10822 /* Insert it and set attributes. */
10823
10824 if (!stree)
10825 {
10826 stree = gfc_new_symtree (&ns->tb_sym_root, name);
10827 gcc_assert (stree);
10828 }
10829 stree->n.tb = gfc_get_typebound_proc (&tb);
10830
10831 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
10832 false))
10833 return MATCH_ERROR;
10834 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
10835 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
10836 target, &stree->n.tb->u.specific->n.sym->declared_at);
10837
10838 if (gfc_match_eos () == MATCH_YES)
10839 return MATCH_YES;
10840 if (gfc_match_char (',') != MATCH_YES)
10841 goto syntax;
10842 }
10843
10844 syntax:
10845 gfc_error ("Syntax error in PROCEDURE statement at %C");
10846 return MATCH_ERROR;
10847 }
10848
10849
10850 /* Match a GENERIC procedure binding inside a derived type. */
10851
10852 match
gfc_match_generic(void)10853 gfc_match_generic (void)
10854 {
10855 char name[GFC_MAX_SYMBOL_LEN + 1];
10856 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
10857 gfc_symbol* block;
10858 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
10859 gfc_typebound_proc* tb;
10860 gfc_namespace* ns;
10861 interface_type op_type;
10862 gfc_intrinsic_op op;
10863 match m;
10864
10865 /* Check current state. */
10866 if (gfc_current_state () == COMP_DERIVED)
10867 {
10868 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10869 return MATCH_ERROR;
10870 }
10871 if (gfc_current_state () != COMP_DERIVED_CONTAINS)
10872 return MATCH_NO;
10873 block = gfc_state_stack->previous->sym;
10874 ns = block->f2k_derived;
10875 gcc_assert (block && ns);
10876
10877 memset (&tbattr, 0, sizeof (tbattr));
10878 tbattr.where = gfc_current_locus;
10879
10880 /* See if we get an access-specifier. */
10881 m = match_binding_attributes (&tbattr, true, false);
10882 if (m == MATCH_ERROR)
10883 goto error;
10884
10885 /* Now the colons, those are required. */
10886 if (gfc_match (" ::") != MATCH_YES)
10887 {
10888 gfc_error ("Expected %<::%> at %C");
10889 goto error;
10890 }
10891
10892 /* Match the binding name; depending on type (operator / generic) format
10893 it for future error messages into bind_name. */
10894
10895 m = gfc_match_generic_spec (&op_type, name, &op);
10896 if (m == MATCH_ERROR)
10897 return MATCH_ERROR;
10898 if (m == MATCH_NO)
10899 {
10900 gfc_error ("Expected generic name or operator descriptor at %C");
10901 goto error;
10902 }
10903
10904 switch (op_type)
10905 {
10906 case INTERFACE_GENERIC:
10907 case INTERFACE_DTIO:
10908 snprintf (bind_name, sizeof (bind_name), "%s", name);
10909 break;
10910
10911 case INTERFACE_USER_OP:
10912 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
10913 break;
10914
10915 case INTERFACE_INTRINSIC_OP:
10916 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
10917 gfc_op2string (op));
10918 break;
10919
10920 case INTERFACE_NAMELESS:
10921 gfc_error ("Malformed GENERIC statement at %C");
10922 goto error;
10923 break;
10924
10925 default:
10926 gcc_unreachable ();
10927 }
10928
10929 /* Match the required =>. */
10930 if (gfc_match (" =>") != MATCH_YES)
10931 {
10932 gfc_error ("Expected %<=>%> at %C");
10933 goto error;
10934 }
10935
10936 /* Try to find existing GENERIC binding with this name / for this operator;
10937 if there is something, check that it is another GENERIC and then extend
10938 it rather than building a new node. Otherwise, create it and put it
10939 at the right position. */
10940
10941 switch (op_type)
10942 {
10943 case INTERFACE_DTIO:
10944 case INTERFACE_USER_OP:
10945 case INTERFACE_GENERIC:
10946 {
10947 const bool is_op = (op_type == INTERFACE_USER_OP);
10948 gfc_symtree* st;
10949
10950 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
10951 tb = st ? st->n.tb : NULL;
10952 break;
10953 }
10954
10955 case INTERFACE_INTRINSIC_OP:
10956 tb = ns->tb_op[op];
10957 break;
10958
10959 default:
10960 gcc_unreachable ();
10961 }
10962
10963 if (tb)
10964 {
10965 if (!tb->is_generic)
10966 {
10967 gcc_assert (op_type == INTERFACE_GENERIC);
10968 gfc_error ("There's already a non-generic procedure with binding name"
10969 " %qs for the derived type %qs at %C",
10970 bind_name, block->name);
10971 goto error;
10972 }
10973
10974 if (tb->access != tbattr.access)
10975 {
10976 gfc_error ("Binding at %C must have the same access as already"
10977 " defined binding %qs", bind_name);
10978 goto error;
10979 }
10980 }
10981 else
10982 {
10983 tb = gfc_get_typebound_proc (NULL);
10984 tb->where = gfc_current_locus;
10985 tb->access = tbattr.access;
10986 tb->is_generic = 1;
10987 tb->u.generic = NULL;
10988
10989 switch (op_type)
10990 {
10991 case INTERFACE_DTIO:
10992 case INTERFACE_GENERIC:
10993 case INTERFACE_USER_OP:
10994 {
10995 const bool is_op = (op_type == INTERFACE_USER_OP);
10996 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
10997 &ns->tb_sym_root, name);
10998 gcc_assert (st);
10999 st->n.tb = tb;
11000
11001 break;
11002 }
11003
11004 case INTERFACE_INTRINSIC_OP:
11005 ns->tb_op[op] = tb;
11006 break;
11007
11008 default:
11009 gcc_unreachable ();
11010 }
11011 }
11012
11013 /* Now, match all following names as specific targets. */
11014 do
11015 {
11016 gfc_symtree* target_st;
11017 gfc_tbp_generic* target;
11018
11019 m = gfc_match_name (name);
11020 if (m == MATCH_ERROR)
11021 goto error;
11022 if (m == MATCH_NO)
11023 {
11024 gfc_error ("Expected specific binding name at %C");
11025 goto error;
11026 }
11027
11028 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
11029
11030 /* See if this is a duplicate specification. */
11031 for (target = tb->u.generic; target; target = target->next)
11032 if (target_st == target->specific_st)
11033 {
11034 gfc_error ("%qs already defined as specific binding for the"
11035 " generic %qs at %C", name, bind_name);
11036 goto error;
11037 }
11038
11039 target = gfc_get_tbp_generic ();
11040 target->specific_st = target_st;
11041 target->specific = NULL;
11042 target->next = tb->u.generic;
11043 target->is_operator = ((op_type == INTERFACE_USER_OP)
11044 || (op_type == INTERFACE_INTRINSIC_OP));
11045 tb->u.generic = target;
11046 }
11047 while (gfc_match (" ,") == MATCH_YES);
11048
11049 /* Here should be the end. */
11050 if (gfc_match_eos () != MATCH_YES)
11051 {
11052 gfc_error ("Junk after GENERIC binding at %C");
11053 goto error;
11054 }
11055
11056 return MATCH_YES;
11057
11058 error:
11059 return MATCH_ERROR;
11060 }
11061
11062
11063 /* Match a FINAL declaration inside a derived type. */
11064
11065 match
gfc_match_final_decl(void)11066 gfc_match_final_decl (void)
11067 {
11068 char name[GFC_MAX_SYMBOL_LEN + 1];
11069 gfc_symbol* sym;
11070 match m;
11071 gfc_namespace* module_ns;
11072 bool first, last;
11073 gfc_symbol* block;
11074
11075 if (gfc_current_form == FORM_FREE)
11076 {
11077 char c = gfc_peek_ascii_char ();
11078 if (!gfc_is_whitespace (c) && c != ':')
11079 return MATCH_NO;
11080 }
11081
11082 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
11083 {
11084 if (gfc_current_form == FORM_FIXED)
11085 return MATCH_NO;
11086
11087 gfc_error ("FINAL declaration at %C must be inside a derived type "
11088 "CONTAINS section");
11089 return MATCH_ERROR;
11090 }
11091
11092 block = gfc_state_stack->previous->sym;
11093 gcc_assert (block);
11094
11095 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
11096 || gfc_state_stack->previous->previous->state != COMP_MODULE)
11097 {
11098 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11099 " specification part of a MODULE");
11100 return MATCH_ERROR;
11101 }
11102
11103 module_ns = gfc_current_ns;
11104 gcc_assert (module_ns);
11105 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
11106
11107 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11108 if (gfc_match (" ::") == MATCH_ERROR)
11109 return MATCH_ERROR;
11110
11111 /* Match the sequence of procedure names. */
11112 first = true;
11113 last = false;
11114 do
11115 {
11116 gfc_finalizer* f;
11117
11118 if (first && gfc_match_eos () == MATCH_YES)
11119 {
11120 gfc_error ("Empty FINAL at %C");
11121 return MATCH_ERROR;
11122 }
11123
11124 m = gfc_match_name (name);
11125 if (m == MATCH_NO)
11126 {
11127 gfc_error ("Expected module procedure name at %C");
11128 return MATCH_ERROR;
11129 }
11130 else if (m != MATCH_YES)
11131 return MATCH_ERROR;
11132
11133 if (gfc_match_eos () == MATCH_YES)
11134 last = true;
11135 if (!last && gfc_match_char (',') != MATCH_YES)
11136 {
11137 gfc_error ("Expected %<,%> at %C");
11138 return MATCH_ERROR;
11139 }
11140
11141 if (gfc_get_symbol (name, module_ns, &sym))
11142 {
11143 gfc_error ("Unknown procedure name %qs at %C", name);
11144 return MATCH_ERROR;
11145 }
11146
11147 /* Mark the symbol as module procedure. */
11148 if (sym->attr.proc != PROC_MODULE
11149 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
11150 return MATCH_ERROR;
11151
11152 /* Check if we already have this symbol in the list, this is an error. */
11153 for (f = block->f2k_derived->finalizers; f; f = f->next)
11154 if (f->proc_sym == sym)
11155 {
11156 gfc_error ("%qs at %C is already defined as FINAL procedure",
11157 name);
11158 return MATCH_ERROR;
11159 }
11160
11161 /* Add this symbol to the list of finalizers. */
11162 gcc_assert (block->f2k_derived);
11163 sym->refs++;
11164 f = XCNEW (gfc_finalizer);
11165 f->proc_sym = sym;
11166 f->proc_tree = NULL;
11167 f->where = gfc_current_locus;
11168 f->next = block->f2k_derived->finalizers;
11169 block->f2k_derived->finalizers = f;
11170
11171 first = false;
11172 }
11173 while (!last);
11174
11175 return MATCH_YES;
11176 }
11177
11178
11179 const ext_attr_t ext_attr_list[] = {
11180 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
11181 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
11182 { "cdecl", EXT_ATTR_CDECL, "cdecl" },
11183 { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
11184 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
11185 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
11186 { NULL, EXT_ATTR_LAST, NULL }
11187 };
11188
11189 /* Match a !GCC$ ATTRIBUTES statement of the form:
11190 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11191 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11192
11193 TODO: We should support all GCC attributes using the same syntax for
11194 the attribute list, i.e. the list in C
11195 __attributes(( attribute-list ))
11196 matches then
11197 !GCC$ ATTRIBUTES attribute-list ::
11198 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11199 saved into a TREE.
11200
11201 As there is absolutely no risk of confusion, we should never return
11202 MATCH_NO. */
11203 match
gfc_match_gcc_attributes(void)11204 gfc_match_gcc_attributes (void)
11205 {
11206 symbol_attribute attr;
11207 char name[GFC_MAX_SYMBOL_LEN + 1];
11208 unsigned id;
11209 gfc_symbol *sym;
11210 match m;
11211
11212 gfc_clear_attr (&attr);
11213 for(;;)
11214 {
11215 char ch;
11216
11217 if (gfc_match_name (name) != MATCH_YES)
11218 return MATCH_ERROR;
11219
11220 for (id = 0; id < EXT_ATTR_LAST; id++)
11221 if (strcmp (name, ext_attr_list[id].name) == 0)
11222 break;
11223
11224 if (id == EXT_ATTR_LAST)
11225 {
11226 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11227 return MATCH_ERROR;
11228 }
11229
11230 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
11231 return MATCH_ERROR;
11232
11233 gfc_gobble_whitespace ();
11234 ch = gfc_next_ascii_char ();
11235 if (ch == ':')
11236 {
11237 /* This is the successful exit condition for the loop. */
11238 if (gfc_next_ascii_char () == ':')
11239 break;
11240 }
11241
11242 if (ch == ',')
11243 continue;
11244
11245 goto syntax;
11246 }
11247
11248 if (gfc_match_eos () == MATCH_YES)
11249 goto syntax;
11250
11251 for(;;)
11252 {
11253 m = gfc_match_name (name);
11254 if (m != MATCH_YES)
11255 return m;
11256
11257 if (find_special (name, &sym, true))
11258 return MATCH_ERROR;
11259
11260 sym->attr.ext_attr |= attr.ext_attr;
11261
11262 if (gfc_match_eos () == MATCH_YES)
11263 break;
11264
11265 if (gfc_match_char (',') != MATCH_YES)
11266 goto syntax;
11267 }
11268
11269 return MATCH_YES;
11270
11271 syntax:
11272 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11273 return MATCH_ERROR;
11274 }
11275
11276
11277 /* Match a !GCC$ UNROLL statement of the form:
11278 !GCC$ UNROLL n
11279
11280 The parameter n is the number of times we are supposed to unroll.
11281
11282 When we come here, we have already matched the !GCC$ UNROLL string. */
11283 match
gfc_match_gcc_unroll(void)11284 gfc_match_gcc_unroll (void)
11285 {
11286 int value;
11287
11288 if (gfc_match_small_int (&value) == MATCH_YES)
11289 {
11290 if (value < 0 || value > USHRT_MAX)
11291 {
11292 gfc_error ("%<GCC unroll%> directive requires a"
11293 " non-negative integral constant"
11294 " less than or equal to %u at %C",
11295 USHRT_MAX
11296 );
11297 return MATCH_ERROR;
11298 }
11299 if (gfc_match_eos () == MATCH_YES)
11300 {
11301 directive_unroll = value == 0 ? 1 : value;
11302 return MATCH_YES;
11303 }
11304 }
11305
11306 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11307 return MATCH_ERROR;
11308 }
11309