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_comp_struct (gfc_current_state ())
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 bool is_derived = gfc_current_state () == COMP_DERIVED;
5245 if (d == DECL_ALLOCATABLE)
5246 {
5247 if (!gfc_notify_std (GFC_STD_F2003, is_derived
5248 ? G_("ALLOCATABLE attribute at %C in a "
5249 "TYPE definition")
5250 : G_("ALLOCATABLE attribute at %C in a "
5251 "STRUCTURE definition")))
5252 {
5253 m = MATCH_ERROR;
5254 goto cleanup;
5255 }
5256 }
5257 else if (d == DECL_KIND)
5258 {
5259 if (!gfc_notify_std (GFC_STD_F2003, is_derived
5260 ? G_("KIND attribute at %C in a "
5261 "TYPE definition")
5262 : G_("KIND attribute at %C in a "
5263 "STRUCTURE definition")))
5264 {
5265 m = MATCH_ERROR;
5266 goto cleanup;
5267 }
5268 if (current_ts.type != BT_INTEGER)
5269 {
5270 gfc_error ("Component with KIND attribute at %C must be "
5271 "INTEGER");
5272 m = MATCH_ERROR;
5273 goto cleanup;
5274 }
5275 if (current_ts.kind != gfc_default_integer_kind)
5276 {
5277 gfc_error ("Component with KIND attribute at %C must be "
5278 "default integer kind (%d)",
5279 gfc_default_integer_kind);
5280 m = MATCH_ERROR;
5281 goto cleanup;
5282 }
5283 }
5284 else if (d == DECL_LEN)
5285 {
5286 if (!gfc_notify_std (GFC_STD_F2003, is_derived
5287 ? G_("LEN attribute at %C in a "
5288 "TYPE definition")
5289 : G_("LEN attribute at %C in a "
5290 "STRUCTURE definition")))
5291 {
5292 m = MATCH_ERROR;
5293 goto cleanup;
5294 }
5295 if (current_ts.type != BT_INTEGER)
5296 {
5297 gfc_error ("Component with LEN attribute at %C must be "
5298 "INTEGER");
5299 m = MATCH_ERROR;
5300 goto cleanup;
5301 }
5302 if (current_ts.kind != gfc_default_integer_kind)
5303 {
5304 gfc_error ("Component with LEN attribute at %C must be "
5305 "default integer kind (%d)",
5306 gfc_default_integer_kind);
5307 m = MATCH_ERROR;
5308 goto cleanup;
5309 }
5310 }
5311 else
5312 {
5313 gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
5314 "TYPE definition")
5315 : G_("Attribute at %L is not allowed in a "
5316 "STRUCTURE definition"), &seen_at[d]);
5317 m = MATCH_ERROR;
5318 goto cleanup;
5319 }
5320 }
5321
5322 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5323 && gfc_current_state () != COMP_MODULE)
5324 {
5325 if (d == DECL_PRIVATE)
5326 attr = "PRIVATE";
5327 else
5328 attr = "PUBLIC";
5329 if (gfc_current_state () == COMP_DERIVED
5330 && gfc_state_stack->previous
5331 && gfc_state_stack->previous->state == COMP_MODULE)
5332 {
5333 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5334 "at %L in a TYPE definition", attr,
5335 &seen_at[d]))
5336 {
5337 m = MATCH_ERROR;
5338 goto cleanup;
5339 }
5340 }
5341 else
5342 {
5343 gfc_error ("%s attribute at %L is not allowed outside of the "
5344 "specification part of a module", attr, &seen_at[d]);
5345 m = MATCH_ERROR;
5346 goto cleanup;
5347 }
5348 }
5349
5350 if (gfc_current_state () != COMP_DERIVED
5351 && (d == DECL_KIND || d == DECL_LEN))
5352 {
5353 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5354 "definition", &seen_at[d]);
5355 m = MATCH_ERROR;
5356 goto cleanup;
5357 }
5358
5359 switch (d)
5360 {
5361 case DECL_ALLOCATABLE:
5362 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
5363 break;
5364
5365 case DECL_ASYNCHRONOUS:
5366 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5367 t = false;
5368 else
5369 t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
5370 break;
5371
5372 case DECL_CODIMENSION:
5373 t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
5374 break;
5375
5376 case DECL_CONTIGUOUS:
5377 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5378 t = false;
5379 else
5380 t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
5381 break;
5382
5383 case DECL_DIMENSION:
5384 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
5385 break;
5386
5387 case DECL_EXTERNAL:
5388 t = gfc_add_external (¤t_attr, &seen_at[d]);
5389 break;
5390
5391 case DECL_IN:
5392 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
5393 break;
5394
5395 case DECL_OUT:
5396 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
5397 break;
5398
5399 case DECL_INOUT:
5400 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
5401 break;
5402
5403 case DECL_INTRINSIC:
5404 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
5405 break;
5406
5407 case DECL_OPTIONAL:
5408 t = gfc_add_optional (¤t_attr, &seen_at[d]);
5409 break;
5410
5411 case DECL_KIND:
5412 t = gfc_add_kind (¤t_attr, &seen_at[d]);
5413 break;
5414
5415 case DECL_LEN:
5416 t = gfc_add_len (¤t_attr, &seen_at[d]);
5417 break;
5418
5419 case DECL_PARAMETER:
5420 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
5421 break;
5422
5423 case DECL_POINTER:
5424 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
5425 break;
5426
5427 case DECL_PROTECTED:
5428 if (gfc_current_state () != COMP_MODULE
5429 || (gfc_current_ns->proc_name
5430 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5431 {
5432 gfc_error ("PROTECTED at %C only allowed in specification "
5433 "part of a module");
5434 t = false;
5435 break;
5436 }
5437
5438 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5439 t = false;
5440 else
5441 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
5442 break;
5443
5444 case DECL_PRIVATE:
5445 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
5446 &seen_at[d]);
5447 break;
5448
5449 case DECL_PUBLIC:
5450 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
5451 &seen_at[d]);
5452 break;
5453
5454 case DECL_STATIC:
5455 case DECL_SAVE:
5456 t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5457 break;
5458
5459 case DECL_AUTOMATIC:
5460 t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
5461 break;
5462
5463 case DECL_TARGET:
5464 t = gfc_add_target (¤t_attr, &seen_at[d]);
5465 break;
5466
5467 case DECL_IS_BIND_C:
5468 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
5469 break;
5470
5471 case DECL_VALUE:
5472 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5473 t = false;
5474 else
5475 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
5476 break;
5477
5478 case DECL_VOLATILE:
5479 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5480 t = false;
5481 else
5482 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
5483 break;
5484
5485 default:
5486 gfc_internal_error ("match_attr_spec(): Bad attribute");
5487 }
5488
5489 if (!t)
5490 {
5491 m = MATCH_ERROR;
5492 goto cleanup;
5493 }
5494 }
5495
5496 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5497 if ((gfc_current_state () == COMP_MODULE
5498 || gfc_current_state () == COMP_SUBMODULE)
5499 && !current_attr.save
5500 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5501 current_attr.save = SAVE_IMPLICIT;
5502
5503 colon_seen = 1;
5504 return MATCH_YES;
5505
5506 cleanup:
5507 gfc_current_locus = start;
5508 gfc_free_array_spec (current_as);
5509 current_as = NULL;
5510 attr_seen = 0;
5511 return m;
5512 }
5513
5514
5515 /* Set the binding label, dest_label, either with the binding label
5516 stored in the given gfc_typespec, ts, or if none was provided, it
5517 will be the symbol name in all lower case, as required by the draft
5518 (J3/04-007, section 15.4.1). If a binding label was given and
5519 there is more than one argument (num_idents), it is an error. */
5520
5521 static bool
set_binding_label(const char ** dest_label,const char * sym_name,int num_idents)5522 set_binding_label (const char **dest_label, const char *sym_name,
5523 int num_idents)
5524 {
5525 if (num_idents > 1 && has_name_equals)
5526 {
5527 gfc_error ("Multiple identifiers provided with "
5528 "single NAME= specifier at %C");
5529 return false;
5530 }
5531
5532 if (curr_binding_label)
5533 /* Binding label given; store in temp holder till have sym. */
5534 *dest_label = curr_binding_label;
5535 else
5536 {
5537 /* No binding label given, and the NAME= specifier did not exist,
5538 which means there was no NAME="". */
5539 if (sym_name != NULL && has_name_equals == 0)
5540 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5541 }
5542
5543 return true;
5544 }
5545
5546
5547 /* Set the status of the given common block as being BIND(C) or not,
5548 depending on the given parameter, is_bind_c. */
5549
5550 void
set_com_block_bind_c(gfc_common_head * com_block,int is_bind_c)5551 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5552 {
5553 com_block->is_bind_c = is_bind_c;
5554 return;
5555 }
5556
5557
5558 /* Verify that the given gfc_typespec is for a C interoperable type. */
5559
5560 bool
gfc_verify_c_interop(gfc_typespec * ts)5561 gfc_verify_c_interop (gfc_typespec *ts)
5562 {
5563 if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5564 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5565 ? true : false;
5566 else if (ts->type == BT_CLASS)
5567 return false;
5568 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5569 return false;
5570
5571 return true;
5572 }
5573
5574
5575 /* Verify that the variables of a given common block, which has been
5576 defined with the attribute specifier bind(c), to be of a C
5577 interoperable type. Errors will be reported here, if
5578 encountered. */
5579
5580 bool
verify_com_block_vars_c_interop(gfc_common_head * com_block)5581 verify_com_block_vars_c_interop (gfc_common_head *com_block)
5582 {
5583 gfc_symbol *curr_sym = NULL;
5584 bool retval = true;
5585
5586 curr_sym = com_block->head;
5587
5588 /* Make sure we have at least one symbol. */
5589 if (curr_sym == NULL)
5590 return retval;
5591
5592 /* Here we know we have a symbol, so we'll execute this loop
5593 at least once. */
5594 do
5595 {
5596 /* The second to last param, 1, says this is in a common block. */
5597 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5598 curr_sym = curr_sym->common_next;
5599 } while (curr_sym != NULL);
5600
5601 return retval;
5602 }
5603
5604
5605 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5606 an appropriate error message is reported. */
5607
5608 bool
verify_bind_c_sym(gfc_symbol * tmp_sym,gfc_typespec * ts,int is_in_common,gfc_common_head * com_block)5609 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5610 int is_in_common, gfc_common_head *com_block)
5611 {
5612 bool bind_c_function = false;
5613 bool retval = true;
5614
5615 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5616 bind_c_function = true;
5617
5618 if (tmp_sym->attr.function && tmp_sym->result != NULL)
5619 {
5620 tmp_sym = tmp_sym->result;
5621 /* Make sure it wasn't an implicitly typed result. */
5622 if (tmp_sym->attr.implicit_type && warn_c_binding_type)
5623 {
5624 gfc_warning (OPT_Wc_binding_type,
5625 "Implicitly declared BIND(C) function %qs at "
5626 "%L may not be C interoperable", tmp_sym->name,
5627 &tmp_sym->declared_at);
5628 tmp_sym->ts.f90_type = tmp_sym->ts.type;
5629 /* Mark it as C interoperable to prevent duplicate warnings. */
5630 tmp_sym->ts.is_c_interop = 1;
5631 tmp_sym->attr.is_c_interop = 1;
5632 }
5633 }
5634
5635 /* Here, we know we have the bind(c) attribute, so if we have
5636 enough type info, then verify that it's a C interop kind.
5637 The info could be in the symbol already, or possibly still in
5638 the given ts (current_ts), so look in both. */
5639 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
5640 {
5641 if (!gfc_verify_c_interop (&(tmp_sym->ts)))
5642 {
5643 /* See if we're dealing with a sym in a common block or not. */
5644 if (is_in_common == 1 && warn_c_binding_type)
5645 {
5646 gfc_warning (OPT_Wc_binding_type,
5647 "Variable %qs in common block %qs at %L "
5648 "may not be a C interoperable "
5649 "kind though common block %qs is BIND(C)",
5650 tmp_sym->name, com_block->name,
5651 &(tmp_sym->declared_at), com_block->name);
5652 }
5653 else
5654 {
5655 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
5656 gfc_error ("Type declaration %qs at %L is not C "
5657 "interoperable but it is BIND(C)",
5658 tmp_sym->name, &(tmp_sym->declared_at));
5659 else if (warn_c_binding_type)
5660 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
5661 "may not be a C interoperable "
5662 "kind but it is BIND(C)",
5663 tmp_sym->name, &(tmp_sym->declared_at));
5664 }
5665 }
5666
5667 /* Variables declared w/in a common block can't be bind(c)
5668 since there's no way for C to see these variables, so there's
5669 semantically no reason for the attribute. */
5670 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
5671 {
5672 gfc_error ("Variable %qs in common block %qs at "
5673 "%L cannot be declared with BIND(C) "
5674 "since it is not a global",
5675 tmp_sym->name, com_block->name,
5676 &(tmp_sym->declared_at));
5677 retval = false;
5678 }
5679
5680 /* Scalar variables that are bind(c) can not have the pointer
5681 or allocatable attributes. */
5682 if (tmp_sym->attr.is_bind_c == 1)
5683 {
5684 if (tmp_sym->attr.pointer == 1)
5685 {
5686 gfc_error ("Variable %qs at %L cannot have both the "
5687 "POINTER and BIND(C) attributes",
5688 tmp_sym->name, &(tmp_sym->declared_at));
5689 retval = false;
5690 }
5691
5692 if (tmp_sym->attr.allocatable == 1)
5693 {
5694 gfc_error ("Variable %qs at %L cannot have both the "
5695 "ALLOCATABLE and BIND(C) attributes",
5696 tmp_sym->name, &(tmp_sym->declared_at));
5697 retval = false;
5698 }
5699
5700 }
5701
5702 /* If it is a BIND(C) function, make sure the return value is a
5703 scalar value. The previous tests in this function made sure
5704 the type is interoperable. */
5705 if (bind_c_function && tmp_sym->as != NULL)
5706 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5707 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
5708
5709 /* BIND(C) functions can not return a character string. */
5710 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
5711 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
5712 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5713 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
5714 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5715 "be a character string", tmp_sym->name,
5716 &(tmp_sym->declared_at));
5717 }
5718
5719 /* See if the symbol has been marked as private. If it has, make sure
5720 there is no binding label and warn the user if there is one. */
5721 if (tmp_sym->attr.access == ACCESS_PRIVATE
5722 && tmp_sym->binding_label)
5723 /* Use gfc_warning_now because we won't say that the symbol fails
5724 just because of this. */
5725 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5726 "given the binding label %qs", tmp_sym->name,
5727 &(tmp_sym->declared_at), tmp_sym->binding_label);
5728
5729 return retval;
5730 }
5731
5732
5733 /* Set the appropriate fields for a symbol that's been declared as
5734 BIND(C) (the is_bind_c flag and the binding label), and verify that
5735 the type is C interoperable. Errors are reported by the functions
5736 used to set/test these fields. */
5737
5738 bool
set_verify_bind_c_sym(gfc_symbol * tmp_sym,int num_idents)5739 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
5740 {
5741 bool retval = true;
5742
5743 /* TODO: Do we need to make sure the vars aren't marked private? */
5744
5745 /* Set the is_bind_c bit in symbol_attribute. */
5746 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
5747
5748 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
5749 return false;
5750
5751 return retval;
5752 }
5753
5754
5755 /* Set the fields marking the given common block as BIND(C), including
5756 a binding label, and report any errors encountered. */
5757
5758 bool
set_verify_bind_c_com_block(gfc_common_head * com_block,int num_idents)5759 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
5760 {
5761 bool retval = true;
5762
5763 /* destLabel, common name, typespec (which may have binding label). */
5764 if (!set_binding_label (&com_block->binding_label, com_block->name,
5765 num_idents))
5766 return false;
5767
5768 /* Set the given common block (com_block) to being bind(c) (1). */
5769 set_com_block_bind_c (com_block, 1);
5770
5771 return retval;
5772 }
5773
5774
5775 /* Retrieve the list of one or more identifiers that the given bind(c)
5776 attribute applies to. */
5777
5778 bool
get_bind_c_idents(void)5779 get_bind_c_idents (void)
5780 {
5781 char name[GFC_MAX_SYMBOL_LEN + 1];
5782 int num_idents = 0;
5783 gfc_symbol *tmp_sym = NULL;
5784 match found_id;
5785 gfc_common_head *com_block = NULL;
5786
5787 if (gfc_match_name (name) == MATCH_YES)
5788 {
5789 found_id = MATCH_YES;
5790 gfc_get_ha_symbol (name, &tmp_sym);
5791 }
5792 else if (match_common_name (name) == MATCH_YES)
5793 {
5794 found_id = MATCH_YES;
5795 com_block = gfc_get_common (name, 0);
5796 }
5797 else
5798 {
5799 gfc_error ("Need either entity or common block name for "
5800 "attribute specification statement at %C");
5801 return false;
5802 }
5803
5804 /* Save the current identifier and look for more. */
5805 do
5806 {
5807 /* Increment the number of identifiers found for this spec stmt. */
5808 num_idents++;
5809
5810 /* Make sure we have a sym or com block, and verify that it can
5811 be bind(c). Set the appropriate field(s) and look for more
5812 identifiers. */
5813 if (tmp_sym != NULL || com_block != NULL)
5814 {
5815 if (tmp_sym != NULL)
5816 {
5817 if (!set_verify_bind_c_sym (tmp_sym, num_idents))
5818 return false;
5819 }
5820 else
5821 {
5822 if (!set_verify_bind_c_com_block (com_block, num_idents))
5823 return false;
5824 }
5825
5826 /* Look to see if we have another identifier. */
5827 tmp_sym = NULL;
5828 if (gfc_match_eos () == MATCH_YES)
5829 found_id = MATCH_NO;
5830 else if (gfc_match_char (',') != MATCH_YES)
5831 found_id = MATCH_NO;
5832 else if (gfc_match_name (name) == MATCH_YES)
5833 {
5834 found_id = MATCH_YES;
5835 gfc_get_ha_symbol (name, &tmp_sym);
5836 }
5837 else if (match_common_name (name) == MATCH_YES)
5838 {
5839 found_id = MATCH_YES;
5840 com_block = gfc_get_common (name, 0);
5841 }
5842 else
5843 {
5844 gfc_error ("Missing entity or common block name for "
5845 "attribute specification statement at %C");
5846 return false;
5847 }
5848 }
5849 else
5850 {
5851 gfc_internal_error ("Missing symbol");
5852 }
5853 } while (found_id == MATCH_YES);
5854
5855 /* if we get here we were successful */
5856 return true;
5857 }
5858
5859
5860 /* Try and match a BIND(C) attribute specification statement. */
5861
5862 match
gfc_match_bind_c_stmt(void)5863 gfc_match_bind_c_stmt (void)
5864 {
5865 match found_match = MATCH_NO;
5866 gfc_typespec *ts;
5867
5868 ts = ¤t_ts;
5869
5870 /* This may not be necessary. */
5871 gfc_clear_ts (ts);
5872 /* Clear the temporary binding label holder. */
5873 curr_binding_label = NULL;
5874
5875 /* Look for the bind(c). */
5876 found_match = gfc_match_bind_c (NULL, true);
5877
5878 if (found_match == MATCH_YES)
5879 {
5880 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
5881 return MATCH_ERROR;
5882
5883 /* Look for the :: now, but it is not required. */
5884 gfc_match (" :: ");
5885
5886 /* Get the identifier(s) that needs to be updated. This may need to
5887 change to hand the flag(s) for the attr specified so all identifiers
5888 found can have all appropriate parts updated (assuming that the same
5889 spec stmt can have multiple attrs, such as both bind(c) and
5890 allocatable...). */
5891 if (!get_bind_c_idents ())
5892 /* Error message should have printed already. */
5893 return MATCH_ERROR;
5894 }
5895
5896 return found_match;
5897 }
5898
5899
5900 /* Match a data declaration statement. */
5901
5902 match
gfc_match_data_decl(void)5903 gfc_match_data_decl (void)
5904 {
5905 gfc_symbol *sym;
5906 match m;
5907 int elem;
5908
5909 type_param_spec_list = NULL;
5910 decl_type_param_list = NULL;
5911
5912 num_idents_on_line = 0;
5913
5914 m = gfc_match_decl_type_spec (¤t_ts, 0);
5915 if (m != MATCH_YES)
5916 return m;
5917
5918 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5919 && !gfc_comp_struct (gfc_current_state ()))
5920 {
5921 sym = gfc_use_derived (current_ts.u.derived);
5922
5923 if (sym == NULL)
5924 {
5925 m = MATCH_ERROR;
5926 goto cleanup;
5927 }
5928
5929 current_ts.u.derived = sym;
5930 }
5931
5932 m = match_attr_spec ();
5933 if (m == MATCH_ERROR)
5934 {
5935 m = MATCH_NO;
5936 goto cleanup;
5937 }
5938
5939 if (current_ts.type == BT_CLASS
5940 && current_ts.u.derived->attr.unlimited_polymorphic)
5941 goto ok;
5942
5943 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5944 && current_ts.u.derived->components == NULL
5945 && !current_ts.u.derived->attr.zero_comp)
5946 {
5947
5948 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
5949 goto ok;
5950
5951 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
5952 && current_ts.u.derived == gfc_current_block ())
5953 goto ok;
5954
5955 gfc_find_symbol (current_ts.u.derived->name,
5956 current_ts.u.derived->ns, 1, &sym);
5957
5958 /* Any symbol that we find had better be a type definition
5959 which has its components defined, or be a structure definition
5960 actively being parsed. */
5961 if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
5962 && (current_ts.u.derived->components != NULL
5963 || current_ts.u.derived->attr.zero_comp
5964 || current_ts.u.derived == gfc_new_block))
5965 goto ok;
5966
5967 gfc_error ("Derived type at %C has not been previously defined "
5968 "and so cannot appear in a derived type definition");
5969 m = MATCH_ERROR;
5970 goto cleanup;
5971 }
5972
5973 ok:
5974 /* If we have an old-style character declaration, and no new-style
5975 attribute specifications, then there a comma is optional between
5976 the type specification and the variable list. */
5977 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
5978 gfc_match_char (',');
5979
5980 /* Give the types/attributes to symbols that follow. Give the element
5981 a number so that repeat character length expressions can be copied. */
5982 elem = 1;
5983 for (;;)
5984 {
5985 num_idents_on_line++;
5986 m = variable_decl (elem++);
5987 if (m == MATCH_ERROR)
5988 goto cleanup;
5989 if (m == MATCH_NO)
5990 break;
5991
5992 if (gfc_match_eos () == MATCH_YES)
5993 goto cleanup;
5994 if (gfc_match_char (',') != MATCH_YES)
5995 break;
5996 }
5997
5998 if (!gfc_error_flag_test ())
5999 {
6000 /* An anonymous structure declaration is unambiguous; if we matched one
6001 according to gfc_match_structure_decl, we need to return MATCH_YES
6002 here to avoid confusing the remaining matchers, even if there was an
6003 error during variable_decl. We must flush any such errors. Note this
6004 causes the parser to gracefully continue parsing the remaining input
6005 as a structure body, which likely follows. */
6006 if (current_ts.type == BT_DERIVED && current_ts.u.derived
6007 && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6008 {
6009 gfc_error_now ("Syntax error in anonymous structure declaration"
6010 " at %C");
6011 /* Skip the bad variable_decl and line up for the start of the
6012 structure body. */
6013 gfc_error_recovery ();
6014 m = MATCH_YES;
6015 goto cleanup;
6016 }
6017
6018 gfc_error ("Syntax error in data declaration at %C");
6019 }
6020
6021 m = MATCH_ERROR;
6022
6023 gfc_free_data_all (gfc_current_ns);
6024
6025 cleanup:
6026 if (saved_kind_expr)
6027 gfc_free_expr (saved_kind_expr);
6028 if (type_param_spec_list)
6029 gfc_free_actual_arglist (type_param_spec_list);
6030 if (decl_type_param_list)
6031 gfc_free_actual_arglist (decl_type_param_list);
6032 saved_kind_expr = NULL;
6033 gfc_free_array_spec (current_as);
6034 current_as = NULL;
6035 return m;
6036 }
6037
6038
6039 /* Match a prefix associated with a function or subroutine
6040 declaration. If the typespec pointer is nonnull, then a typespec
6041 can be matched. Note that if nothing matches, MATCH_YES is
6042 returned (the null string was matched). */
6043
6044 match
gfc_match_prefix(gfc_typespec * ts)6045 gfc_match_prefix (gfc_typespec *ts)
6046 {
6047 bool seen_type;
6048 bool seen_impure;
6049 bool found_prefix;
6050
6051 gfc_clear_attr (¤t_attr);
6052 seen_type = false;
6053 seen_impure = false;
6054
6055 gcc_assert (!gfc_matching_prefix);
6056 gfc_matching_prefix = true;
6057
6058 do
6059 {
6060 found_prefix = false;
6061
6062 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6063 corresponding attribute seems natural and distinguishes these
6064 procedures from procedure types of PROC_MODULE, which these are
6065 as well. */
6066 if (gfc_match ("module% ") == MATCH_YES)
6067 {
6068 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6069 goto error;
6070
6071 current_attr.module_procedure = 1;
6072 found_prefix = true;
6073 }
6074
6075 if (!seen_type && ts != NULL
6076 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
6077 && gfc_match_space () == MATCH_YES)
6078 {
6079
6080 seen_type = true;
6081 found_prefix = true;
6082 }
6083
6084 if (gfc_match ("elemental% ") == MATCH_YES)
6085 {
6086 if (!gfc_add_elemental (¤t_attr, NULL))
6087 goto error;
6088
6089 found_prefix = true;
6090 }
6091
6092 if (gfc_match ("pure% ") == MATCH_YES)
6093 {
6094 if (!gfc_add_pure (¤t_attr, NULL))
6095 goto error;
6096
6097 found_prefix = true;
6098 }
6099
6100 if (gfc_match ("recursive% ") == MATCH_YES)
6101 {
6102 if (!gfc_add_recursive (¤t_attr, NULL))
6103 goto error;
6104
6105 found_prefix = true;
6106 }
6107
6108 /* IMPURE is a somewhat special case, as it needs not set an actual
6109 attribute but rather only prevents ELEMENTAL routines from being
6110 automatically PURE. */
6111 if (gfc_match ("impure% ") == MATCH_YES)
6112 {
6113 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6114 goto error;
6115
6116 seen_impure = true;
6117 found_prefix = true;
6118 }
6119 }
6120 while (found_prefix);
6121
6122 /* IMPURE and PURE must not both appear, of course. */
6123 if (seen_impure && current_attr.pure)
6124 {
6125 gfc_error ("PURE and IMPURE must not appear both at %C");
6126 goto error;
6127 }
6128
6129 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6130 if (!seen_impure && current_attr.elemental && !current_attr.pure)
6131 {
6132 if (!gfc_add_pure (¤t_attr, NULL))
6133 goto error;
6134 }
6135
6136 /* At this point, the next item is not a prefix. */
6137 gcc_assert (gfc_matching_prefix);
6138
6139 gfc_matching_prefix = false;
6140 return MATCH_YES;
6141
6142 error:
6143 gcc_assert (gfc_matching_prefix);
6144 gfc_matching_prefix = false;
6145 return MATCH_ERROR;
6146 }
6147
6148
6149 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6150
6151 static bool
copy_prefix(symbol_attribute * dest,locus * where)6152 copy_prefix (symbol_attribute *dest, locus *where)
6153 {
6154 if (dest->module_procedure)
6155 {
6156 if (current_attr.elemental)
6157 dest->elemental = 1;
6158
6159 if (current_attr.pure)
6160 dest->pure = 1;
6161
6162 if (current_attr.recursive)
6163 dest->recursive = 1;
6164
6165 /* Module procedures are unusual in that the 'dest' is copied from
6166 the interface declaration. However, this is an oportunity to
6167 check that the submodule declaration is compliant with the
6168 interface. */
6169 if (dest->elemental && !current_attr.elemental)
6170 {
6171 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6172 "missing at %L", where);
6173 return false;
6174 }
6175
6176 if (dest->pure && !current_attr.pure)
6177 {
6178 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6179 "missing at %L", where);
6180 return false;
6181 }
6182
6183 if (dest->recursive && !current_attr.recursive)
6184 {
6185 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6186 "missing at %L", where);
6187 return false;
6188 }
6189
6190 return true;
6191 }
6192
6193 if (current_attr.elemental && !gfc_add_elemental (dest, where))
6194 return false;
6195
6196 if (current_attr.pure && !gfc_add_pure (dest, where))
6197 return false;
6198
6199 if (current_attr.recursive && !gfc_add_recursive (dest, where))
6200 return false;
6201
6202 return true;
6203 }
6204
6205
6206 /* Match a formal argument list or, if typeparam is true, a
6207 type_param_name_list. */
6208
6209 match
gfc_match_formal_arglist(gfc_symbol * progname,int st_flag,int null_flag,bool typeparam)6210 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6211 int null_flag, bool typeparam)
6212 {
6213 gfc_formal_arglist *head, *tail, *p, *q;
6214 char name[GFC_MAX_SYMBOL_LEN + 1];
6215 gfc_symbol *sym;
6216 match m;
6217 gfc_formal_arglist *formal = NULL;
6218
6219 head = tail = NULL;
6220
6221 /* Keep the interface formal argument list and null it so that the
6222 matching for the new declaration can be done. The numbers and
6223 names of the arguments are checked here. The interface formal
6224 arguments are retained in formal_arglist and the characteristics
6225 are compared in resolve.c(resolve_fl_procedure). See the remark
6226 in get_proc_name about the eventual need to copy the formal_arglist
6227 and populate the formal namespace of the interface symbol. */
6228 if (progname->attr.module_procedure
6229 && progname->attr.host_assoc)
6230 {
6231 formal = progname->formal;
6232 progname->formal = NULL;
6233 }
6234
6235 if (gfc_match_char ('(') != MATCH_YES)
6236 {
6237 if (null_flag)
6238 goto ok;
6239 return MATCH_NO;
6240 }
6241
6242 if (gfc_match_char (')') == MATCH_YES)
6243 goto ok;
6244
6245 for (;;)
6246 {
6247 if (gfc_match_char ('*') == MATCH_YES)
6248 {
6249 sym = NULL;
6250 if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6251 "Alternate-return argument at %C"))
6252 {
6253 m = MATCH_ERROR;
6254 goto cleanup;
6255 }
6256 else if (typeparam)
6257 gfc_error_now ("A parameter name is required at %C");
6258 }
6259 else
6260 {
6261 m = gfc_match_name (name);
6262 if (m != MATCH_YES)
6263 {
6264 if(typeparam)
6265 gfc_error_now ("A parameter name is required at %C");
6266 goto cleanup;
6267 }
6268
6269 if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6270 goto cleanup;
6271 else if (typeparam
6272 && gfc_get_symbol (name, progname->f2k_derived, &sym))
6273 goto cleanup;
6274 }
6275
6276 p = gfc_get_formal_arglist ();
6277
6278 if (head == NULL)
6279 head = tail = p;
6280 else
6281 {
6282 tail->next = p;
6283 tail = p;
6284 }
6285
6286 tail->sym = sym;
6287
6288 /* We don't add the VARIABLE flavor because the name could be a
6289 dummy procedure. We don't apply these attributes to formal
6290 arguments of statement functions. */
6291 if (sym != NULL && !st_flag
6292 && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6293 || !gfc_missing_attr (&sym->attr, NULL)))
6294 {
6295 m = MATCH_ERROR;
6296 goto cleanup;
6297 }
6298
6299 /* The name of a program unit can be in a different namespace,
6300 so check for it explicitly. After the statement is accepted,
6301 the name is checked for especially in gfc_get_symbol(). */
6302 if (gfc_new_block != NULL && sym != NULL && !typeparam
6303 && strcmp (sym->name, gfc_new_block->name) == 0)
6304 {
6305 gfc_error ("Name %qs at %C is the name of the procedure",
6306 sym->name);
6307 m = MATCH_ERROR;
6308 goto cleanup;
6309 }
6310
6311 if (gfc_match_char (')') == MATCH_YES)
6312 goto ok;
6313
6314 m = gfc_match_char (',');
6315 if (m != MATCH_YES)
6316 {
6317 if (typeparam)
6318 gfc_error_now ("Expected parameter list in type declaration "
6319 "at %C");
6320 else
6321 gfc_error ("Unexpected junk in formal argument list at %C");
6322 goto cleanup;
6323 }
6324 }
6325
6326 ok:
6327 /* Check for duplicate symbols in the formal argument list. */
6328 if (head != NULL)
6329 {
6330 for (p = head; p->next; p = p->next)
6331 {
6332 if (p->sym == NULL)
6333 continue;
6334
6335 for (q = p->next; q; q = q->next)
6336 if (p->sym == q->sym)
6337 {
6338 if (typeparam)
6339 gfc_error_now ("Duplicate name %qs in parameter "
6340 "list at %C", p->sym->name);
6341 else
6342 gfc_error ("Duplicate symbol %qs in formal argument "
6343 "list at %C", p->sym->name);
6344
6345 m = MATCH_ERROR;
6346 goto cleanup;
6347 }
6348 }
6349 }
6350
6351 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6352 {
6353 m = MATCH_ERROR;
6354 goto cleanup;
6355 }
6356
6357 /* gfc_error_now used in following and return with MATCH_YES because
6358 doing otherwise results in a cascade of extraneous errors and in
6359 some cases an ICE in symbol.c(gfc_release_symbol). */
6360 if (progname->attr.module_procedure && progname->attr.host_assoc)
6361 {
6362 bool arg_count_mismatch = false;
6363
6364 if (!formal && head)
6365 arg_count_mismatch = true;
6366
6367 /* Abbreviated module procedure declaration is not meant to have any
6368 formal arguments! */
6369 if (!progname->abr_modproc_decl && formal && !head)
6370 arg_count_mismatch = true;
6371
6372 for (p = formal, q = head; p && q; p = p->next, q = q->next)
6373 {
6374 if ((p->next != NULL && q->next == NULL)
6375 || (p->next == NULL && q->next != NULL))
6376 arg_count_mismatch = true;
6377 else if ((p->sym == NULL && q->sym == NULL)
6378 || strcmp (p->sym->name, q->sym->name) == 0)
6379 continue;
6380 else
6381 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6382 "argument names (%s/%s) at %C",
6383 p->sym->name, q->sym->name);
6384 }
6385
6386 if (arg_count_mismatch)
6387 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6388 "formal arguments at %C");
6389 }
6390
6391 return MATCH_YES;
6392
6393 cleanup:
6394 gfc_free_formal_arglist (head);
6395 return m;
6396 }
6397
6398
6399 /* Match a RESULT specification following a function declaration or
6400 ENTRY statement. Also matches the end-of-statement. */
6401
6402 static match
match_result(gfc_symbol * function,gfc_symbol ** result)6403 match_result (gfc_symbol *function, gfc_symbol **result)
6404 {
6405 char name[GFC_MAX_SYMBOL_LEN + 1];
6406 gfc_symbol *r;
6407 match m;
6408
6409 if (gfc_match (" result (") != MATCH_YES)
6410 return MATCH_NO;
6411
6412 m = gfc_match_name (name);
6413 if (m != MATCH_YES)
6414 return m;
6415
6416 /* Get the right paren, and that's it because there could be the
6417 bind(c) attribute after the result clause. */
6418 if (gfc_match_char (')') != MATCH_YES)
6419 {
6420 /* TODO: should report the missing right paren here. */
6421 return MATCH_ERROR;
6422 }
6423
6424 if (strcmp (function->name, name) == 0)
6425 {
6426 gfc_error ("RESULT variable at %C must be different than function name");
6427 return MATCH_ERROR;
6428 }
6429
6430 if (gfc_get_symbol (name, NULL, &r))
6431 return MATCH_ERROR;
6432
6433 if (!gfc_add_result (&r->attr, r->name, NULL))
6434 return MATCH_ERROR;
6435
6436 *result = r;
6437
6438 return MATCH_YES;
6439 }
6440
6441
6442 /* Match a function suffix, which could be a combination of a result
6443 clause and BIND(C), either one, or neither. The draft does not
6444 require them to come in a specific order. */
6445
6446 match
gfc_match_suffix(gfc_symbol * sym,gfc_symbol ** result)6447 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6448 {
6449 match is_bind_c; /* Found bind(c). */
6450 match is_result; /* Found result clause. */
6451 match found_match; /* Status of whether we've found a good match. */
6452 char peek_char; /* Character we're going to peek at. */
6453 bool allow_binding_name;
6454
6455 /* Initialize to having found nothing. */
6456 found_match = MATCH_NO;
6457 is_bind_c = MATCH_NO;
6458 is_result = MATCH_NO;
6459
6460 /* Get the next char to narrow between result and bind(c). */
6461 gfc_gobble_whitespace ();
6462 peek_char = gfc_peek_ascii_char ();
6463
6464 /* C binding names are not allowed for internal procedures. */
6465 if (gfc_current_state () == COMP_CONTAINS
6466 && sym->ns->proc_name->attr.flavor != FL_MODULE)
6467 allow_binding_name = false;
6468 else
6469 allow_binding_name = true;
6470
6471 switch (peek_char)
6472 {
6473 case 'r':
6474 /* Look for result clause. */
6475 is_result = match_result (sym, result);
6476 if (is_result == MATCH_YES)
6477 {
6478 /* Now see if there is a bind(c) after it. */
6479 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6480 /* We've found the result clause and possibly bind(c). */
6481 found_match = MATCH_YES;
6482 }
6483 else
6484 /* This should only be MATCH_ERROR. */
6485 found_match = is_result;
6486 break;
6487 case 'b':
6488 /* Look for bind(c) first. */
6489 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6490 if (is_bind_c == MATCH_YES)
6491 {
6492 /* Now see if a result clause followed it. */
6493 is_result = match_result (sym, result);
6494 found_match = MATCH_YES;
6495 }
6496 else
6497 {
6498 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6499 found_match = MATCH_ERROR;
6500 }
6501 break;
6502 default:
6503 gfc_error ("Unexpected junk after function declaration at %C");
6504 found_match = MATCH_ERROR;
6505 break;
6506 }
6507
6508 if (is_bind_c == MATCH_YES)
6509 {
6510 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6511 if (gfc_current_state () == COMP_CONTAINS
6512 && sym->ns->proc_name->attr.flavor != FL_MODULE
6513 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6514 "at %L may not be specified for an internal "
6515 "procedure", &gfc_current_locus))
6516 return MATCH_ERROR;
6517
6518 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6519 return MATCH_ERROR;
6520 }
6521
6522 return found_match;
6523 }
6524
6525
6526 /* Procedure pointer return value without RESULT statement:
6527 Add "hidden" result variable named "ppr@". */
6528
6529 static bool
add_hidden_procptr_result(gfc_symbol * sym)6530 add_hidden_procptr_result (gfc_symbol *sym)
6531 {
6532 bool case1,case2;
6533
6534 if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6535 return false;
6536
6537 /* First usage case: PROCEDURE and EXTERNAL statements. */
6538 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6539 && strcmp (gfc_current_block ()->name, sym->name) == 0
6540 && sym->attr.external;
6541 /* Second usage case: INTERFACE statements. */
6542 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6543 && gfc_state_stack->previous->state == COMP_FUNCTION
6544 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
6545
6546 if (case1 || case2)
6547 {
6548 gfc_symtree *stree;
6549 if (case1)
6550 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
6551 else if (case2)
6552 {
6553 gfc_symtree *st2;
6554 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
6555 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
6556 st2->n.sym = stree->n.sym;
6557 stree->n.sym->refs++;
6558 }
6559 sym->result = stree->n.sym;
6560
6561 sym->result->attr.proc_pointer = sym->attr.proc_pointer;
6562 sym->result->attr.pointer = sym->attr.pointer;
6563 sym->result->attr.external = sym->attr.external;
6564 sym->result->attr.referenced = sym->attr.referenced;
6565 sym->result->ts = sym->ts;
6566 sym->attr.proc_pointer = 0;
6567 sym->attr.pointer = 0;
6568 sym->attr.external = 0;
6569 if (sym->result->attr.external && sym->result->attr.pointer)
6570 {
6571 sym->result->attr.pointer = 0;
6572 sym->result->attr.proc_pointer = 1;
6573 }
6574
6575 return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
6576 }
6577 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6578 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
6579 && sym->result && sym->result != sym && sym->result->attr.external
6580 && sym == gfc_current_ns->proc_name
6581 && sym == sym->result->ns->proc_name
6582 && strcmp ("ppr@", sym->result->name) == 0)
6583 {
6584 sym->result->attr.proc_pointer = 1;
6585 sym->attr.pointer = 0;
6586 return true;
6587 }
6588 else
6589 return false;
6590 }
6591
6592
6593 /* Match the interface for a PROCEDURE declaration,
6594 including brackets (R1212). */
6595
6596 static match
match_procedure_interface(gfc_symbol ** proc_if)6597 match_procedure_interface (gfc_symbol **proc_if)
6598 {
6599 match m;
6600 gfc_symtree *st;
6601 locus old_loc, entry_loc;
6602 gfc_namespace *old_ns = gfc_current_ns;
6603 char name[GFC_MAX_SYMBOL_LEN + 1];
6604
6605 old_loc = entry_loc = gfc_current_locus;
6606 gfc_clear_ts (¤t_ts);
6607
6608 if (gfc_match (" (") != MATCH_YES)
6609 {
6610 gfc_current_locus = entry_loc;
6611 return MATCH_NO;
6612 }
6613
6614 /* Get the type spec. for the procedure interface. */
6615 old_loc = gfc_current_locus;
6616 m = gfc_match_decl_type_spec (¤t_ts, 0);
6617 gfc_gobble_whitespace ();
6618 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
6619 goto got_ts;
6620
6621 if (m == MATCH_ERROR)
6622 return m;
6623
6624 /* Procedure interface is itself a procedure. */
6625 gfc_current_locus = old_loc;
6626 m = gfc_match_name (name);
6627
6628 /* First look to see if it is already accessible in the current
6629 namespace because it is use associated or contained. */
6630 st = NULL;
6631 if (gfc_find_sym_tree (name, NULL, 0, &st))
6632 return MATCH_ERROR;
6633
6634 /* If it is still not found, then try the parent namespace, if it
6635 exists and create the symbol there if it is still not found. */
6636 if (gfc_current_ns->parent)
6637 gfc_current_ns = gfc_current_ns->parent;
6638 if (st == NULL && gfc_get_ha_sym_tree (name, &st))
6639 return MATCH_ERROR;
6640
6641 gfc_current_ns = old_ns;
6642 *proc_if = st->n.sym;
6643
6644 if (*proc_if)
6645 {
6646 (*proc_if)->refs++;
6647 /* Resolve interface if possible. That way, attr.procedure is only set
6648 if it is declared by a later procedure-declaration-stmt, which is
6649 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6650 while ((*proc_if)->ts.interface
6651 && *proc_if != (*proc_if)->ts.interface)
6652 *proc_if = (*proc_if)->ts.interface;
6653
6654 if ((*proc_if)->attr.flavor == FL_UNKNOWN
6655 && (*proc_if)->ts.type == BT_UNKNOWN
6656 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
6657 (*proc_if)->name, NULL))
6658 return MATCH_ERROR;
6659 }
6660
6661 got_ts:
6662 if (gfc_match (" )") != MATCH_YES)
6663 {
6664 gfc_current_locus = entry_loc;
6665 return MATCH_NO;
6666 }
6667
6668 return MATCH_YES;
6669 }
6670
6671
6672 /* Match a PROCEDURE declaration (R1211). */
6673
6674 static match
match_procedure_decl(void)6675 match_procedure_decl (void)
6676 {
6677 match m;
6678 gfc_symbol *sym, *proc_if = NULL;
6679 int num;
6680 gfc_expr *initializer = NULL;
6681
6682 /* Parse interface (with brackets). */
6683 m = match_procedure_interface (&proc_if);
6684 if (m != MATCH_YES)
6685 return m;
6686
6687 /* Parse attributes (with colons). */
6688 m = match_attr_spec();
6689 if (m == MATCH_ERROR)
6690 return MATCH_ERROR;
6691
6692 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
6693 {
6694 current_attr.is_bind_c = 1;
6695 has_name_equals = 0;
6696 curr_binding_label = NULL;
6697 }
6698
6699 /* Get procedure symbols. */
6700 for(num=1;;num++)
6701 {
6702 m = gfc_match_symbol (&sym, 0);
6703 if (m == MATCH_NO)
6704 goto syntax;
6705 else if (m == MATCH_ERROR)
6706 return m;
6707
6708 /* Add current_attr to the symbol attributes. */
6709 if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
6710 return MATCH_ERROR;
6711
6712 if (sym->attr.is_bind_c)
6713 {
6714 /* Check for C1218. */
6715 if (!proc_if || !proc_if->attr.is_bind_c)
6716 {
6717 gfc_error ("BIND(C) attribute at %C requires "
6718 "an interface with BIND(C)");
6719 return MATCH_ERROR;
6720 }
6721 /* Check for C1217. */
6722 if (has_name_equals && sym->attr.pointer)
6723 {
6724 gfc_error ("BIND(C) procedure with NAME may not have "
6725 "POINTER attribute at %C");
6726 return MATCH_ERROR;
6727 }
6728 if (has_name_equals && sym->attr.dummy)
6729 {
6730 gfc_error ("Dummy procedure at %C may not have "
6731 "BIND(C) attribute with NAME");
6732 return MATCH_ERROR;
6733 }
6734 /* Set binding label for BIND(C). */
6735 if (!set_binding_label (&sym->binding_label, sym->name, num))
6736 return MATCH_ERROR;
6737 }
6738
6739 if (!gfc_add_external (&sym->attr, NULL))
6740 return MATCH_ERROR;
6741
6742 if (add_hidden_procptr_result (sym))
6743 sym = sym->result;
6744
6745 if (!gfc_add_proc (&sym->attr, sym->name, NULL))
6746 return MATCH_ERROR;
6747
6748 /* Set interface. */
6749 if (proc_if != NULL)
6750 {
6751 if (sym->ts.type != BT_UNKNOWN)
6752 {
6753 gfc_error ("Procedure %qs at %L already has basic type of %s",
6754 sym->name, &gfc_current_locus,
6755 gfc_basic_typename (sym->ts.type));
6756 return MATCH_ERROR;
6757 }
6758 sym->ts.interface = proc_if;
6759 sym->attr.untyped = 1;
6760 sym->attr.if_source = IFSRC_IFBODY;
6761 }
6762 else if (current_ts.type != BT_UNKNOWN)
6763 {
6764 if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
6765 return MATCH_ERROR;
6766 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6767 sym->ts.interface->ts = current_ts;
6768 sym->ts.interface->attr.flavor = FL_PROCEDURE;
6769 sym->ts.interface->attr.function = 1;
6770 sym->attr.function = 1;
6771 sym->attr.if_source = IFSRC_UNKNOWN;
6772 }
6773
6774 if (gfc_match (" =>") == MATCH_YES)
6775 {
6776 if (!current_attr.pointer)
6777 {
6778 gfc_error ("Initialization at %C isn't for a pointer variable");
6779 m = MATCH_ERROR;
6780 goto cleanup;
6781 }
6782
6783 m = match_pointer_init (&initializer, 1);
6784 if (m != MATCH_YES)
6785 goto cleanup;
6786
6787 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
6788 goto cleanup;
6789
6790 }
6791
6792 if (gfc_match_eos () == MATCH_YES)
6793 return MATCH_YES;
6794 if (gfc_match_char (',') != MATCH_YES)
6795 goto syntax;
6796 }
6797
6798 syntax:
6799 gfc_error ("Syntax error in PROCEDURE statement at %C");
6800 return MATCH_ERROR;
6801
6802 cleanup:
6803 /* Free stuff up and return. */
6804 gfc_free_expr (initializer);
6805 return m;
6806 }
6807
6808
6809 static match
6810 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
6811
6812
6813 /* Match a procedure pointer component declaration (R445). */
6814
6815 static match
match_ppc_decl(void)6816 match_ppc_decl (void)
6817 {
6818 match m;
6819 gfc_symbol *proc_if = NULL;
6820 gfc_typespec ts;
6821 int num;
6822 gfc_component *c;
6823 gfc_expr *initializer = NULL;
6824 gfc_typebound_proc* tb;
6825 char name[GFC_MAX_SYMBOL_LEN + 1];
6826
6827 /* Parse interface (with brackets). */
6828 m = match_procedure_interface (&proc_if);
6829 if (m != MATCH_YES)
6830 goto syntax;
6831
6832 /* Parse attributes. */
6833 tb = XCNEW (gfc_typebound_proc);
6834 tb->where = gfc_current_locus;
6835 m = match_binding_attributes (tb, false, true);
6836 if (m == MATCH_ERROR)
6837 return m;
6838
6839 gfc_clear_attr (¤t_attr);
6840 current_attr.procedure = 1;
6841 current_attr.proc_pointer = 1;
6842 current_attr.access = tb->access;
6843 current_attr.flavor = FL_PROCEDURE;
6844
6845 /* Match the colons (required). */
6846 if (gfc_match (" ::") != MATCH_YES)
6847 {
6848 gfc_error ("Expected %<::%> after binding-attributes at %C");
6849 return MATCH_ERROR;
6850 }
6851
6852 /* Check for C450. */
6853 if (!tb->nopass && proc_if == NULL)
6854 {
6855 gfc_error("NOPASS or explicit interface required at %C");
6856 return MATCH_ERROR;
6857 }
6858
6859 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
6860 return MATCH_ERROR;
6861
6862 /* Match PPC names. */
6863 ts = current_ts;
6864 for(num=1;;num++)
6865 {
6866 m = gfc_match_name (name);
6867 if (m == MATCH_NO)
6868 goto syntax;
6869 else if (m == MATCH_ERROR)
6870 return m;
6871
6872 if (!gfc_add_component (gfc_current_block(), name, &c))
6873 return MATCH_ERROR;
6874
6875 /* Add current_attr to the symbol attributes. */
6876 if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
6877 return MATCH_ERROR;
6878
6879 if (!gfc_add_external (&c->attr, NULL))
6880 return MATCH_ERROR;
6881
6882 if (!gfc_add_proc (&c->attr, name, NULL))
6883 return MATCH_ERROR;
6884
6885 if (num == 1)
6886 c->tb = tb;
6887 else
6888 {
6889 c->tb = XCNEW (gfc_typebound_proc);
6890 c->tb->where = gfc_current_locus;
6891 *c->tb = *tb;
6892 }
6893
6894 /* Set interface. */
6895 if (proc_if != NULL)
6896 {
6897 c->ts.interface = proc_if;
6898 c->attr.untyped = 1;
6899 c->attr.if_source = IFSRC_IFBODY;
6900 }
6901 else if (ts.type != BT_UNKNOWN)
6902 {
6903 c->ts = ts;
6904 c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6905 c->ts.interface->result = c->ts.interface;
6906 c->ts.interface->ts = ts;
6907 c->ts.interface->attr.flavor = FL_PROCEDURE;
6908 c->ts.interface->attr.function = 1;
6909 c->attr.function = 1;
6910 c->attr.if_source = IFSRC_UNKNOWN;
6911 }
6912
6913 if (gfc_match (" =>") == MATCH_YES)
6914 {
6915 m = match_pointer_init (&initializer, 1);
6916 if (m != MATCH_YES)
6917 {
6918 gfc_free_expr (initializer);
6919 return m;
6920 }
6921 c->initializer = initializer;
6922 }
6923
6924 if (gfc_match_eos () == MATCH_YES)
6925 return MATCH_YES;
6926 if (gfc_match_char (',') != MATCH_YES)
6927 goto syntax;
6928 }
6929
6930 syntax:
6931 gfc_error ("Syntax error in procedure pointer component at %C");
6932 return MATCH_ERROR;
6933 }
6934
6935
6936 /* Match a PROCEDURE declaration inside an interface (R1206). */
6937
6938 static match
match_procedure_in_interface(void)6939 match_procedure_in_interface (void)
6940 {
6941 match m;
6942 gfc_symbol *sym;
6943 char name[GFC_MAX_SYMBOL_LEN + 1];
6944 locus old_locus;
6945
6946 if (current_interface.type == INTERFACE_NAMELESS
6947 || current_interface.type == INTERFACE_ABSTRACT)
6948 {
6949 gfc_error ("PROCEDURE at %C must be in a generic interface");
6950 return MATCH_ERROR;
6951 }
6952
6953 /* Check if the F2008 optional double colon appears. */
6954 gfc_gobble_whitespace ();
6955 old_locus = gfc_current_locus;
6956 if (gfc_match ("::") == MATCH_YES)
6957 {
6958 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
6959 "MODULE PROCEDURE statement at %L", &old_locus))
6960 return MATCH_ERROR;
6961 }
6962 else
6963 gfc_current_locus = old_locus;
6964
6965 for(;;)
6966 {
6967 m = gfc_match_name (name);
6968 if (m == MATCH_NO)
6969 goto syntax;
6970 else if (m == MATCH_ERROR)
6971 return m;
6972 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
6973 return MATCH_ERROR;
6974
6975 if (!gfc_add_interface (sym))
6976 return MATCH_ERROR;
6977
6978 if (gfc_match_eos () == MATCH_YES)
6979 break;
6980 if (gfc_match_char (',') != MATCH_YES)
6981 goto syntax;
6982 }
6983
6984 return MATCH_YES;
6985
6986 syntax:
6987 gfc_error ("Syntax error in PROCEDURE statement at %C");
6988 return MATCH_ERROR;
6989 }
6990
6991
6992 /* General matcher for PROCEDURE declarations. */
6993
6994 static match match_procedure_in_type (void);
6995
6996 match
gfc_match_procedure(void)6997 gfc_match_procedure (void)
6998 {
6999 match m;
7000
7001 switch (gfc_current_state ())
7002 {
7003 case COMP_NONE:
7004 case COMP_PROGRAM:
7005 case COMP_MODULE:
7006 case COMP_SUBMODULE:
7007 case COMP_SUBROUTINE:
7008 case COMP_FUNCTION:
7009 case COMP_BLOCK:
7010 m = match_procedure_decl ();
7011 break;
7012 case COMP_INTERFACE:
7013 m = match_procedure_in_interface ();
7014 break;
7015 case COMP_DERIVED:
7016 m = match_ppc_decl ();
7017 break;
7018 case COMP_DERIVED_CONTAINS:
7019 m = match_procedure_in_type ();
7020 break;
7021 default:
7022 return MATCH_NO;
7023 }
7024
7025 if (m != MATCH_YES)
7026 return m;
7027
7028 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7029 return MATCH_ERROR;
7030
7031 return m;
7032 }
7033
7034
7035 /* Warn if a matched procedure has the same name as an intrinsic; this is
7036 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7037 parser-state-stack to find out whether we're in a module. */
7038
7039 static void
do_warn_intrinsic_shadow(const gfc_symbol * sym,bool func)7040 do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7041 {
7042 bool in_module;
7043
7044 in_module = (gfc_state_stack->previous
7045 && (gfc_state_stack->previous->state == COMP_MODULE
7046 || gfc_state_stack->previous->state == COMP_SUBMODULE));
7047
7048 gfc_warn_intrinsic_shadow (sym, in_module, func);
7049 }
7050
7051
7052 /* Match a function declaration. */
7053
7054 match
gfc_match_function_decl(void)7055 gfc_match_function_decl (void)
7056 {
7057 char name[GFC_MAX_SYMBOL_LEN + 1];
7058 gfc_symbol *sym, *result;
7059 locus old_loc;
7060 match m;
7061 match suffix_match;
7062 match found_match; /* Status returned by match func. */
7063
7064 if (gfc_current_state () != COMP_NONE
7065 && gfc_current_state () != COMP_INTERFACE
7066 && gfc_current_state () != COMP_CONTAINS)
7067 return MATCH_NO;
7068
7069 gfc_clear_ts (¤t_ts);
7070
7071 old_loc = gfc_current_locus;
7072
7073 m = gfc_match_prefix (¤t_ts);
7074 if (m != MATCH_YES)
7075 {
7076 gfc_current_locus = old_loc;
7077 return m;
7078 }
7079
7080 if (gfc_match ("function% %n", name) != MATCH_YES)
7081 {
7082 gfc_current_locus = old_loc;
7083 return MATCH_NO;
7084 }
7085
7086 if (get_proc_name (name, &sym, false))
7087 return MATCH_ERROR;
7088
7089 if (add_hidden_procptr_result (sym))
7090 sym = sym->result;
7091
7092 if (current_attr.module_procedure)
7093 sym->attr.module_procedure = 1;
7094
7095 gfc_new_block = sym;
7096
7097 m = gfc_match_formal_arglist (sym, 0, 0);
7098 if (m == MATCH_NO)
7099 {
7100 gfc_error ("Expected formal argument list in function "
7101 "definition at %C");
7102 m = MATCH_ERROR;
7103 goto cleanup;
7104 }
7105 else if (m == MATCH_ERROR)
7106 goto cleanup;
7107
7108 result = NULL;
7109
7110 /* According to the draft, the bind(c) and result clause can
7111 come in either order after the formal_arg_list (i.e., either
7112 can be first, both can exist together or by themselves or neither
7113 one). Therefore, the match_result can't match the end of the
7114 string, and check for the bind(c) or result clause in either order. */
7115 found_match = gfc_match_eos ();
7116
7117 /* Make sure that it isn't already declared as BIND(C). If it is, it
7118 must have been marked BIND(C) with a BIND(C) attribute and that is
7119 not allowed for procedures. */
7120 if (sym->attr.is_bind_c == 1)
7121 {
7122 sym->attr.is_bind_c = 0;
7123 if (sym->old_symbol != NULL)
7124 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7125 "variables or common blocks",
7126 &(sym->old_symbol->declared_at));
7127 else
7128 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7129 "variables or common blocks", &gfc_current_locus);
7130 }
7131
7132 if (found_match != MATCH_YES)
7133 {
7134 /* If we haven't found the end-of-statement, look for a suffix. */
7135 suffix_match = gfc_match_suffix (sym, &result);
7136 if (suffix_match == MATCH_YES)
7137 /* Need to get the eos now. */
7138 found_match = gfc_match_eos ();
7139 else
7140 found_match = suffix_match;
7141 }
7142
7143 if(found_match != MATCH_YES)
7144 m = MATCH_ERROR;
7145 else
7146 {
7147 /* Make changes to the symbol. */
7148 m = MATCH_ERROR;
7149
7150 if (!gfc_add_function (&sym->attr, sym->name, NULL))
7151 goto cleanup;
7152
7153 if (!gfc_missing_attr (&sym->attr, NULL))
7154 goto cleanup;
7155
7156 if (!copy_prefix (&sym->attr, &sym->declared_at))
7157 {
7158 if(!sym->attr.module_procedure)
7159 goto cleanup;
7160 else
7161 gfc_error_check ();
7162 }
7163
7164 /* Delay matching the function characteristics until after the
7165 specification block by signalling kind=-1. */
7166 sym->declared_at = old_loc;
7167 if (current_ts.type != BT_UNKNOWN)
7168 current_ts.kind = -1;
7169 else
7170 current_ts.kind = 0;
7171
7172 if (result == NULL)
7173 {
7174 if (current_ts.type != BT_UNKNOWN
7175 && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7176 goto cleanup;
7177 sym->result = sym;
7178 }
7179 else
7180 {
7181 if (current_ts.type != BT_UNKNOWN
7182 && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
7183 goto cleanup;
7184 sym->result = result;
7185 }
7186
7187 /* Warn if this procedure has the same name as an intrinsic. */
7188 do_warn_intrinsic_shadow (sym, true);
7189
7190 return MATCH_YES;
7191 }
7192
7193 cleanup:
7194 gfc_current_locus = old_loc;
7195 return m;
7196 }
7197
7198
7199 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7200 pass the name of the entry, rather than the gfc_current_block name, and
7201 to return false upon finding an existing global entry. */
7202
7203 static bool
add_global_entry(const char * name,const char * binding_label,bool sub,locus * where)7204 add_global_entry (const char *name, const char *binding_label, bool sub,
7205 locus *where)
7206 {
7207 gfc_gsymbol *s;
7208 enum gfc_symbol_type type;
7209
7210 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7211
7212 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7213 name is a global identifier. */
7214 if (!binding_label || gfc_notification_std (GFC_STD_F2008))
7215 {
7216 s = gfc_get_gsymbol (name, false);
7217
7218 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7219 {
7220 gfc_global_used (s, where);
7221 return false;
7222 }
7223 else
7224 {
7225 s->type = type;
7226 s->sym_name = name;
7227 s->where = *where;
7228 s->defined = 1;
7229 s->ns = gfc_current_ns;
7230 }
7231 }
7232
7233 /* Don't add the symbol multiple times. */
7234 if (binding_label
7235 && (!gfc_notification_std (GFC_STD_F2008)
7236 || strcmp (name, binding_label) != 0))
7237 {
7238 s = gfc_get_gsymbol (binding_label, true);
7239
7240 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7241 {
7242 gfc_global_used (s, where);
7243 return false;
7244 }
7245 else
7246 {
7247 s->type = type;
7248 s->sym_name = name;
7249 s->binding_label = binding_label;
7250 s->where = *where;
7251 s->defined = 1;
7252 s->ns = gfc_current_ns;
7253 }
7254 }
7255
7256 return true;
7257 }
7258
7259
7260 /* Match an ENTRY statement. */
7261
7262 match
gfc_match_entry(void)7263 gfc_match_entry (void)
7264 {
7265 gfc_symbol *proc;
7266 gfc_symbol *result;
7267 gfc_symbol *entry;
7268 char name[GFC_MAX_SYMBOL_LEN + 1];
7269 gfc_compile_state state;
7270 match m;
7271 gfc_entry_list *el;
7272 locus old_loc;
7273 bool module_procedure;
7274 char peek_char;
7275 match is_bind_c;
7276
7277 m = gfc_match_name (name);
7278 if (m != MATCH_YES)
7279 return m;
7280
7281 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
7282 return MATCH_ERROR;
7283
7284 state = gfc_current_state ();
7285 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
7286 {
7287 switch (state)
7288 {
7289 case COMP_PROGRAM:
7290 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7291 break;
7292 case COMP_MODULE:
7293 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7294 break;
7295 case COMP_SUBMODULE:
7296 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7297 break;
7298 case COMP_BLOCK_DATA:
7299 gfc_error ("ENTRY statement at %C cannot appear within "
7300 "a BLOCK DATA");
7301 break;
7302 case COMP_INTERFACE:
7303 gfc_error ("ENTRY statement at %C cannot appear within "
7304 "an INTERFACE");
7305 break;
7306 case COMP_STRUCTURE:
7307 gfc_error ("ENTRY statement at %C cannot appear within "
7308 "a STRUCTURE block");
7309 break;
7310 case COMP_DERIVED:
7311 gfc_error ("ENTRY statement at %C cannot appear within "
7312 "a DERIVED TYPE block");
7313 break;
7314 case COMP_IF:
7315 gfc_error ("ENTRY statement at %C cannot appear within "
7316 "an IF-THEN block");
7317 break;
7318 case COMP_DO:
7319 case COMP_DO_CONCURRENT:
7320 gfc_error ("ENTRY statement at %C cannot appear within "
7321 "a DO block");
7322 break;
7323 case COMP_SELECT:
7324 gfc_error ("ENTRY statement at %C cannot appear within "
7325 "a SELECT block");
7326 break;
7327 case COMP_FORALL:
7328 gfc_error ("ENTRY statement at %C cannot appear within "
7329 "a FORALL block");
7330 break;
7331 case COMP_WHERE:
7332 gfc_error ("ENTRY statement at %C cannot appear within "
7333 "a WHERE block");
7334 break;
7335 case COMP_CONTAINS:
7336 gfc_error ("ENTRY statement at %C cannot appear within "
7337 "a contained subprogram");
7338 break;
7339 default:
7340 gfc_error ("Unexpected ENTRY statement at %C");
7341 }
7342 return MATCH_ERROR;
7343 }
7344
7345 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
7346 && gfc_state_stack->previous->state == COMP_INTERFACE)
7347 {
7348 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7349 return MATCH_ERROR;
7350 }
7351
7352 module_procedure = gfc_current_ns->parent != NULL
7353 && gfc_current_ns->parent->proc_name
7354 && gfc_current_ns->parent->proc_name->attr.flavor
7355 == FL_MODULE;
7356
7357 if (gfc_current_ns->parent != NULL
7358 && gfc_current_ns->parent->proc_name
7359 && !module_procedure)
7360 {
7361 gfc_error("ENTRY statement at %C cannot appear in a "
7362 "contained procedure");
7363 return MATCH_ERROR;
7364 }
7365
7366 /* Module function entries need special care in get_proc_name
7367 because previous references within the function will have
7368 created symbols attached to the current namespace. */
7369 if (get_proc_name (name, &entry,
7370 gfc_current_ns->parent != NULL
7371 && module_procedure))
7372 return MATCH_ERROR;
7373
7374 proc = gfc_current_block ();
7375
7376 /* Make sure that it isn't already declared as BIND(C). If it is, it
7377 must have been marked BIND(C) with a BIND(C) attribute and that is
7378 not allowed for procedures. */
7379 if (entry->attr.is_bind_c == 1)
7380 {
7381 entry->attr.is_bind_c = 0;
7382 if (entry->old_symbol != NULL)
7383 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7384 "variables or common blocks",
7385 &(entry->old_symbol->declared_at));
7386 else
7387 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7388 "variables or common blocks", &gfc_current_locus);
7389 }
7390
7391 /* Check what next non-whitespace character is so we can tell if there
7392 is the required parens if we have a BIND(C). */
7393 old_loc = gfc_current_locus;
7394 gfc_gobble_whitespace ();
7395 peek_char = gfc_peek_ascii_char ();
7396
7397 if (state == COMP_SUBROUTINE)
7398 {
7399 m = gfc_match_formal_arglist (entry, 0, 1);
7400 if (m != MATCH_YES)
7401 return MATCH_ERROR;
7402
7403 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7404 never be an internal procedure. */
7405 is_bind_c = gfc_match_bind_c (entry, true);
7406 if (is_bind_c == MATCH_ERROR)
7407 return MATCH_ERROR;
7408 if (is_bind_c == MATCH_YES)
7409 {
7410 if (peek_char != '(')
7411 {
7412 gfc_error ("Missing required parentheses before BIND(C) at %C");
7413 return MATCH_ERROR;
7414 }
7415
7416 if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
7417 &(entry->declared_at), 1))
7418 return MATCH_ERROR;
7419
7420 }
7421
7422 if (!gfc_current_ns->parent
7423 && !add_global_entry (name, entry->binding_label, true,
7424 &old_loc))
7425 return MATCH_ERROR;
7426
7427 /* An entry in a subroutine. */
7428 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7429 || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
7430 return MATCH_ERROR;
7431 }
7432 else
7433 {
7434 /* An entry in a function.
7435 We need to take special care because writing
7436 ENTRY f()
7437 as
7438 ENTRY f
7439 is allowed, whereas
7440 ENTRY f() RESULT (r)
7441 can't be written as
7442 ENTRY f RESULT (r). */
7443 if (gfc_match_eos () == MATCH_YES)
7444 {
7445 gfc_current_locus = old_loc;
7446 /* Match the empty argument list, and add the interface to
7447 the symbol. */
7448 m = gfc_match_formal_arglist (entry, 0, 1);
7449 }
7450 else
7451 m = gfc_match_formal_arglist (entry, 0, 0);
7452
7453 if (m != MATCH_YES)
7454 return MATCH_ERROR;
7455
7456 result = NULL;
7457
7458 if (gfc_match_eos () == MATCH_YES)
7459 {
7460 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7461 || !gfc_add_function (&entry->attr, entry->name, NULL))
7462 return MATCH_ERROR;
7463
7464 entry->result = entry;
7465 }
7466 else
7467 {
7468 m = gfc_match_suffix (entry, &result);
7469 if (m == MATCH_NO)
7470 gfc_syntax_error (ST_ENTRY);
7471 if (m != MATCH_YES)
7472 return MATCH_ERROR;
7473
7474 if (result)
7475 {
7476 if (!gfc_add_result (&result->attr, result->name, NULL)
7477 || !gfc_add_entry (&entry->attr, result->name, NULL)
7478 || !gfc_add_function (&entry->attr, result->name, NULL))
7479 return MATCH_ERROR;
7480 entry->result = result;
7481 }
7482 else
7483 {
7484 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7485 || !gfc_add_function (&entry->attr, entry->name, NULL))
7486 return MATCH_ERROR;
7487 entry->result = entry;
7488 }
7489 }
7490
7491 if (!gfc_current_ns->parent
7492 && !add_global_entry (name, entry->binding_label, false,
7493 &old_loc))
7494 return MATCH_ERROR;
7495 }
7496
7497 if (gfc_match_eos () != MATCH_YES)
7498 {
7499 gfc_syntax_error (ST_ENTRY);
7500 return MATCH_ERROR;
7501 }
7502
7503 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7504 if (proc->attr.elemental && entry->attr.is_bind_c)
7505 {
7506 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7507 "elemental procedure", &entry->declared_at);
7508 return MATCH_ERROR;
7509 }
7510
7511 entry->attr.recursive = proc->attr.recursive;
7512 entry->attr.elemental = proc->attr.elemental;
7513 entry->attr.pure = proc->attr.pure;
7514
7515 el = gfc_get_entry_list ();
7516 el->sym = entry;
7517 el->next = gfc_current_ns->entries;
7518 gfc_current_ns->entries = el;
7519 if (el->next)
7520 el->id = el->next->id + 1;
7521 else
7522 el->id = 1;
7523
7524 new_st.op = EXEC_ENTRY;
7525 new_st.ext.entry = el;
7526
7527 return MATCH_YES;
7528 }
7529
7530
7531 /* Match a subroutine statement, including optional prefixes. */
7532
7533 match
gfc_match_subroutine(void)7534 gfc_match_subroutine (void)
7535 {
7536 char name[GFC_MAX_SYMBOL_LEN + 1];
7537 gfc_symbol *sym;
7538 match m;
7539 match is_bind_c;
7540 char peek_char;
7541 bool allow_binding_name;
7542
7543 if (gfc_current_state () != COMP_NONE
7544 && gfc_current_state () != COMP_INTERFACE
7545 && gfc_current_state () != COMP_CONTAINS)
7546 return MATCH_NO;
7547
7548 m = gfc_match_prefix (NULL);
7549 if (m != MATCH_YES)
7550 return m;
7551
7552 m = gfc_match ("subroutine% %n", name);
7553 if (m != MATCH_YES)
7554 return m;
7555
7556 if (get_proc_name (name, &sym, false))
7557 return MATCH_ERROR;
7558
7559 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7560 the symbol existed before. */
7561 sym->declared_at = gfc_current_locus;
7562
7563 if (current_attr.module_procedure)
7564 sym->attr.module_procedure = 1;
7565
7566 if (add_hidden_procptr_result (sym))
7567 sym = sym->result;
7568
7569 gfc_new_block = sym;
7570
7571 /* Check what next non-whitespace character is so we can tell if there
7572 is the required parens if we have a BIND(C). */
7573 gfc_gobble_whitespace ();
7574 peek_char = gfc_peek_ascii_char ();
7575
7576 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
7577 return MATCH_ERROR;
7578
7579 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
7580 return MATCH_ERROR;
7581
7582 /* Make sure that it isn't already declared as BIND(C). If it is, it
7583 must have been marked BIND(C) with a BIND(C) attribute and that is
7584 not allowed for procedures. */
7585 if (sym->attr.is_bind_c == 1)
7586 {
7587 sym->attr.is_bind_c = 0;
7588 if (sym->old_symbol != NULL)
7589 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7590 "variables or common blocks",
7591 &(sym->old_symbol->declared_at));
7592 else
7593 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7594 "variables or common blocks", &gfc_current_locus);
7595 }
7596
7597 /* C binding names are not allowed for internal procedures. */
7598 if (gfc_current_state () == COMP_CONTAINS
7599 && sym->ns->proc_name->attr.flavor != FL_MODULE)
7600 allow_binding_name = false;
7601 else
7602 allow_binding_name = true;
7603
7604 /* Here, we are just checking if it has the bind(c) attribute, and if
7605 so, then we need to make sure it's all correct. If it doesn't,
7606 we still need to continue matching the rest of the subroutine line. */
7607 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7608 if (is_bind_c == MATCH_ERROR)
7609 {
7610 /* There was an attempt at the bind(c), but it was wrong. An
7611 error message should have been printed w/in the gfc_match_bind_c
7612 so here we'll just return the MATCH_ERROR. */
7613 return MATCH_ERROR;
7614 }
7615
7616 if (is_bind_c == MATCH_YES)
7617 {
7618 /* The following is allowed in the Fortran 2008 draft. */
7619 if (gfc_current_state () == COMP_CONTAINS
7620 && sym->ns->proc_name->attr.flavor != FL_MODULE
7621 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7622 "at %L may not be specified for an internal "
7623 "procedure", &gfc_current_locus))
7624 return MATCH_ERROR;
7625
7626 if (peek_char != '(')
7627 {
7628 gfc_error ("Missing required parentheses before BIND(C) at %C");
7629 return MATCH_ERROR;
7630 }
7631 if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
7632 &(sym->declared_at), 1))
7633 return MATCH_ERROR;
7634 }
7635
7636 if (gfc_match_eos () != MATCH_YES)
7637 {
7638 gfc_syntax_error (ST_SUBROUTINE);
7639 return MATCH_ERROR;
7640 }
7641
7642 if (!copy_prefix (&sym->attr, &sym->declared_at))
7643 {
7644 if(!sym->attr.module_procedure)
7645 return MATCH_ERROR;
7646 else
7647 gfc_error_check ();
7648 }
7649
7650 /* Warn if it has the same name as an intrinsic. */
7651 do_warn_intrinsic_shadow (sym, false);
7652
7653 return MATCH_YES;
7654 }
7655
7656
7657 /* Check that the NAME identifier in a BIND attribute or statement
7658 is conform to C identifier rules. */
7659
7660 match
check_bind_name_identifier(char ** name)7661 check_bind_name_identifier (char **name)
7662 {
7663 char *n = *name, *p;
7664
7665 /* Remove leading spaces. */
7666 while (*n == ' ')
7667 n++;
7668
7669 /* On an empty string, free memory and set name to NULL. */
7670 if (*n == '\0')
7671 {
7672 free (*name);
7673 *name = NULL;
7674 return MATCH_YES;
7675 }
7676
7677 /* Remove trailing spaces. */
7678 p = n + strlen(n) - 1;
7679 while (*p == ' ')
7680 *(p--) = '\0';
7681
7682 /* Insert the identifier into the symbol table. */
7683 p = xstrdup (n);
7684 free (*name);
7685 *name = p;
7686
7687 /* Now check that identifier is valid under C rules. */
7688 if (ISDIGIT (*p))
7689 {
7690 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7691 return MATCH_ERROR;
7692 }
7693
7694 for (; *p; p++)
7695 if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
7696 {
7697 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7698 return MATCH_ERROR;
7699 }
7700
7701 return MATCH_YES;
7702 }
7703
7704
7705 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7706 given, and set the binding label in either the given symbol (if not
7707 NULL), or in the current_ts. The symbol may be NULL because we may
7708 encounter the BIND(C) before the declaration itself. Return
7709 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7710 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7711 or MATCH_YES if the specifier was correct and the binding label and
7712 bind(c) fields were set correctly for the given symbol or the
7713 current_ts. If allow_binding_name is false, no binding name may be
7714 given. */
7715
7716 match
gfc_match_bind_c(gfc_symbol * sym,bool allow_binding_name)7717 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
7718 {
7719 char *binding_label = NULL;
7720 gfc_expr *e = NULL;
7721
7722 /* Initialize the flag that specifies whether we encountered a NAME=
7723 specifier or not. */
7724 has_name_equals = 0;
7725
7726 /* This much we have to be able to match, in this order, if
7727 there is a bind(c) label. */
7728 if (gfc_match (" bind ( c ") != MATCH_YES)
7729 return MATCH_NO;
7730
7731 /* Now see if there is a binding label, or if we've reached the
7732 end of the bind(c) attribute without one. */
7733 if (gfc_match_char (',') == MATCH_YES)
7734 {
7735 if (gfc_match (" name = ") != MATCH_YES)
7736 {
7737 gfc_error ("Syntax error in NAME= specifier for binding label "
7738 "at %C");
7739 /* should give an error message here */
7740 return MATCH_ERROR;
7741 }
7742
7743 has_name_equals = 1;
7744
7745 if (gfc_match_init_expr (&e) != MATCH_YES)
7746 {
7747 gfc_free_expr (e);
7748 return MATCH_ERROR;
7749 }
7750
7751 if (!gfc_simplify_expr(e, 0))
7752 {
7753 gfc_error ("NAME= specifier at %C should be a constant expression");
7754 gfc_free_expr (e);
7755 return MATCH_ERROR;
7756 }
7757
7758 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
7759 || e->ts.kind != gfc_default_character_kind || e->rank != 0)
7760 {
7761 gfc_error ("NAME= specifier at %C should be a scalar of "
7762 "default character kind");
7763 gfc_free_expr(e);
7764 return MATCH_ERROR;
7765 }
7766
7767 // Get a C string from the Fortran string constant
7768 binding_label = gfc_widechar_to_char (e->value.character.string,
7769 e->value.character.length);
7770 gfc_free_expr(e);
7771
7772 // Check that it is valid (old gfc_match_name_C)
7773 if (check_bind_name_identifier (&binding_label) != MATCH_YES)
7774 return MATCH_ERROR;
7775 }
7776
7777 /* Get the required right paren. */
7778 if (gfc_match_char (')') != MATCH_YES)
7779 {
7780 gfc_error ("Missing closing paren for binding label at %C");
7781 return MATCH_ERROR;
7782 }
7783
7784 if (has_name_equals && !allow_binding_name)
7785 {
7786 gfc_error ("No binding name is allowed in BIND(C) at %C");
7787 return MATCH_ERROR;
7788 }
7789
7790 if (has_name_equals && sym != NULL && sym->attr.dummy)
7791 {
7792 gfc_error ("For dummy procedure %s, no binding name is "
7793 "allowed in BIND(C) at %C", sym->name);
7794 return MATCH_ERROR;
7795 }
7796
7797
7798 /* Save the binding label to the symbol. If sym is null, we're
7799 probably matching the typespec attributes of a declaration and
7800 haven't gotten the name yet, and therefore, no symbol yet. */
7801 if (binding_label)
7802 {
7803 if (sym != NULL)
7804 sym->binding_label = binding_label;
7805 else
7806 curr_binding_label = binding_label;
7807 }
7808 else if (allow_binding_name)
7809 {
7810 /* No binding label, but if symbol isn't null, we
7811 can set the label for it here.
7812 If name="" or allow_binding_name is false, no C binding name is
7813 created. */
7814 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
7815 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
7816 }
7817
7818 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
7819 && current_interface.type == INTERFACE_ABSTRACT)
7820 {
7821 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7822 return MATCH_ERROR;
7823 }
7824
7825 return MATCH_YES;
7826 }
7827
7828
7829 /* Return nonzero if we're currently compiling a contained procedure. */
7830
7831 static int
contained_procedure(void)7832 contained_procedure (void)
7833 {
7834 gfc_state_data *s = gfc_state_stack;
7835
7836 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
7837 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
7838 return 1;
7839
7840 return 0;
7841 }
7842
7843 /* Set the kind of each enumerator. The kind is selected such that it is
7844 interoperable with the corresponding C enumeration type, making
7845 sure that -fshort-enums is honored. */
7846
7847 static void
set_enum_kind(void)7848 set_enum_kind(void)
7849 {
7850 enumerator_history *current_history = NULL;
7851 int kind;
7852 int i;
7853
7854 if (max_enum == NULL || enum_history == NULL)
7855 return;
7856
7857 if (!flag_short_enums)
7858 return;
7859
7860 i = 0;
7861 do
7862 {
7863 kind = gfc_integer_kinds[i++].kind;
7864 }
7865 while (kind < gfc_c_int_kind
7866 && gfc_check_integer_range (max_enum->initializer->value.integer,
7867 kind) != ARITH_OK);
7868
7869 current_history = enum_history;
7870 while (current_history != NULL)
7871 {
7872 current_history->sym->ts.kind = kind;
7873 current_history = current_history->next;
7874 }
7875 }
7876
7877
7878 /* Match any of the various end-block statements. Returns the type of
7879 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7880 and END BLOCK statements cannot be replaced by a single END statement. */
7881
7882 match
gfc_match_end(gfc_statement * st)7883 gfc_match_end (gfc_statement *st)
7884 {
7885 char name[GFC_MAX_SYMBOL_LEN + 1];
7886 gfc_compile_state state;
7887 locus old_loc;
7888 const char *block_name;
7889 const char *target;
7890 int eos_ok;
7891 match m;
7892 gfc_namespace *parent_ns, *ns, *prev_ns;
7893 gfc_namespace **nsp;
7894 bool abreviated_modproc_decl = false;
7895 bool got_matching_end = false;
7896
7897 old_loc = gfc_current_locus;
7898 if (gfc_match ("end") != MATCH_YES)
7899 return MATCH_NO;
7900
7901 state = gfc_current_state ();
7902 block_name = gfc_current_block () == NULL
7903 ? NULL : gfc_current_block ()->name;
7904
7905 switch (state)
7906 {
7907 case COMP_ASSOCIATE:
7908 case COMP_BLOCK:
7909 if (!strncmp (block_name, "block@", strlen("block@")))
7910 block_name = NULL;
7911 break;
7912
7913 case COMP_CONTAINS:
7914 case COMP_DERIVED_CONTAINS:
7915 state = gfc_state_stack->previous->state;
7916 block_name = gfc_state_stack->previous->sym == NULL
7917 ? NULL : gfc_state_stack->previous->sym->name;
7918 abreviated_modproc_decl = gfc_state_stack->previous->sym
7919 && gfc_state_stack->previous->sym->abr_modproc_decl;
7920 break;
7921
7922 default:
7923 break;
7924 }
7925
7926 if (!abreviated_modproc_decl)
7927 abreviated_modproc_decl = gfc_current_block ()
7928 && gfc_current_block ()->abr_modproc_decl;
7929
7930 switch (state)
7931 {
7932 case COMP_NONE:
7933 case COMP_PROGRAM:
7934 *st = ST_END_PROGRAM;
7935 target = " program";
7936 eos_ok = 1;
7937 break;
7938
7939 case COMP_SUBROUTINE:
7940 *st = ST_END_SUBROUTINE;
7941 if (!abreviated_modproc_decl)
7942 target = " subroutine";
7943 else
7944 target = " procedure";
7945 eos_ok = !contained_procedure ();
7946 break;
7947
7948 case COMP_FUNCTION:
7949 *st = ST_END_FUNCTION;
7950 if (!abreviated_modproc_decl)
7951 target = " function";
7952 else
7953 target = " procedure";
7954 eos_ok = !contained_procedure ();
7955 break;
7956
7957 case COMP_BLOCK_DATA:
7958 *st = ST_END_BLOCK_DATA;
7959 target = " block data";
7960 eos_ok = 1;
7961 break;
7962
7963 case COMP_MODULE:
7964 *st = ST_END_MODULE;
7965 target = " module";
7966 eos_ok = 1;
7967 break;
7968
7969 case COMP_SUBMODULE:
7970 *st = ST_END_SUBMODULE;
7971 target = " submodule";
7972 eos_ok = 1;
7973 break;
7974
7975 case COMP_INTERFACE:
7976 *st = ST_END_INTERFACE;
7977 target = " interface";
7978 eos_ok = 0;
7979 break;
7980
7981 case COMP_MAP:
7982 *st = ST_END_MAP;
7983 target = " map";
7984 eos_ok = 0;
7985 break;
7986
7987 case COMP_UNION:
7988 *st = ST_END_UNION;
7989 target = " union";
7990 eos_ok = 0;
7991 break;
7992
7993 case COMP_STRUCTURE:
7994 *st = ST_END_STRUCTURE;
7995 target = " structure";
7996 eos_ok = 0;
7997 break;
7998
7999 case COMP_DERIVED:
8000 case COMP_DERIVED_CONTAINS:
8001 *st = ST_END_TYPE;
8002 target = " type";
8003 eos_ok = 0;
8004 break;
8005
8006 case COMP_ASSOCIATE:
8007 *st = ST_END_ASSOCIATE;
8008 target = " associate";
8009 eos_ok = 0;
8010 break;
8011
8012 case COMP_BLOCK:
8013 *st = ST_END_BLOCK;
8014 target = " block";
8015 eos_ok = 0;
8016 break;
8017
8018 case COMP_IF:
8019 *st = ST_ENDIF;
8020 target = " if";
8021 eos_ok = 0;
8022 break;
8023
8024 case COMP_DO:
8025 case COMP_DO_CONCURRENT:
8026 *st = ST_ENDDO;
8027 target = " do";
8028 eos_ok = 0;
8029 break;
8030
8031 case COMP_CRITICAL:
8032 *st = ST_END_CRITICAL;
8033 target = " critical";
8034 eos_ok = 0;
8035 break;
8036
8037 case COMP_SELECT:
8038 case COMP_SELECT_TYPE:
8039 *st = ST_END_SELECT;
8040 target = " select";
8041 eos_ok = 0;
8042 break;
8043
8044 case COMP_FORALL:
8045 *st = ST_END_FORALL;
8046 target = " forall";
8047 eos_ok = 0;
8048 break;
8049
8050 case COMP_WHERE:
8051 *st = ST_END_WHERE;
8052 target = " where";
8053 eos_ok = 0;
8054 break;
8055
8056 case COMP_ENUM:
8057 *st = ST_END_ENUM;
8058 target = " enum";
8059 eos_ok = 0;
8060 last_initializer = NULL;
8061 set_enum_kind ();
8062 gfc_free_enum_history ();
8063 break;
8064
8065 default:
8066 gfc_error ("Unexpected END statement at %C");
8067 goto cleanup;
8068 }
8069
8070 old_loc = gfc_current_locus;
8071 if (gfc_match_eos () == MATCH_YES)
8072 {
8073 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
8074 {
8075 if (!gfc_notify_std (GFC_STD_F2008, "END statement "
8076 "instead of %s statement at %L",
8077 abreviated_modproc_decl ? "END PROCEDURE"
8078 : gfc_ascii_statement(*st), &old_loc))
8079 goto cleanup;
8080 }
8081 else if (!eos_ok)
8082 {
8083 /* We would have required END [something]. */
8084 gfc_error ("%s statement expected at %L",
8085 gfc_ascii_statement (*st), &old_loc);
8086 goto cleanup;
8087 }
8088
8089 return MATCH_YES;
8090 }
8091
8092 /* Verify that we've got the sort of end-block that we're expecting. */
8093 if (gfc_match (target) != MATCH_YES)
8094 {
8095 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8096 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
8097 goto cleanup;
8098 }
8099 else
8100 got_matching_end = true;
8101
8102 old_loc = gfc_current_locus;
8103 /* If we're at the end, make sure a block name wasn't required. */
8104 if (gfc_match_eos () == MATCH_YES)
8105 {
8106
8107 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
8108 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
8109 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
8110 return MATCH_YES;
8111
8112 if (!block_name)
8113 return MATCH_YES;
8114
8115 gfc_error ("Expected block name of %qs in %s statement at %L",
8116 block_name, gfc_ascii_statement (*st), &old_loc);
8117
8118 return MATCH_ERROR;
8119 }
8120
8121 /* END INTERFACE has a special handler for its several possible endings. */
8122 if (*st == ST_END_INTERFACE)
8123 return gfc_match_end_interface ();
8124
8125 /* We haven't hit the end of statement, so what is left must be an
8126 end-name. */
8127 m = gfc_match_space ();
8128 if (m == MATCH_YES)
8129 m = gfc_match_name (name);
8130
8131 if (m == MATCH_NO)
8132 gfc_error ("Expected terminating name at %C");
8133 if (m != MATCH_YES)
8134 goto cleanup;
8135
8136 if (block_name == NULL)
8137 goto syntax;
8138
8139 /* We have to pick out the declared submodule name from the composite
8140 required by F2008:11.2.3 para 2, which ends in the declared name. */
8141 if (state == COMP_SUBMODULE)
8142 block_name = strchr (block_name, '.') + 1;
8143
8144 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
8145 {
8146 gfc_error ("Expected label %qs for %s statement at %C", block_name,
8147 gfc_ascii_statement (*st));
8148 goto cleanup;
8149 }
8150 /* Procedure pointer as function result. */
8151 else if (strcmp (block_name, "ppr@") == 0
8152 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
8153 {
8154 gfc_error ("Expected label %qs for %s statement at %C",
8155 gfc_current_block ()->ns->proc_name->name,
8156 gfc_ascii_statement (*st));
8157 goto cleanup;
8158 }
8159
8160 if (gfc_match_eos () == MATCH_YES)
8161 return MATCH_YES;
8162
8163 syntax:
8164 gfc_syntax_error (*st);
8165
8166 cleanup:
8167 gfc_current_locus = old_loc;
8168
8169 /* If we are missing an END BLOCK, we created a half-ready namespace.
8170 Remove it from the parent namespace's sibling list. */
8171
8172 while (state == COMP_BLOCK && !got_matching_end)
8173 {
8174 parent_ns = gfc_current_ns->parent;
8175
8176 nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
8177
8178 prev_ns = NULL;
8179 ns = *nsp;
8180 while (ns)
8181 {
8182 if (ns == gfc_current_ns)
8183 {
8184 if (prev_ns == NULL)
8185 *nsp = NULL;
8186 else
8187 prev_ns->sibling = ns->sibling;
8188 }
8189 prev_ns = ns;
8190 ns = ns->sibling;
8191 }
8192
8193 gfc_free_namespace (gfc_current_ns);
8194 gfc_current_ns = parent_ns;
8195 gfc_state_stack = gfc_state_stack->previous;
8196 state = gfc_current_state ();
8197 }
8198
8199 return MATCH_ERROR;
8200 }
8201
8202
8203
8204 /***************** Attribute declaration statements ****************/
8205
8206 /* Set the attribute of a single variable. */
8207
8208 static match
attr_decl1(void)8209 attr_decl1 (void)
8210 {
8211 char name[GFC_MAX_SYMBOL_LEN + 1];
8212 gfc_array_spec *as;
8213
8214 /* Workaround -Wmaybe-uninitialized false positive during
8215 profiledbootstrap by initializing them. */
8216 gfc_symbol *sym = NULL;
8217 locus var_locus;
8218 match m;
8219
8220 as = NULL;
8221
8222 m = gfc_match_name (name);
8223 if (m != MATCH_YES)
8224 goto cleanup;
8225
8226 if (find_special (name, &sym, false))
8227 return MATCH_ERROR;
8228
8229 if (!check_function_name (name))
8230 {
8231 m = MATCH_ERROR;
8232 goto cleanup;
8233 }
8234
8235 var_locus = gfc_current_locus;
8236
8237 /* Deal with possible array specification for certain attributes. */
8238 if (current_attr.dimension
8239 || current_attr.codimension
8240 || current_attr.allocatable
8241 || current_attr.pointer
8242 || current_attr.target)
8243 {
8244 m = gfc_match_array_spec (&as, !current_attr.codimension,
8245 !current_attr.dimension
8246 && !current_attr.pointer
8247 && !current_attr.target);
8248 if (m == MATCH_ERROR)
8249 goto cleanup;
8250
8251 if (current_attr.dimension && m == MATCH_NO)
8252 {
8253 gfc_error ("Missing array specification at %L in DIMENSION "
8254 "statement", &var_locus);
8255 m = MATCH_ERROR;
8256 goto cleanup;
8257 }
8258
8259 if (current_attr.dimension && sym->value)
8260 {
8261 gfc_error ("Dimensions specified for %s at %L after its "
8262 "initialization", sym->name, &var_locus);
8263 m = MATCH_ERROR;
8264 goto cleanup;
8265 }
8266
8267 if (current_attr.codimension && m == MATCH_NO)
8268 {
8269 gfc_error ("Missing array specification at %L in CODIMENSION "
8270 "statement", &var_locus);
8271 m = MATCH_ERROR;
8272 goto cleanup;
8273 }
8274
8275 if ((current_attr.allocatable || current_attr.pointer)
8276 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
8277 {
8278 gfc_error ("Array specification must be deferred at %L", &var_locus);
8279 m = MATCH_ERROR;
8280 goto cleanup;
8281 }
8282 }
8283
8284 /* Update symbol table. DIMENSION attribute is set in
8285 gfc_set_array_spec(). For CLASS variables, this must be applied
8286 to the first component, or '_data' field. */
8287 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
8288 {
8289 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus))
8290 {
8291 m = MATCH_ERROR;
8292 goto cleanup;
8293 }
8294 }
8295 else
8296 {
8297 if (current_attr.dimension == 0 && current_attr.codimension == 0
8298 && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
8299 {
8300 m = MATCH_ERROR;
8301 goto cleanup;
8302 }
8303 }
8304
8305 if (sym->ts.type == BT_CLASS
8306 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
8307 {
8308 m = MATCH_ERROR;
8309 goto cleanup;
8310 }
8311
8312 if (!gfc_set_array_spec (sym, as, &var_locus))
8313 {
8314 m = MATCH_ERROR;
8315 goto cleanup;
8316 }
8317
8318 if (sym->attr.cray_pointee && sym->as != NULL)
8319 {
8320 /* Fix the array spec. */
8321 m = gfc_mod_pointee_as (sym->as);
8322 if (m == MATCH_ERROR)
8323 goto cleanup;
8324 }
8325
8326 if (!gfc_add_attribute (&sym->attr, &var_locus))
8327 {
8328 m = MATCH_ERROR;
8329 goto cleanup;
8330 }
8331
8332 if ((current_attr.external || current_attr.intrinsic)
8333 && sym->attr.flavor != FL_PROCEDURE
8334 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
8335 {
8336 m = MATCH_ERROR;
8337 goto cleanup;
8338 }
8339
8340 add_hidden_procptr_result (sym);
8341
8342 return MATCH_YES;
8343
8344 cleanup:
8345 gfc_free_array_spec (as);
8346 return m;
8347 }
8348
8349
8350 /* Generic attribute declaration subroutine. Used for attributes that
8351 just have a list of names. */
8352
8353 static match
attr_decl(void)8354 attr_decl (void)
8355 {
8356 match m;
8357
8358 /* Gobble the optional double colon, by simply ignoring the result
8359 of gfc_match(). */
8360 gfc_match (" ::");
8361
8362 for (;;)
8363 {
8364 m = attr_decl1 ();
8365 if (m != MATCH_YES)
8366 break;
8367
8368 if (gfc_match_eos () == MATCH_YES)
8369 {
8370 m = MATCH_YES;
8371 break;
8372 }
8373
8374 if (gfc_match_char (',') != MATCH_YES)
8375 {
8376 gfc_error ("Unexpected character in variable list at %C");
8377 m = MATCH_ERROR;
8378 break;
8379 }
8380 }
8381
8382 return m;
8383 }
8384
8385
8386 /* This routine matches Cray Pointer declarations of the form:
8387 pointer ( <pointer>, <pointee> )
8388 or
8389 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8390 The pointer, if already declared, should be an integer. Otherwise, we
8391 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8392 be either a scalar, or an array declaration. No space is allocated for
8393 the pointee. For the statement
8394 pointer (ipt, ar(10))
8395 any subsequent uses of ar will be translated (in C-notation) as
8396 ar(i) => ((<type> *) ipt)(i)
8397 After gimplification, pointee variable will disappear in the code. */
8398
8399 static match
cray_pointer_decl(void)8400 cray_pointer_decl (void)
8401 {
8402 match m;
8403 gfc_array_spec *as = NULL;
8404 gfc_symbol *cptr; /* Pointer symbol. */
8405 gfc_symbol *cpte; /* Pointee symbol. */
8406 locus var_locus;
8407 bool done = false;
8408
8409 while (!done)
8410 {
8411 if (gfc_match_char ('(') != MATCH_YES)
8412 {
8413 gfc_error ("Expected %<(%> at %C");
8414 return MATCH_ERROR;
8415 }
8416
8417 /* Match pointer. */
8418 var_locus = gfc_current_locus;
8419 gfc_clear_attr (¤t_attr);
8420 gfc_add_cray_pointer (¤t_attr, &var_locus);
8421 current_ts.type = BT_INTEGER;
8422 current_ts.kind = gfc_index_integer_kind;
8423
8424 m = gfc_match_symbol (&cptr, 0);
8425 if (m != MATCH_YES)
8426 {
8427 gfc_error ("Expected variable name at %C");
8428 return m;
8429 }
8430
8431 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
8432 return MATCH_ERROR;
8433
8434 gfc_set_sym_referenced (cptr);
8435
8436 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
8437 {
8438 cptr->ts.type = BT_INTEGER;
8439 cptr->ts.kind = gfc_index_integer_kind;
8440 }
8441 else if (cptr->ts.type != BT_INTEGER)
8442 {
8443 gfc_error ("Cray pointer at %C must be an integer");
8444 return MATCH_ERROR;
8445 }
8446 else if (cptr->ts.kind < gfc_index_integer_kind)
8447 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8448 " memory addresses require %d bytes",
8449 cptr->ts.kind, gfc_index_integer_kind);
8450
8451 if (gfc_match_char (',') != MATCH_YES)
8452 {
8453 gfc_error ("Expected \",\" at %C");
8454 return MATCH_ERROR;
8455 }
8456
8457 /* Match Pointee. */
8458 var_locus = gfc_current_locus;
8459 gfc_clear_attr (¤t_attr);
8460 gfc_add_cray_pointee (¤t_attr, &var_locus);
8461 current_ts.type = BT_UNKNOWN;
8462 current_ts.kind = 0;
8463
8464 m = gfc_match_symbol (&cpte, 0);
8465 if (m != MATCH_YES)
8466 {
8467 gfc_error ("Expected variable name at %C");
8468 return m;
8469 }
8470
8471 /* Check for an optional array spec. */
8472 m = gfc_match_array_spec (&as, true, false);
8473 if (m == MATCH_ERROR)
8474 {
8475 gfc_free_array_spec (as);
8476 return m;
8477 }
8478 else if (m == MATCH_NO)
8479 {
8480 gfc_free_array_spec (as);
8481 as = NULL;
8482 }
8483
8484 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
8485 return MATCH_ERROR;
8486
8487 gfc_set_sym_referenced (cpte);
8488
8489 if (cpte->as == NULL)
8490 {
8491 if (!gfc_set_array_spec (cpte, as, &var_locus))
8492 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8493 }
8494 else if (as != NULL)
8495 {
8496 gfc_error ("Duplicate array spec for Cray pointee at %C");
8497 gfc_free_array_spec (as);
8498 return MATCH_ERROR;
8499 }
8500
8501 as = NULL;
8502
8503 if (cpte->as != NULL)
8504 {
8505 /* Fix array spec. */
8506 m = gfc_mod_pointee_as (cpte->as);
8507 if (m == MATCH_ERROR)
8508 return m;
8509 }
8510
8511 /* Point the Pointee at the Pointer. */
8512 cpte->cp_pointer = cptr;
8513
8514 if (gfc_match_char (')') != MATCH_YES)
8515 {
8516 gfc_error ("Expected \")\" at %C");
8517 return MATCH_ERROR;
8518 }
8519 m = gfc_match_char (',');
8520 if (m != MATCH_YES)
8521 done = true; /* Stop searching for more declarations. */
8522
8523 }
8524
8525 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
8526 || gfc_match_eos () != MATCH_YES)
8527 {
8528 gfc_error ("Expected %<,%> or end of statement at %C");
8529 return MATCH_ERROR;
8530 }
8531 return MATCH_YES;
8532 }
8533
8534
8535 match
gfc_match_external(void)8536 gfc_match_external (void)
8537 {
8538
8539 gfc_clear_attr (¤t_attr);
8540 current_attr.external = 1;
8541
8542 return attr_decl ();
8543 }
8544
8545
8546 match
gfc_match_intent(void)8547 gfc_match_intent (void)
8548 {
8549 sym_intent intent;
8550
8551 /* This is not allowed within a BLOCK construct! */
8552 if (gfc_current_state () == COMP_BLOCK)
8553 {
8554 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8555 return MATCH_ERROR;
8556 }
8557
8558 intent = match_intent_spec ();
8559 if (intent == INTENT_UNKNOWN)
8560 return MATCH_ERROR;
8561
8562 gfc_clear_attr (¤t_attr);
8563 current_attr.intent = intent;
8564
8565 return attr_decl ();
8566 }
8567
8568
8569 match
gfc_match_intrinsic(void)8570 gfc_match_intrinsic (void)
8571 {
8572
8573 gfc_clear_attr (¤t_attr);
8574 current_attr.intrinsic = 1;
8575
8576 return attr_decl ();
8577 }
8578
8579
8580 match
gfc_match_optional(void)8581 gfc_match_optional (void)
8582 {
8583 /* This is not allowed within a BLOCK construct! */
8584 if (gfc_current_state () == COMP_BLOCK)
8585 {
8586 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8587 return MATCH_ERROR;
8588 }
8589
8590 gfc_clear_attr (¤t_attr);
8591 current_attr.optional = 1;
8592
8593 return attr_decl ();
8594 }
8595
8596
8597 match
gfc_match_pointer(void)8598 gfc_match_pointer (void)
8599 {
8600 gfc_gobble_whitespace ();
8601 if (gfc_peek_ascii_char () == '(')
8602 {
8603 if (!flag_cray_pointer)
8604 {
8605 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8606 "flag");
8607 return MATCH_ERROR;
8608 }
8609 return cray_pointer_decl ();
8610 }
8611 else
8612 {
8613 gfc_clear_attr (¤t_attr);
8614 current_attr.pointer = 1;
8615
8616 return attr_decl ();
8617 }
8618 }
8619
8620
8621 match
gfc_match_allocatable(void)8622 gfc_match_allocatable (void)
8623 {
8624 gfc_clear_attr (¤t_attr);
8625 current_attr.allocatable = 1;
8626
8627 return attr_decl ();
8628 }
8629
8630
8631 match
gfc_match_codimension(void)8632 gfc_match_codimension (void)
8633 {
8634 gfc_clear_attr (¤t_attr);
8635 current_attr.codimension = 1;
8636
8637 return attr_decl ();
8638 }
8639
8640
8641 match
gfc_match_contiguous(void)8642 gfc_match_contiguous (void)
8643 {
8644 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
8645 return MATCH_ERROR;
8646
8647 gfc_clear_attr (¤t_attr);
8648 current_attr.contiguous = 1;
8649
8650 return attr_decl ();
8651 }
8652
8653
8654 match
gfc_match_dimension(void)8655 gfc_match_dimension (void)
8656 {
8657 gfc_clear_attr (¤t_attr);
8658 current_attr.dimension = 1;
8659
8660 return attr_decl ();
8661 }
8662
8663
8664 match
gfc_match_target(void)8665 gfc_match_target (void)
8666 {
8667 gfc_clear_attr (¤t_attr);
8668 current_attr.target = 1;
8669
8670 return attr_decl ();
8671 }
8672
8673
8674 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8675 statement. */
8676
8677 static match
access_attr_decl(gfc_statement st)8678 access_attr_decl (gfc_statement st)
8679 {
8680 char name[GFC_MAX_SYMBOL_LEN + 1];
8681 interface_type type;
8682 gfc_user_op *uop;
8683 gfc_symbol *sym, *dt_sym;
8684 gfc_intrinsic_op op;
8685 match m;
8686
8687 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8688 goto done;
8689
8690 for (;;)
8691 {
8692 m = gfc_match_generic_spec (&type, name, &op);
8693 if (m == MATCH_NO)
8694 goto syntax;
8695 if (m == MATCH_ERROR)
8696 return MATCH_ERROR;
8697
8698 switch (type)
8699 {
8700 case INTERFACE_NAMELESS:
8701 case INTERFACE_ABSTRACT:
8702 goto syntax;
8703
8704 case INTERFACE_GENERIC:
8705 case INTERFACE_DTIO:
8706
8707 if (gfc_get_symbol (name, NULL, &sym))
8708 goto done;
8709
8710 if (type == INTERFACE_DTIO
8711 && gfc_current_ns->proc_name
8712 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
8713 && sym->attr.flavor == FL_UNKNOWN)
8714 sym->attr.flavor = FL_PROCEDURE;
8715
8716 if (!gfc_add_access (&sym->attr,
8717 (st == ST_PUBLIC)
8718 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8719 sym->name, NULL))
8720 return MATCH_ERROR;
8721
8722 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
8723 && !gfc_add_access (&dt_sym->attr,
8724 (st == ST_PUBLIC)
8725 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8726 sym->name, NULL))
8727 return MATCH_ERROR;
8728
8729 break;
8730
8731 case INTERFACE_INTRINSIC_OP:
8732 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
8733 {
8734 gfc_intrinsic_op other_op;
8735
8736 gfc_current_ns->operator_access[op] =
8737 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8738
8739 /* Handle the case if there is another op with the same
8740 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8741 other_op = gfc_equivalent_op (op);
8742
8743 if (other_op != INTRINSIC_NONE)
8744 gfc_current_ns->operator_access[other_op] =
8745 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8746
8747 }
8748 else
8749 {
8750 gfc_error ("Access specification of the %s operator at %C has "
8751 "already been specified", gfc_op2string (op));
8752 goto done;
8753 }
8754
8755 break;
8756
8757 case INTERFACE_USER_OP:
8758 uop = gfc_get_uop (name);
8759
8760 if (uop->access == ACCESS_UNKNOWN)
8761 {
8762 uop->access = (st == ST_PUBLIC)
8763 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8764 }
8765 else
8766 {
8767 gfc_error ("Access specification of the .%s. operator at %C "
8768 "has already been specified", sym->name);
8769 goto done;
8770 }
8771
8772 break;
8773 }
8774
8775 if (gfc_match_char (',') == MATCH_NO)
8776 break;
8777 }
8778
8779 if (gfc_match_eos () != MATCH_YES)
8780 goto syntax;
8781 return MATCH_YES;
8782
8783 syntax:
8784 gfc_syntax_error (st);
8785
8786 done:
8787 return MATCH_ERROR;
8788 }
8789
8790
8791 match
gfc_match_protected(void)8792 gfc_match_protected (void)
8793 {
8794 gfc_symbol *sym;
8795 match m;
8796
8797 if (!gfc_current_ns->proc_name
8798 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
8799 {
8800 gfc_error ("PROTECTED at %C only allowed in specification "
8801 "part of a module");
8802 return MATCH_ERROR;
8803
8804 }
8805
8806 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
8807 return MATCH_ERROR;
8808
8809 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8810 {
8811 return MATCH_ERROR;
8812 }
8813
8814 if (gfc_match_eos () == MATCH_YES)
8815 goto syntax;
8816
8817 for(;;)
8818 {
8819 m = gfc_match_symbol (&sym, 0);
8820 switch (m)
8821 {
8822 case MATCH_YES:
8823 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
8824 return MATCH_ERROR;
8825 goto next_item;
8826
8827 case MATCH_NO:
8828 break;
8829
8830 case MATCH_ERROR:
8831 return MATCH_ERROR;
8832 }
8833
8834 next_item:
8835 if (gfc_match_eos () == MATCH_YES)
8836 break;
8837 if (gfc_match_char (',') != MATCH_YES)
8838 goto syntax;
8839 }
8840
8841 return MATCH_YES;
8842
8843 syntax:
8844 gfc_error ("Syntax error in PROTECTED statement at %C");
8845 return MATCH_ERROR;
8846 }
8847
8848
8849 /* The PRIVATE statement is a bit weird in that it can be an attribute
8850 declaration, but also works as a standalone statement inside of a
8851 type declaration or a module. */
8852
8853 match
gfc_match_private(gfc_statement * st)8854 gfc_match_private (gfc_statement *st)
8855 {
8856
8857 if (gfc_match ("private") != MATCH_YES)
8858 return MATCH_NO;
8859
8860 if (gfc_current_state () != COMP_MODULE
8861 && !(gfc_current_state () == COMP_DERIVED
8862 && gfc_state_stack->previous
8863 && gfc_state_stack->previous->state == COMP_MODULE)
8864 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8865 && gfc_state_stack->previous && gfc_state_stack->previous->previous
8866 && gfc_state_stack->previous->previous->state == COMP_MODULE))
8867 {
8868 gfc_error ("PRIVATE statement at %C is only allowed in the "
8869 "specification part of a module");
8870 return MATCH_ERROR;
8871 }
8872
8873 if (gfc_current_state () == COMP_DERIVED)
8874 {
8875 if (gfc_match_eos () == MATCH_YES)
8876 {
8877 *st = ST_PRIVATE;
8878 return MATCH_YES;
8879 }
8880
8881 gfc_syntax_error (ST_PRIVATE);
8882 return MATCH_ERROR;
8883 }
8884
8885 if (gfc_match_eos () == MATCH_YES)
8886 {
8887 *st = ST_PRIVATE;
8888 return MATCH_YES;
8889 }
8890
8891 *st = ST_ATTR_DECL;
8892 return access_attr_decl (ST_PRIVATE);
8893 }
8894
8895
8896 match
gfc_match_public(gfc_statement * st)8897 gfc_match_public (gfc_statement *st)
8898 {
8899
8900 if (gfc_match ("public") != MATCH_YES)
8901 return MATCH_NO;
8902
8903 if (gfc_current_state () != COMP_MODULE)
8904 {
8905 gfc_error ("PUBLIC statement at %C is only allowed in the "
8906 "specification part of a module");
8907 return MATCH_ERROR;
8908 }
8909
8910 if (gfc_match_eos () == MATCH_YES)
8911 {
8912 *st = ST_PUBLIC;
8913 return MATCH_YES;
8914 }
8915
8916 *st = ST_ATTR_DECL;
8917 return access_attr_decl (ST_PUBLIC);
8918 }
8919
8920
8921 /* Workhorse for gfc_match_parameter. */
8922
8923 static match
do_parm(void)8924 do_parm (void)
8925 {
8926 gfc_symbol *sym;
8927 gfc_expr *init;
8928 match m;
8929 bool t;
8930
8931 m = gfc_match_symbol (&sym, 0);
8932 if (m == MATCH_NO)
8933 gfc_error ("Expected variable name at %C in PARAMETER statement");
8934
8935 if (m != MATCH_YES)
8936 return m;
8937
8938 if (gfc_match_char ('=') == MATCH_NO)
8939 {
8940 gfc_error ("Expected = sign in PARAMETER statement at %C");
8941 return MATCH_ERROR;
8942 }
8943
8944 m = gfc_match_init_expr (&init);
8945 if (m == MATCH_NO)
8946 gfc_error ("Expected expression at %C in PARAMETER statement");
8947 if (m != MATCH_YES)
8948 return m;
8949
8950 if (sym->ts.type == BT_UNKNOWN
8951 && !gfc_set_default_type (sym, 1, NULL))
8952 {
8953 m = MATCH_ERROR;
8954 goto cleanup;
8955 }
8956
8957 if (!gfc_check_assign_symbol (sym, NULL, init)
8958 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
8959 {
8960 m = MATCH_ERROR;
8961 goto cleanup;
8962 }
8963
8964 if (sym->value)
8965 {
8966 gfc_error ("Initializing already initialized variable at %C");
8967 m = MATCH_ERROR;
8968 goto cleanup;
8969 }
8970
8971 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
8972 return (t) ? MATCH_YES : MATCH_ERROR;
8973
8974 cleanup:
8975 gfc_free_expr (init);
8976 return m;
8977 }
8978
8979
8980 /* Match a parameter statement, with the weird syntax that these have. */
8981
8982 match
gfc_match_parameter(void)8983 gfc_match_parameter (void)
8984 {
8985 const char *term = " )%t";
8986 match m;
8987
8988 if (gfc_match_char ('(') == MATCH_NO)
8989 {
8990 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8991 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
8992 return MATCH_NO;
8993 term = " %t";
8994 }
8995
8996 for (;;)
8997 {
8998 m = do_parm ();
8999 if (m != MATCH_YES)
9000 break;
9001
9002 if (gfc_match (term) == MATCH_YES)
9003 break;
9004
9005 if (gfc_match_char (',') != MATCH_YES)
9006 {
9007 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9008 m = MATCH_ERROR;
9009 break;
9010 }
9011 }
9012
9013 return m;
9014 }
9015
9016
9017 match
gfc_match_automatic(void)9018 gfc_match_automatic (void)
9019 {
9020 gfc_symbol *sym;
9021 match m;
9022 bool seen_symbol = false;
9023
9024 if (!flag_dec_static)
9025 {
9026 gfc_error ("%s at %C is a DEC extension, enable with "
9027 "%<-fdec-static%>",
9028 "AUTOMATIC"
9029 );
9030 return MATCH_ERROR;
9031 }
9032
9033 gfc_match (" ::");
9034
9035 for (;;)
9036 {
9037 m = gfc_match_symbol (&sym, 0);
9038 switch (m)
9039 {
9040 case MATCH_NO:
9041 break;
9042
9043 case MATCH_ERROR:
9044 return MATCH_ERROR;
9045
9046 case MATCH_YES:
9047 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
9048 return MATCH_ERROR;
9049 seen_symbol = true;
9050 break;
9051 }
9052
9053 if (gfc_match_eos () == MATCH_YES)
9054 break;
9055 if (gfc_match_char (',') != MATCH_YES)
9056 goto syntax;
9057 }
9058
9059 if (!seen_symbol)
9060 {
9061 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9062 return MATCH_ERROR;
9063 }
9064
9065 return MATCH_YES;
9066
9067 syntax:
9068 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9069 return MATCH_ERROR;
9070 }
9071
9072
9073 match
gfc_match_static(void)9074 gfc_match_static (void)
9075 {
9076 gfc_symbol *sym;
9077 match m;
9078 bool seen_symbol = false;
9079
9080 if (!flag_dec_static)
9081 {
9082 gfc_error ("%s at %C is a DEC extension, enable with "
9083 "%<-fdec-static%>",
9084 "STATIC");
9085 return MATCH_ERROR;
9086 }
9087
9088 gfc_match (" ::");
9089
9090 for (;;)
9091 {
9092 m = gfc_match_symbol (&sym, 0);
9093 switch (m)
9094 {
9095 case MATCH_NO:
9096 break;
9097
9098 case MATCH_ERROR:
9099 return MATCH_ERROR;
9100
9101 case MATCH_YES:
9102 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9103 &gfc_current_locus))
9104 return MATCH_ERROR;
9105 seen_symbol = true;
9106 break;
9107 }
9108
9109 if (gfc_match_eos () == MATCH_YES)
9110 break;
9111 if (gfc_match_char (',') != MATCH_YES)
9112 goto syntax;
9113 }
9114
9115 if (!seen_symbol)
9116 {
9117 gfc_error ("Expected entity-list in STATIC statement at %C");
9118 return MATCH_ERROR;
9119 }
9120
9121 return MATCH_YES;
9122
9123 syntax:
9124 gfc_error ("Syntax error in STATIC statement at %C");
9125 return MATCH_ERROR;
9126 }
9127
9128
9129 /* Save statements have a special syntax. */
9130
9131 match
gfc_match_save(void)9132 gfc_match_save (void)
9133 {
9134 char n[GFC_MAX_SYMBOL_LEN+1];
9135 gfc_common_head *c;
9136 gfc_symbol *sym;
9137 match m;
9138
9139 if (gfc_match_eos () == MATCH_YES)
9140 {
9141 if (gfc_current_ns->seen_save)
9142 {
9143 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
9144 "follows previous SAVE statement"))
9145 return MATCH_ERROR;
9146 }
9147
9148 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
9149 return MATCH_YES;
9150 }
9151
9152 if (gfc_current_ns->save_all)
9153 {
9154 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
9155 "blanket SAVE statement"))
9156 return MATCH_ERROR;
9157 }
9158
9159 gfc_match (" ::");
9160
9161 for (;;)
9162 {
9163 m = gfc_match_symbol (&sym, 0);
9164 switch (m)
9165 {
9166 case MATCH_YES:
9167 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9168 &gfc_current_locus))
9169 return MATCH_ERROR;
9170 goto next_item;
9171
9172 case MATCH_NO:
9173 break;
9174
9175 case MATCH_ERROR:
9176 return MATCH_ERROR;
9177 }
9178
9179 m = gfc_match (" / %n /", &n);
9180 if (m == MATCH_ERROR)
9181 return MATCH_ERROR;
9182 if (m == MATCH_NO)
9183 goto syntax;
9184
9185 c = gfc_get_common (n, 0);
9186 c->saved = 1;
9187
9188 gfc_current_ns->seen_save = 1;
9189
9190 next_item:
9191 if (gfc_match_eos () == MATCH_YES)
9192 break;
9193 if (gfc_match_char (',') != MATCH_YES)
9194 goto syntax;
9195 }
9196
9197 return MATCH_YES;
9198
9199 syntax:
9200 gfc_error ("Syntax error in SAVE statement at %C");
9201 return MATCH_ERROR;
9202 }
9203
9204
9205 match
gfc_match_value(void)9206 gfc_match_value (void)
9207 {
9208 gfc_symbol *sym;
9209 match m;
9210
9211 /* This is not allowed within a BLOCK construct! */
9212 if (gfc_current_state () == COMP_BLOCK)
9213 {
9214 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9215 return MATCH_ERROR;
9216 }
9217
9218 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
9219 return MATCH_ERROR;
9220
9221 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9222 {
9223 return MATCH_ERROR;
9224 }
9225
9226 if (gfc_match_eos () == MATCH_YES)
9227 goto syntax;
9228
9229 for(;;)
9230 {
9231 m = gfc_match_symbol (&sym, 0);
9232 switch (m)
9233 {
9234 case MATCH_YES:
9235 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
9236 return MATCH_ERROR;
9237 goto next_item;
9238
9239 case MATCH_NO:
9240 break;
9241
9242 case MATCH_ERROR:
9243 return MATCH_ERROR;
9244 }
9245
9246 next_item:
9247 if (gfc_match_eos () == MATCH_YES)
9248 break;
9249 if (gfc_match_char (',') != MATCH_YES)
9250 goto syntax;
9251 }
9252
9253 return MATCH_YES;
9254
9255 syntax:
9256 gfc_error ("Syntax error in VALUE statement at %C");
9257 return MATCH_ERROR;
9258 }
9259
9260
9261 match
gfc_match_volatile(void)9262 gfc_match_volatile (void)
9263 {
9264 gfc_symbol *sym;
9265 char *name;
9266 match m;
9267
9268 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
9269 return MATCH_ERROR;
9270
9271 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9272 {
9273 return MATCH_ERROR;
9274 }
9275
9276 if (gfc_match_eos () == MATCH_YES)
9277 goto syntax;
9278
9279 for(;;)
9280 {
9281 /* VOLATILE is special because it can be added to host-associated
9282 symbols locally. Except for coarrays. */
9283 m = gfc_match_symbol (&sym, 1);
9284 switch (m)
9285 {
9286 case MATCH_YES:
9287 name = XCNEWVAR (char, strlen (sym->name) + 1);
9288 strcpy (name, sym->name);
9289 if (!check_function_name (name))
9290 return MATCH_ERROR;
9291 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9292 for variable in a BLOCK which is defined outside of the BLOCK. */
9293 if (sym->ns != gfc_current_ns && sym->attr.codimension)
9294 {
9295 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9296 "%C, which is use-/host-associated", sym->name);
9297 return MATCH_ERROR;
9298 }
9299 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
9300 return MATCH_ERROR;
9301 goto next_item;
9302
9303 case MATCH_NO:
9304 break;
9305
9306 case MATCH_ERROR:
9307 return MATCH_ERROR;
9308 }
9309
9310 next_item:
9311 if (gfc_match_eos () == MATCH_YES)
9312 break;
9313 if (gfc_match_char (',') != MATCH_YES)
9314 goto syntax;
9315 }
9316
9317 return MATCH_YES;
9318
9319 syntax:
9320 gfc_error ("Syntax error in VOLATILE statement at %C");
9321 return MATCH_ERROR;
9322 }
9323
9324
9325 match
gfc_match_asynchronous(void)9326 gfc_match_asynchronous (void)
9327 {
9328 gfc_symbol *sym;
9329 char *name;
9330 match m;
9331
9332 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
9333 return MATCH_ERROR;
9334
9335 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9336 {
9337 return MATCH_ERROR;
9338 }
9339
9340 if (gfc_match_eos () == MATCH_YES)
9341 goto syntax;
9342
9343 for(;;)
9344 {
9345 /* ASYNCHRONOUS is special because it can be added to host-associated
9346 symbols locally. */
9347 m = gfc_match_symbol (&sym, 1);
9348 switch (m)
9349 {
9350 case MATCH_YES:
9351 name = XCNEWVAR (char, strlen (sym->name) + 1);
9352 strcpy (name, sym->name);
9353 if (!check_function_name (name))
9354 return MATCH_ERROR;
9355 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
9356 return MATCH_ERROR;
9357 goto next_item;
9358
9359 case MATCH_NO:
9360 break;
9361
9362 case MATCH_ERROR:
9363 return MATCH_ERROR;
9364 }
9365
9366 next_item:
9367 if (gfc_match_eos () == MATCH_YES)
9368 break;
9369 if (gfc_match_char (',') != MATCH_YES)
9370 goto syntax;
9371 }
9372
9373 return MATCH_YES;
9374
9375 syntax:
9376 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9377 return MATCH_ERROR;
9378 }
9379
9380
9381 /* Match a module procedure statement in a submodule. */
9382
9383 match
gfc_match_submod_proc(void)9384 gfc_match_submod_proc (void)
9385 {
9386 char name[GFC_MAX_SYMBOL_LEN + 1];
9387 gfc_symbol *sym, *fsym;
9388 match m;
9389 gfc_formal_arglist *formal, *head, *tail;
9390
9391 if (gfc_current_state () != COMP_CONTAINS
9392 || !(gfc_state_stack->previous
9393 && (gfc_state_stack->previous->state == COMP_SUBMODULE
9394 || gfc_state_stack->previous->state == COMP_MODULE)))
9395 return MATCH_NO;
9396
9397 m = gfc_match (" module% procedure% %n", name);
9398 if (m != MATCH_YES)
9399 return m;
9400
9401 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
9402 "at %C"))
9403 return MATCH_ERROR;
9404
9405 if (get_proc_name (name, &sym, false))
9406 return MATCH_ERROR;
9407
9408 /* Make sure that the result field is appropriately filled, even though
9409 the result symbol will be replaced later on. */
9410 if (sym->tlink && sym->tlink->attr.function)
9411 {
9412 if (sym->tlink->result
9413 && sym->tlink->result != sym->tlink)
9414 sym->result= sym->tlink->result;
9415 else
9416 sym->result = sym;
9417 }
9418
9419 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9420 the symbol existed before. */
9421 sym->declared_at = gfc_current_locus;
9422
9423 if (!sym->attr.module_procedure)
9424 return MATCH_ERROR;
9425
9426 /* Signal match_end to expect "end procedure". */
9427 sym->abr_modproc_decl = 1;
9428
9429 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9430 sym->attr.if_source = IFSRC_DECL;
9431
9432 gfc_new_block = sym;
9433
9434 /* Make a new formal arglist with the symbols in the procedure
9435 namespace. */
9436 head = tail = NULL;
9437 for (formal = sym->formal; formal && formal->sym; formal = formal->next)
9438 {
9439 if (formal == sym->formal)
9440 head = tail = gfc_get_formal_arglist ();
9441 else
9442 {
9443 tail->next = gfc_get_formal_arglist ();
9444 tail = tail->next;
9445 }
9446
9447 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
9448 goto cleanup;
9449
9450 tail->sym = fsym;
9451 gfc_set_sym_referenced (fsym);
9452 }
9453
9454 /* The dummy symbols get cleaned up, when the formal_namespace of the
9455 interface declaration is cleared. This allows us to add the
9456 explicit interface as is done for other type of procedure. */
9457 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
9458 &gfc_current_locus))
9459 return MATCH_ERROR;
9460
9461 if (gfc_match_eos () != MATCH_YES)
9462 {
9463 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9464 undone, such that the st->n.sym->formal points to the original symbol;
9465 if now this namespace is finalized, the formal namespace is freed,
9466 but it might be still needed in the parent namespace. */
9467 gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
9468 st->n.sym = NULL;
9469 gfc_free_symbol (sym->tlink);
9470 sym->tlink = NULL;
9471 sym->refs--;
9472 gfc_syntax_error (ST_MODULE_PROC);
9473 return MATCH_ERROR;
9474 }
9475
9476 return MATCH_YES;
9477
9478 cleanup:
9479 gfc_free_formal_arglist (head);
9480 return MATCH_ERROR;
9481 }
9482
9483
9484 /* Match a module procedure statement. Note that we have to modify
9485 symbols in the parent's namespace because the current one was there
9486 to receive symbols that are in an interface's formal argument list. */
9487
9488 match
gfc_match_modproc(void)9489 gfc_match_modproc (void)
9490 {
9491 char name[GFC_MAX_SYMBOL_LEN + 1];
9492 gfc_symbol *sym;
9493 match m;
9494 locus old_locus;
9495 gfc_namespace *module_ns;
9496 gfc_interface *old_interface_head, *interface;
9497
9498 if (gfc_state_stack->state != COMP_INTERFACE
9499 || gfc_state_stack->previous == NULL
9500 || current_interface.type == INTERFACE_NAMELESS
9501 || current_interface.type == INTERFACE_ABSTRACT)
9502 {
9503 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9504 "interface");
9505 return MATCH_ERROR;
9506 }
9507
9508 module_ns = gfc_current_ns->parent;
9509 for (; module_ns; module_ns = module_ns->parent)
9510 if (module_ns->proc_name->attr.flavor == FL_MODULE
9511 || module_ns->proc_name->attr.flavor == FL_PROGRAM
9512 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
9513 && !module_ns->proc_name->attr.contained))
9514 break;
9515
9516 if (module_ns == NULL)
9517 return MATCH_ERROR;
9518
9519 /* Store the current state of the interface. We will need it if we
9520 end up with a syntax error and need to recover. */
9521 old_interface_head = gfc_current_interface_head ();
9522
9523 /* Check if the F2008 optional double colon appears. */
9524 gfc_gobble_whitespace ();
9525 old_locus = gfc_current_locus;
9526 if (gfc_match ("::") == MATCH_YES)
9527 {
9528 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
9529 "MODULE PROCEDURE statement at %L", &old_locus))
9530 return MATCH_ERROR;
9531 }
9532 else
9533 gfc_current_locus = old_locus;
9534
9535 for (;;)
9536 {
9537 bool last = false;
9538 old_locus = gfc_current_locus;
9539
9540 m = gfc_match_name (name);
9541 if (m == MATCH_NO)
9542 goto syntax;
9543 if (m != MATCH_YES)
9544 return MATCH_ERROR;
9545
9546 /* Check for syntax error before starting to add symbols to the
9547 current namespace. */
9548 if (gfc_match_eos () == MATCH_YES)
9549 last = true;
9550
9551 if (!last && gfc_match_char (',') != MATCH_YES)
9552 goto syntax;
9553
9554 /* Now we're sure the syntax is valid, we process this item
9555 further. */
9556 if (gfc_get_symbol (name, module_ns, &sym))
9557 return MATCH_ERROR;
9558
9559 if (sym->attr.intrinsic)
9560 {
9561 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9562 "PROCEDURE", &old_locus);
9563 return MATCH_ERROR;
9564 }
9565
9566 if (sym->attr.proc != PROC_MODULE
9567 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
9568 return MATCH_ERROR;
9569
9570 if (!gfc_add_interface (sym))
9571 return MATCH_ERROR;
9572
9573 sym->attr.mod_proc = 1;
9574 sym->declared_at = old_locus;
9575
9576 if (last)
9577 break;
9578 }
9579
9580 return MATCH_YES;
9581
9582 syntax:
9583 /* Restore the previous state of the interface. */
9584 interface = gfc_current_interface_head ();
9585 gfc_set_current_interface_head (old_interface_head);
9586
9587 /* Free the new interfaces. */
9588 while (interface != old_interface_head)
9589 {
9590 gfc_interface *i = interface->next;
9591 free (interface);
9592 interface = i;
9593 }
9594
9595 /* And issue a syntax error. */
9596 gfc_syntax_error (ST_MODULE_PROC);
9597 return MATCH_ERROR;
9598 }
9599
9600
9601 /* Check a derived type that is being extended. */
9602
9603 static gfc_symbol*
check_extended_derived_type(char * name)9604 check_extended_derived_type (char *name)
9605 {
9606 gfc_symbol *extended;
9607
9608 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
9609 {
9610 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9611 return NULL;
9612 }
9613
9614 extended = gfc_find_dt_in_generic (extended);
9615
9616 /* F08:C428. */
9617 if (!extended)
9618 {
9619 gfc_error ("Symbol %qs at %C has not been previously defined", name);
9620 return NULL;
9621 }
9622
9623 if (extended->attr.flavor != FL_DERIVED)
9624 {
9625 gfc_error ("%qs in EXTENDS expression at %C is not a "
9626 "derived type", name);
9627 return NULL;
9628 }
9629
9630 if (extended->attr.is_bind_c)
9631 {
9632 gfc_error ("%qs cannot be extended at %C because it "
9633 "is BIND(C)", extended->name);
9634 return NULL;
9635 }
9636
9637 if (extended->attr.sequence)
9638 {
9639 gfc_error ("%qs cannot be extended at %C because it "
9640 "is a SEQUENCE type", extended->name);
9641 return NULL;
9642 }
9643
9644 return extended;
9645 }
9646
9647
9648 /* Match the optional attribute specifiers for a type declaration.
9649 Return MATCH_ERROR if an error is encountered in one of the handled
9650 attributes (public, private, bind(c)), MATCH_NO if what's found is
9651 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9652 checking on attribute conflicts needs to be done. */
9653
9654 match
gfc_get_type_attr_spec(symbol_attribute * attr,char * name)9655 gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
9656 {
9657 /* See if the derived type is marked as private. */
9658 if (gfc_match (" , private") == MATCH_YES)
9659 {
9660 if (gfc_current_state () != COMP_MODULE)
9661 {
9662 gfc_error ("Derived type at %C can only be PRIVATE in the "
9663 "specification part of a module");
9664 return MATCH_ERROR;
9665 }
9666
9667 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
9668 return MATCH_ERROR;
9669 }
9670 else if (gfc_match (" , public") == MATCH_YES)
9671 {
9672 if (gfc_current_state () != COMP_MODULE)
9673 {
9674 gfc_error ("Derived type at %C can only be PUBLIC in the "
9675 "specification part of a module");
9676 return MATCH_ERROR;
9677 }
9678
9679 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
9680 return MATCH_ERROR;
9681 }
9682 else if (gfc_match (" , bind ( c )") == MATCH_YES)
9683 {
9684 /* If the type is defined to be bind(c) it then needs to make
9685 sure that all fields are interoperable. This will
9686 need to be a semantic check on the finished derived type.
9687 See 15.2.3 (lines 9-12) of F2003 draft. */
9688 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
9689 return MATCH_ERROR;
9690
9691 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9692 }
9693 else if (gfc_match (" , abstract") == MATCH_YES)
9694 {
9695 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
9696 return MATCH_ERROR;
9697
9698 if (!gfc_add_abstract (attr, &gfc_current_locus))
9699 return MATCH_ERROR;
9700 }
9701 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
9702 {
9703 if (!gfc_add_extension (attr, &gfc_current_locus))
9704 return MATCH_ERROR;
9705 }
9706 else
9707 return MATCH_NO;
9708
9709 /* If we get here, something matched. */
9710 return MATCH_YES;
9711 }
9712
9713
9714 /* Common function for type declaration blocks similar to derived types, such
9715 as STRUCTURES and MAPs. Unlike derived types, a structure type
9716 does NOT have a generic symbol matching the name given by the user.
9717 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9718 for the creation of an independent symbol.
9719 Other parameters are a message to prefix errors with, the name of the new
9720 type to be created, and the flavor to add to the resulting symbol. */
9721
9722 static bool
get_struct_decl(const char * name,sym_flavor fl,locus * decl,gfc_symbol ** result)9723 get_struct_decl (const char *name, sym_flavor fl, locus *decl,
9724 gfc_symbol **result)
9725 {
9726 gfc_symbol *sym;
9727 locus where;
9728
9729 gcc_assert (name[0] == (char) TOUPPER (name[0]));
9730
9731 if (decl)
9732 where = *decl;
9733 else
9734 where = gfc_current_locus;
9735
9736 if (gfc_get_symbol (name, NULL, &sym))
9737 return false;
9738
9739 if (!sym)
9740 {
9741 gfc_internal_error ("Failed to create structure type '%s' at %C", name);
9742 return false;
9743 }
9744
9745 if (sym->components != NULL || sym->attr.zero_comp)
9746 {
9747 gfc_error ("Type definition of %qs at %C was already defined at %L",
9748 sym->name, &sym->declared_at);
9749 return false;
9750 }
9751
9752 sym->declared_at = where;
9753
9754 if (sym->attr.flavor != fl
9755 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
9756 return false;
9757
9758 if (!sym->hash_value)
9759 /* Set the hash for the compound name for this type. */
9760 sym->hash_value = gfc_hash_value (sym);
9761
9762 /* Normally the type is expected to have been completely parsed by the time
9763 a field declaration with this type is seen. For unions, maps, and nested
9764 structure declarations, we need to indicate that it is okay that we
9765 haven't seen any components yet. This will be updated after the structure
9766 is fully parsed. */
9767 sym->attr.zero_comp = 0;
9768
9769 /* Structures always act like derived-types with the SEQUENCE attribute */
9770 gfc_add_sequence (&sym->attr, sym->name, NULL);
9771
9772 if (result) *result = sym;
9773
9774 return true;
9775 }
9776
9777
9778 /* Match the opening of a MAP block. Like a struct within a union in C;
9779 behaves identical to STRUCTURE blocks. */
9780
9781 match
gfc_match_map(void)9782 gfc_match_map (void)
9783 {
9784 /* Counter used to give unique internal names to map structures. */
9785 static unsigned int gfc_map_id = 0;
9786 char name[GFC_MAX_SYMBOL_LEN + 1];
9787 gfc_symbol *sym;
9788 locus old_loc;
9789
9790 old_loc = gfc_current_locus;
9791
9792 if (gfc_match_eos () != MATCH_YES)
9793 {
9794 gfc_error ("Junk after MAP statement at %C");
9795 gfc_current_locus = old_loc;
9796 return MATCH_ERROR;
9797 }
9798
9799 /* Map blocks are anonymous so we make up unique names for the symbol table
9800 which are invalid Fortran identifiers. */
9801 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
9802
9803 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
9804 return MATCH_ERROR;
9805
9806 gfc_new_block = sym;
9807
9808 return MATCH_YES;
9809 }
9810
9811
9812 /* Match the opening of a UNION block. */
9813
9814 match
gfc_match_union(void)9815 gfc_match_union (void)
9816 {
9817 /* Counter used to give unique internal names to union types. */
9818 static unsigned int gfc_union_id = 0;
9819 char name[GFC_MAX_SYMBOL_LEN + 1];
9820 gfc_symbol *sym;
9821 locus old_loc;
9822
9823 old_loc = gfc_current_locus;
9824
9825 if (gfc_match_eos () != MATCH_YES)
9826 {
9827 gfc_error ("Junk after UNION statement at %C");
9828 gfc_current_locus = old_loc;
9829 return MATCH_ERROR;
9830 }
9831
9832 /* Unions are anonymous so we make up unique names for the symbol table
9833 which are invalid Fortran identifiers. */
9834 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
9835
9836 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
9837 return MATCH_ERROR;
9838
9839 gfc_new_block = sym;
9840
9841 return MATCH_YES;
9842 }
9843
9844
9845 /* Match the beginning of a STRUCTURE declaration. This is similar to
9846 matching the beginning of a derived type declaration with a few
9847 twists. The resulting type symbol has no access control or other
9848 interesting attributes. */
9849
9850 match
gfc_match_structure_decl(void)9851 gfc_match_structure_decl (void)
9852 {
9853 /* Counter used to give unique internal names to anonymous structures. */
9854 static unsigned int gfc_structure_id = 0;
9855 char name[GFC_MAX_SYMBOL_LEN + 1];
9856 gfc_symbol *sym;
9857 match m;
9858 locus where;
9859
9860 if (!flag_dec_structure)
9861 {
9862 gfc_error ("%s at %C is a DEC extension, enable with "
9863 "%<-fdec-structure%>",
9864 "STRUCTURE");
9865 return MATCH_ERROR;
9866 }
9867
9868 name[0] = '\0';
9869
9870 m = gfc_match (" /%n/", name);
9871 if (m != MATCH_YES)
9872 {
9873 /* Non-nested structure declarations require a structure name. */
9874 if (!gfc_comp_struct (gfc_current_state ()))
9875 {
9876 gfc_error ("Structure name expected in non-nested structure "
9877 "declaration at %C");
9878 return MATCH_ERROR;
9879 }
9880 /* This is an anonymous structure; make up a unique name for it
9881 (upper-case letters never make it to symbol names from the source).
9882 The important thing is initializing the type variable
9883 and setting gfc_new_symbol, which is immediately used by
9884 parse_structure () and variable_decl () to add components of
9885 this type. */
9886 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
9887 }
9888
9889 where = gfc_current_locus;
9890 /* No field list allowed after non-nested structure declaration. */
9891 if (!gfc_comp_struct (gfc_current_state ())
9892 && gfc_match_eos () != MATCH_YES)
9893 {
9894 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9895 return MATCH_ERROR;
9896 }
9897
9898 /* Make sure the name is not the name of an intrinsic type. */
9899 if (gfc_is_intrinsic_typename (name))
9900 {
9901 gfc_error ("Structure name %qs at %C cannot be the same as an"
9902 " intrinsic type", name);
9903 return MATCH_ERROR;
9904 }
9905
9906 /* Store the actual type symbol for the structure with an upper-case first
9907 letter (an invalid Fortran identifier). */
9908
9909 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
9910 return MATCH_ERROR;
9911
9912 gfc_new_block = sym;
9913 return MATCH_YES;
9914 }
9915
9916
9917 /* This function does some work to determine which matcher should be used to
9918 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9919 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9920 * and [parameterized] derived type declarations. */
9921
9922 match
gfc_match_type(gfc_statement * st)9923 gfc_match_type (gfc_statement *st)
9924 {
9925 char name[GFC_MAX_SYMBOL_LEN + 1];
9926 match m;
9927 locus old_loc;
9928
9929 /* Requires -fdec. */
9930 if (!flag_dec)
9931 return MATCH_NO;
9932
9933 m = gfc_match ("type");
9934 if (m != MATCH_YES)
9935 return m;
9936 /* If we already have an error in the buffer, it is probably from failing to
9937 * match a derived type data declaration. Let it happen. */
9938 else if (gfc_error_flag_test ())
9939 return MATCH_NO;
9940
9941 old_loc = gfc_current_locus;
9942 *st = ST_NONE;
9943
9944 /* If we see an attribute list before anything else it's definitely a derived
9945 * type declaration. */
9946 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
9947 goto derived;
9948
9949 /* By now "TYPE" has already been matched. If we do not see a name, this may
9950 * be something like "TYPE *" or "TYPE <fmt>". */
9951 m = gfc_match_name (name);
9952 if (m != MATCH_YES)
9953 {
9954 /* Let print match if it can, otherwise throw an error from
9955 * gfc_match_derived_decl. */
9956 gfc_current_locus = old_loc;
9957 if (gfc_match_print () == MATCH_YES)
9958 {
9959 *st = ST_WRITE;
9960 return MATCH_YES;
9961 }
9962 goto derived;
9963 }
9964
9965 /* Check for EOS. */
9966 if (gfc_match_eos () == MATCH_YES)
9967 {
9968 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9969 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9970 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9971 * symbol which can be printed. */
9972 gfc_current_locus = old_loc;
9973 m = gfc_match_derived_decl ();
9974 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
9975 {
9976 *st = ST_DERIVED_DECL;
9977 return m;
9978 }
9979 }
9980 else
9981 {
9982 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9983 like <type name(parameter)>. */
9984 gfc_gobble_whitespace ();
9985 bool paren = gfc_peek_ascii_char () == '(';
9986 if (paren)
9987 {
9988 if (strcmp ("is", name) == 0)
9989 goto typeis;
9990 else
9991 goto derived;
9992 }
9993 }
9994
9995 /* Treat TYPE... like PRINT... */
9996 gfc_current_locus = old_loc;
9997 *st = ST_WRITE;
9998 return gfc_match_print ();
9999
10000 derived:
10001 gfc_current_locus = old_loc;
10002 *st = ST_DERIVED_DECL;
10003 return gfc_match_derived_decl ();
10004
10005 typeis:
10006 gfc_current_locus = old_loc;
10007 *st = ST_TYPE_IS;
10008 return gfc_match_type_is ();
10009 }
10010
10011
10012 /* Match the beginning of a derived type declaration. If a type name
10013 was the result of a function, then it is possible to have a symbol
10014 already to be known as a derived type yet have no components. */
10015
10016 match
gfc_match_derived_decl(void)10017 gfc_match_derived_decl (void)
10018 {
10019 char name[GFC_MAX_SYMBOL_LEN + 1];
10020 char parent[GFC_MAX_SYMBOL_LEN + 1];
10021 symbol_attribute attr;
10022 gfc_symbol *sym, *gensym;
10023 gfc_symbol *extended;
10024 match m;
10025 match is_type_attr_spec = MATCH_NO;
10026 bool seen_attr = false;
10027 gfc_interface *intr = NULL, *head;
10028 bool parameterized_type = false;
10029 bool seen_colons = false;
10030
10031 if (gfc_comp_struct (gfc_current_state ()))
10032 return MATCH_NO;
10033
10034 name[0] = '\0';
10035 parent[0] = '\0';
10036 gfc_clear_attr (&attr);
10037 extended = NULL;
10038
10039 do
10040 {
10041 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
10042 if (is_type_attr_spec == MATCH_ERROR)
10043 return MATCH_ERROR;
10044 if (is_type_attr_spec == MATCH_YES)
10045 seen_attr = true;
10046 } while (is_type_attr_spec == MATCH_YES);
10047
10048 /* Deal with derived type extensions. The extension attribute has
10049 been added to 'attr' but now the parent type must be found and
10050 checked. */
10051 if (parent[0])
10052 extended = check_extended_derived_type (parent);
10053
10054 if (parent[0] && !extended)
10055 return MATCH_ERROR;
10056
10057 m = gfc_match (" ::");
10058 if (m == MATCH_YES)
10059 {
10060 seen_colons = true;
10061 }
10062 else if (seen_attr)
10063 {
10064 gfc_error ("Expected :: in TYPE definition at %C");
10065 return MATCH_ERROR;
10066 }
10067
10068 m = gfc_match (" %n ", name);
10069 if (m != MATCH_YES)
10070 return m;
10071
10072 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10073 derived type named 'is'.
10074 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10075 and checking if this is a(n intrinsic) typename. his picks up
10076 misplaced TYPE IS statements such as in select_type_1.f03. */
10077 if (gfc_peek_ascii_char () == '(')
10078 {
10079 if (gfc_current_state () == COMP_SELECT_TYPE
10080 || (!seen_colons && !strcmp (name, "is")))
10081 return MATCH_NO;
10082 parameterized_type = true;
10083 }
10084
10085 m = gfc_match_eos ();
10086 if (m != MATCH_YES && !parameterized_type)
10087 return m;
10088
10089 /* Make sure the name is not the name of an intrinsic type. */
10090 if (gfc_is_intrinsic_typename (name))
10091 {
10092 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10093 "type", name);
10094 return MATCH_ERROR;
10095 }
10096
10097 if (gfc_get_symbol (name, NULL, &gensym))
10098 return MATCH_ERROR;
10099
10100 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
10101 {
10102 if (gensym->ts.u.derived)
10103 gfc_error ("Derived type name %qs at %C already has a basic type "
10104 "of %s", gensym->name, gfc_typename (&gensym->ts));
10105 else
10106 gfc_error ("Derived type name %qs at %C already has a basic type",
10107 gensym->name);
10108 return MATCH_ERROR;
10109 }
10110
10111 if (!gensym->attr.generic
10112 && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
10113 return MATCH_ERROR;
10114
10115 if (!gensym->attr.function
10116 && !gfc_add_function (&gensym->attr, gensym->name, NULL))
10117 return MATCH_ERROR;
10118
10119 sym = gfc_find_dt_in_generic (gensym);
10120
10121 if (sym && (sym->components != NULL || sym->attr.zero_comp))
10122 {
10123 gfc_error ("Derived type definition of %qs at %C has already been "
10124 "defined", sym->name);
10125 return MATCH_ERROR;
10126 }
10127
10128 if (!sym)
10129 {
10130 /* Use upper case to save the actual derived-type symbol. */
10131 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
10132 sym->name = gfc_get_string ("%s", gensym->name);
10133 head = gensym->generic;
10134 intr = gfc_get_interface ();
10135 intr->sym = sym;
10136 intr->where = gfc_current_locus;
10137 intr->sym->declared_at = gfc_current_locus;
10138 intr->next = head;
10139 gensym->generic = intr;
10140 gensym->attr.if_source = IFSRC_DECL;
10141 }
10142
10143 /* The symbol may already have the derived attribute without the
10144 components. The ways this can happen is via a function
10145 definition, an INTRINSIC statement or a subtype in another
10146 derived type that is a pointer. The first part of the AND clause
10147 is true if the symbol is not the return value of a function. */
10148 if (sym->attr.flavor != FL_DERIVED
10149 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
10150 return MATCH_ERROR;
10151
10152 if (attr.access != ACCESS_UNKNOWN
10153 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
10154 return MATCH_ERROR;
10155 else if (sym->attr.access == ACCESS_UNKNOWN
10156 && gensym->attr.access != ACCESS_UNKNOWN
10157 && !gfc_add_access (&sym->attr, gensym->attr.access,
10158 sym->name, NULL))
10159 return MATCH_ERROR;
10160
10161 if (sym->attr.access != ACCESS_UNKNOWN
10162 && gensym->attr.access == ACCESS_UNKNOWN)
10163 gensym->attr.access = sym->attr.access;
10164
10165 /* See if the derived type was labeled as bind(c). */
10166 if (attr.is_bind_c != 0)
10167 sym->attr.is_bind_c = attr.is_bind_c;
10168
10169 /* Construct the f2k_derived namespace if it is not yet there. */
10170 if (!sym->f2k_derived)
10171 sym->f2k_derived = gfc_get_namespace (NULL, 0);
10172
10173 if (parameterized_type)
10174 {
10175 /* Ignore error or mismatches by going to the end of the statement
10176 in order to avoid the component declarations causing problems. */
10177 m = gfc_match_formal_arglist (sym, 0, 0, true);
10178 if (m != MATCH_YES)
10179 gfc_error_recovery ();
10180 m = gfc_match_eos ();
10181 if (m != MATCH_YES)
10182 {
10183 gfc_error_recovery ();
10184 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10185 }
10186 sym->attr.pdt_template = 1;
10187 }
10188
10189 if (extended && !sym->components)
10190 {
10191 gfc_component *p;
10192 gfc_formal_arglist *f, *g, *h;
10193
10194 /* Add the extended derived type as the first component. */
10195 gfc_add_component (sym, parent, &p);
10196 extended->refs++;
10197 gfc_set_sym_referenced (extended);
10198
10199 p->ts.type = BT_DERIVED;
10200 p->ts.u.derived = extended;
10201 p->initializer = gfc_default_initializer (&p->ts);
10202
10203 /* Set extension level. */
10204 if (extended->attr.extension == 255)
10205 {
10206 /* Since the extension field is 8 bit wide, we can only have
10207 up to 255 extension levels. */
10208 gfc_error ("Maximum extension level reached with type %qs at %L",
10209 extended->name, &extended->declared_at);
10210 return MATCH_ERROR;
10211 }
10212 sym->attr.extension = extended->attr.extension + 1;
10213
10214 /* Provide the links between the extended type and its extension. */
10215 if (!extended->f2k_derived)
10216 extended->f2k_derived = gfc_get_namespace (NULL, 0);
10217
10218 /* Copy the extended type-param-name-list from the extended type,
10219 append those of the extension and add the whole lot to the
10220 extension. */
10221 if (extended->attr.pdt_template)
10222 {
10223 g = h = NULL;
10224 sym->attr.pdt_template = 1;
10225 for (f = extended->formal; f; f = f->next)
10226 {
10227 if (f == extended->formal)
10228 {
10229 g = gfc_get_formal_arglist ();
10230 h = g;
10231 }
10232 else
10233 {
10234 g->next = gfc_get_formal_arglist ();
10235 g = g->next;
10236 }
10237 g->sym = f->sym;
10238 }
10239 g->next = sym->formal;
10240 sym->formal = h;
10241 }
10242 }
10243
10244 if (!sym->hash_value)
10245 /* Set the hash for the compound name for this type. */
10246 sym->hash_value = gfc_hash_value (sym);
10247
10248 /* Take over the ABSTRACT attribute. */
10249 sym->attr.abstract = attr.abstract;
10250
10251 gfc_new_block = sym;
10252
10253 return MATCH_YES;
10254 }
10255
10256
10257 /* Cray Pointees can be declared as:
10258 pointer (ipt, a (n,m,...,*)) */
10259
10260 match
gfc_mod_pointee_as(gfc_array_spec * as)10261 gfc_mod_pointee_as (gfc_array_spec *as)
10262 {
10263 as->cray_pointee = true; /* This will be useful to know later. */
10264 if (as->type == AS_ASSUMED_SIZE)
10265 as->cp_was_assumed = true;
10266 else if (as->type == AS_ASSUMED_SHAPE)
10267 {
10268 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10269 return MATCH_ERROR;
10270 }
10271 return MATCH_YES;
10272 }
10273
10274
10275 /* Match the enum definition statement, here we are trying to match
10276 the first line of enum definition statement.
10277 Returns MATCH_YES if match is found. */
10278
10279 match
gfc_match_enum(void)10280 gfc_match_enum (void)
10281 {
10282 match m;
10283
10284 m = gfc_match_eos ();
10285 if (m != MATCH_YES)
10286 return m;
10287
10288 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
10289 return MATCH_ERROR;
10290
10291 return MATCH_YES;
10292 }
10293
10294
10295 /* Returns an initializer whose value is one higher than the value of the
10296 LAST_INITIALIZER argument. If the argument is NULL, the
10297 initializers value will be set to zero. The initializer's kind
10298 will be set to gfc_c_int_kind.
10299
10300 If -fshort-enums is given, the appropriate kind will be selected
10301 later after all enumerators have been parsed. A warning is issued
10302 here if an initializer exceeds gfc_c_int_kind. */
10303
10304 static gfc_expr *
enum_initializer(gfc_expr * last_initializer,locus where)10305 enum_initializer (gfc_expr *last_initializer, locus where)
10306 {
10307 gfc_expr *result;
10308 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
10309
10310 mpz_init (result->value.integer);
10311
10312 if (last_initializer != NULL)
10313 {
10314 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
10315 result->where = last_initializer->where;
10316
10317 if (gfc_check_integer_range (result->value.integer,
10318 gfc_c_int_kind) != ARITH_OK)
10319 {
10320 gfc_error ("Enumerator exceeds the C integer type at %C");
10321 return NULL;
10322 }
10323 }
10324 else
10325 {
10326 /* Control comes here, if it's the very first enumerator and no
10327 initializer has been given. It will be initialized to zero. */
10328 mpz_set_si (result->value.integer, 0);
10329 }
10330
10331 return result;
10332 }
10333
10334
10335 /* Match a variable name with an optional initializer. When this
10336 subroutine is called, a variable is expected to be parsed next.
10337 Depending on what is happening at the moment, updates either the
10338 symbol table or the current interface. */
10339
10340 static match
enumerator_decl(void)10341 enumerator_decl (void)
10342 {
10343 char name[GFC_MAX_SYMBOL_LEN + 1];
10344 gfc_expr *initializer;
10345 gfc_array_spec *as = NULL;
10346 gfc_symbol *sym;
10347 locus var_locus;
10348 match m;
10349 bool t;
10350 locus old_locus;
10351
10352 initializer = NULL;
10353 old_locus = gfc_current_locus;
10354
10355 /* When we get here, we've just matched a list of attributes and
10356 maybe a type and a double colon. The next thing we expect to see
10357 is the name of the symbol. */
10358 m = gfc_match_name (name);
10359 if (m != MATCH_YES)
10360 goto cleanup;
10361
10362 var_locus = gfc_current_locus;
10363
10364 /* OK, we've successfully matched the declaration. Now put the
10365 symbol in the current namespace. If we fail to create the symbol,
10366 bail out. */
10367 if (!build_sym (name, NULL, false, &as, &var_locus))
10368 {
10369 m = MATCH_ERROR;
10370 goto cleanup;
10371 }
10372
10373 /* The double colon must be present in order to have initializers.
10374 Otherwise the statement is ambiguous with an assignment statement. */
10375 if (colon_seen)
10376 {
10377 if (gfc_match_char ('=') == MATCH_YES)
10378 {
10379 m = gfc_match_init_expr (&initializer);
10380 if (m == MATCH_NO)
10381 {
10382 gfc_error ("Expected an initialization expression at %C");
10383 m = MATCH_ERROR;
10384 }
10385
10386 if (m != MATCH_YES)
10387 goto cleanup;
10388 }
10389 }
10390
10391 /* If we do not have an initializer, the initialization value of the
10392 previous enumerator (stored in last_initializer) is incremented
10393 by 1 and is used to initialize the current enumerator. */
10394 if (initializer == NULL)
10395 initializer = enum_initializer (last_initializer, old_locus);
10396
10397 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
10398 {
10399 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10400 &var_locus);
10401 m = MATCH_ERROR;
10402 goto cleanup;
10403 }
10404
10405 /* Store this current initializer, for the next enumerator variable
10406 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10407 use last_initializer below. */
10408 last_initializer = initializer;
10409 t = add_init_expr_to_sym (name, &initializer, &var_locus);
10410
10411 /* Maintain enumerator history. */
10412 gfc_find_symbol (name, NULL, 0, &sym);
10413 create_enum_history (sym, last_initializer);
10414
10415 return (t) ? MATCH_YES : MATCH_ERROR;
10416
10417 cleanup:
10418 /* Free stuff up and return. */
10419 gfc_free_expr (initializer);
10420
10421 return m;
10422 }
10423
10424
10425 /* Match the enumerator definition statement. */
10426
10427 match
gfc_match_enumerator_def(void)10428 gfc_match_enumerator_def (void)
10429 {
10430 match m;
10431 bool t;
10432
10433 gfc_clear_ts (¤t_ts);
10434
10435 m = gfc_match (" enumerator");
10436 if (m != MATCH_YES)
10437 return m;
10438
10439 m = gfc_match (" :: ");
10440 if (m == MATCH_ERROR)
10441 return m;
10442
10443 colon_seen = (m == MATCH_YES);
10444
10445 if (gfc_current_state () != COMP_ENUM)
10446 {
10447 gfc_error ("ENUM definition statement expected before %C");
10448 gfc_free_enum_history ();
10449 return MATCH_ERROR;
10450 }
10451
10452 (¤t_ts)->type = BT_INTEGER;
10453 (¤t_ts)->kind = gfc_c_int_kind;
10454
10455 gfc_clear_attr (¤t_attr);
10456 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
10457 if (!t)
10458 {
10459 m = MATCH_ERROR;
10460 goto cleanup;
10461 }
10462
10463 for (;;)
10464 {
10465 m = enumerator_decl ();
10466 if (m == MATCH_ERROR)
10467 {
10468 gfc_free_enum_history ();
10469 goto cleanup;
10470 }
10471 if (m == MATCH_NO)
10472 break;
10473
10474 if (gfc_match_eos () == MATCH_YES)
10475 goto cleanup;
10476 if (gfc_match_char (',') != MATCH_YES)
10477 break;
10478 }
10479
10480 if (gfc_current_state () == COMP_ENUM)
10481 {
10482 gfc_free_enum_history ();
10483 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10484 m = MATCH_ERROR;
10485 }
10486
10487 cleanup:
10488 gfc_free_array_spec (current_as);
10489 current_as = NULL;
10490 return m;
10491
10492 }
10493
10494
10495 /* Match binding attributes. */
10496
10497 static match
match_binding_attributes(gfc_typebound_proc * ba,bool generic,bool ppc)10498 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
10499 {
10500 bool found_passing = false;
10501 bool seen_ptr = false;
10502 match m = MATCH_YES;
10503
10504 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10505 this case the defaults are in there. */
10506 ba->access = ACCESS_UNKNOWN;
10507 ba->pass_arg = NULL;
10508 ba->pass_arg_num = 0;
10509 ba->nopass = 0;
10510 ba->non_overridable = 0;
10511 ba->deferred = 0;
10512 ba->ppc = ppc;
10513
10514 /* If we find a comma, we believe there are binding attributes. */
10515 m = gfc_match_char (',');
10516 if (m == MATCH_NO)
10517 goto done;
10518
10519 do
10520 {
10521 /* Access specifier. */
10522
10523 m = gfc_match (" public");
10524 if (m == MATCH_ERROR)
10525 goto error;
10526 if (m == MATCH_YES)
10527 {
10528 if (ba->access != ACCESS_UNKNOWN)
10529 {
10530 gfc_error ("Duplicate access-specifier at %C");
10531 goto error;
10532 }
10533
10534 ba->access = ACCESS_PUBLIC;
10535 continue;
10536 }
10537
10538 m = gfc_match (" private");
10539 if (m == MATCH_ERROR)
10540 goto error;
10541 if (m == MATCH_YES)
10542 {
10543 if (ba->access != ACCESS_UNKNOWN)
10544 {
10545 gfc_error ("Duplicate access-specifier at %C");
10546 goto error;
10547 }
10548
10549 ba->access = ACCESS_PRIVATE;
10550 continue;
10551 }
10552
10553 /* If inside GENERIC, the following is not allowed. */
10554 if (!generic)
10555 {
10556
10557 /* NOPASS flag. */
10558 m = gfc_match (" nopass");
10559 if (m == MATCH_ERROR)
10560 goto error;
10561 if (m == MATCH_YES)
10562 {
10563 if (found_passing)
10564 {
10565 gfc_error ("Binding attributes already specify passing,"
10566 " illegal NOPASS at %C");
10567 goto error;
10568 }
10569
10570 found_passing = true;
10571 ba->nopass = 1;
10572 continue;
10573 }
10574
10575 /* PASS possibly including argument. */
10576 m = gfc_match (" pass");
10577 if (m == MATCH_ERROR)
10578 goto error;
10579 if (m == MATCH_YES)
10580 {
10581 char arg[GFC_MAX_SYMBOL_LEN + 1];
10582
10583 if (found_passing)
10584 {
10585 gfc_error ("Binding attributes already specify passing,"
10586 " illegal PASS at %C");
10587 goto error;
10588 }
10589
10590 m = gfc_match (" ( %n )", arg);
10591 if (m == MATCH_ERROR)
10592 goto error;
10593 if (m == MATCH_YES)
10594 ba->pass_arg = gfc_get_string ("%s", arg);
10595 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
10596
10597 found_passing = true;
10598 ba->nopass = 0;
10599 continue;
10600 }
10601
10602 if (ppc)
10603 {
10604 /* POINTER flag. */
10605 m = gfc_match (" pointer");
10606 if (m == MATCH_ERROR)
10607 goto error;
10608 if (m == MATCH_YES)
10609 {
10610 if (seen_ptr)
10611 {
10612 gfc_error ("Duplicate POINTER attribute at %C");
10613 goto error;
10614 }
10615
10616 seen_ptr = true;
10617 continue;
10618 }
10619 }
10620 else
10621 {
10622 /* NON_OVERRIDABLE flag. */
10623 m = gfc_match (" non_overridable");
10624 if (m == MATCH_ERROR)
10625 goto error;
10626 if (m == MATCH_YES)
10627 {
10628 if (ba->non_overridable)
10629 {
10630 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10631 goto error;
10632 }
10633
10634 ba->non_overridable = 1;
10635 continue;
10636 }
10637
10638 /* DEFERRED flag. */
10639 m = gfc_match (" deferred");
10640 if (m == MATCH_ERROR)
10641 goto error;
10642 if (m == MATCH_YES)
10643 {
10644 if (ba->deferred)
10645 {
10646 gfc_error ("Duplicate DEFERRED at %C");
10647 goto error;
10648 }
10649
10650 ba->deferred = 1;
10651 continue;
10652 }
10653 }
10654
10655 }
10656
10657 /* Nothing matching found. */
10658 if (generic)
10659 gfc_error ("Expected access-specifier at %C");
10660 else
10661 gfc_error ("Expected binding attribute at %C");
10662 goto error;
10663 }
10664 while (gfc_match_char (',') == MATCH_YES);
10665
10666 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10667 if (ba->non_overridable && ba->deferred)
10668 {
10669 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10670 goto error;
10671 }
10672
10673 m = MATCH_YES;
10674
10675 done:
10676 if (ba->access == ACCESS_UNKNOWN)
10677 ba->access = ppc ? gfc_current_block()->component_access
10678 : gfc_typebound_default_access;
10679
10680 if (ppc && !seen_ptr)
10681 {
10682 gfc_error ("POINTER attribute is required for procedure pointer component"
10683 " at %C");
10684 goto error;
10685 }
10686
10687 return m;
10688
10689 error:
10690 return MATCH_ERROR;
10691 }
10692
10693
10694 /* Match a PROCEDURE specific binding inside a derived type. */
10695
10696 static match
match_procedure_in_type(void)10697 match_procedure_in_type (void)
10698 {
10699 char name[GFC_MAX_SYMBOL_LEN + 1];
10700 char target_buf[GFC_MAX_SYMBOL_LEN + 1];
10701 char* target = NULL, *ifc = NULL;
10702 gfc_typebound_proc tb;
10703 bool seen_colons;
10704 bool seen_attrs;
10705 match m;
10706 gfc_symtree* stree;
10707 gfc_namespace* ns;
10708 gfc_symbol* block;
10709 int num;
10710
10711 /* Check current state. */
10712 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
10713 block = gfc_state_stack->previous->sym;
10714 gcc_assert (block);
10715
10716 /* Try to match PROCEDURE(interface). */
10717 if (gfc_match (" (") == MATCH_YES)
10718 {
10719 m = gfc_match_name (target_buf);
10720 if (m == MATCH_ERROR)
10721 return m;
10722 if (m != MATCH_YES)
10723 {
10724 gfc_error ("Interface-name expected after %<(%> at %C");
10725 return MATCH_ERROR;
10726 }
10727
10728 if (gfc_match (" )") != MATCH_YES)
10729 {
10730 gfc_error ("%<)%> expected at %C");
10731 return MATCH_ERROR;
10732 }
10733
10734 ifc = target_buf;
10735 }
10736
10737 /* Construct the data structure. */
10738 memset (&tb, 0, sizeof (tb));
10739 tb.where = gfc_current_locus;
10740
10741 /* Match binding attributes. */
10742 m = match_binding_attributes (&tb, false, false);
10743 if (m == MATCH_ERROR)
10744 return m;
10745 seen_attrs = (m == MATCH_YES);
10746
10747 /* Check that attribute DEFERRED is given if an interface is specified. */
10748 if (tb.deferred && !ifc)
10749 {
10750 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10751 return MATCH_ERROR;
10752 }
10753 if (ifc && !tb.deferred)
10754 {
10755 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10756 return MATCH_ERROR;
10757 }
10758
10759 /* Match the colons. */
10760 m = gfc_match (" ::");
10761 if (m == MATCH_ERROR)
10762 return m;
10763 seen_colons = (m == MATCH_YES);
10764 if (seen_attrs && !seen_colons)
10765 {
10766 gfc_error ("Expected %<::%> after binding-attributes at %C");
10767 return MATCH_ERROR;
10768 }
10769
10770 /* Match the binding names. */
10771 for(num=1;;num++)
10772 {
10773 m = gfc_match_name (name);
10774 if (m == MATCH_ERROR)
10775 return m;
10776 if (m == MATCH_NO)
10777 {
10778 gfc_error ("Expected binding name at %C");
10779 return MATCH_ERROR;
10780 }
10781
10782 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
10783 return MATCH_ERROR;
10784
10785 /* Try to match the '=> target', if it's there. */
10786 target = ifc;
10787 m = gfc_match (" =>");
10788 if (m == MATCH_ERROR)
10789 return m;
10790 if (m == MATCH_YES)
10791 {
10792 if (tb.deferred)
10793 {
10794 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10795 return MATCH_ERROR;
10796 }
10797
10798 if (!seen_colons)
10799 {
10800 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10801 " at %C");
10802 return MATCH_ERROR;
10803 }
10804
10805 m = gfc_match_name (target_buf);
10806 if (m == MATCH_ERROR)
10807 return m;
10808 if (m == MATCH_NO)
10809 {
10810 gfc_error ("Expected binding target after %<=>%> at %C");
10811 return MATCH_ERROR;
10812 }
10813 target = target_buf;
10814 }
10815
10816 /* If no target was found, it has the same name as the binding. */
10817 if (!target)
10818 target = name;
10819
10820 /* Get the namespace to insert the symbols into. */
10821 ns = block->f2k_derived;
10822 gcc_assert (ns);
10823
10824 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10825 if (tb.deferred && !block->attr.abstract)
10826 {
10827 gfc_error ("Type %qs containing DEFERRED binding at %C "
10828 "is not ABSTRACT", block->name);
10829 return MATCH_ERROR;
10830 }
10831
10832 /* See if we already have a binding with this name in the symtree which
10833 would be an error. If a GENERIC already targeted this binding, it may
10834 be already there but then typebound is still NULL. */
10835 stree = gfc_find_symtree (ns->tb_sym_root, name);
10836 if (stree && stree->n.tb)
10837 {
10838 gfc_error ("There is already a procedure with binding name %qs for "
10839 "the derived type %qs at %C", name, block->name);
10840 return MATCH_ERROR;
10841 }
10842
10843 /* Insert it and set attributes. */
10844
10845 if (!stree)
10846 {
10847 stree = gfc_new_symtree (&ns->tb_sym_root, name);
10848 gcc_assert (stree);
10849 }
10850 stree->n.tb = gfc_get_typebound_proc (&tb);
10851
10852 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
10853 false))
10854 return MATCH_ERROR;
10855 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
10856 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
10857 target, &stree->n.tb->u.specific->n.sym->declared_at);
10858
10859 if (gfc_match_eos () == MATCH_YES)
10860 return MATCH_YES;
10861 if (gfc_match_char (',') != MATCH_YES)
10862 goto syntax;
10863 }
10864
10865 syntax:
10866 gfc_error ("Syntax error in PROCEDURE statement at %C");
10867 return MATCH_ERROR;
10868 }
10869
10870
10871 /* Match a GENERIC procedure binding inside a derived type. */
10872
10873 match
gfc_match_generic(void)10874 gfc_match_generic (void)
10875 {
10876 char name[GFC_MAX_SYMBOL_LEN + 1];
10877 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
10878 gfc_symbol* block;
10879 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
10880 gfc_typebound_proc* tb;
10881 gfc_namespace* ns;
10882 interface_type op_type;
10883 gfc_intrinsic_op op;
10884 match m;
10885
10886 /* Check current state. */
10887 if (gfc_current_state () == COMP_DERIVED)
10888 {
10889 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10890 return MATCH_ERROR;
10891 }
10892 if (gfc_current_state () != COMP_DERIVED_CONTAINS)
10893 return MATCH_NO;
10894 block = gfc_state_stack->previous->sym;
10895 ns = block->f2k_derived;
10896 gcc_assert (block && ns);
10897
10898 memset (&tbattr, 0, sizeof (tbattr));
10899 tbattr.where = gfc_current_locus;
10900
10901 /* See if we get an access-specifier. */
10902 m = match_binding_attributes (&tbattr, true, false);
10903 if (m == MATCH_ERROR)
10904 goto error;
10905
10906 /* Now the colons, those are required. */
10907 if (gfc_match (" ::") != MATCH_YES)
10908 {
10909 gfc_error ("Expected %<::%> at %C");
10910 goto error;
10911 }
10912
10913 /* Match the binding name; depending on type (operator / generic) format
10914 it for future error messages into bind_name. */
10915
10916 m = gfc_match_generic_spec (&op_type, name, &op);
10917 if (m == MATCH_ERROR)
10918 return MATCH_ERROR;
10919 if (m == MATCH_NO)
10920 {
10921 gfc_error ("Expected generic name or operator descriptor at %C");
10922 goto error;
10923 }
10924
10925 switch (op_type)
10926 {
10927 case INTERFACE_GENERIC:
10928 case INTERFACE_DTIO:
10929 snprintf (bind_name, sizeof (bind_name), "%s", name);
10930 break;
10931
10932 case INTERFACE_USER_OP:
10933 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
10934 break;
10935
10936 case INTERFACE_INTRINSIC_OP:
10937 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
10938 gfc_op2string (op));
10939 break;
10940
10941 case INTERFACE_NAMELESS:
10942 gfc_error ("Malformed GENERIC statement at %C");
10943 goto error;
10944 break;
10945
10946 default:
10947 gcc_unreachable ();
10948 }
10949
10950 /* Match the required =>. */
10951 if (gfc_match (" =>") != MATCH_YES)
10952 {
10953 gfc_error ("Expected %<=>%> at %C");
10954 goto error;
10955 }
10956
10957 /* Try to find existing GENERIC binding with this name / for this operator;
10958 if there is something, check that it is another GENERIC and then extend
10959 it rather than building a new node. Otherwise, create it and put it
10960 at the right position. */
10961
10962 switch (op_type)
10963 {
10964 case INTERFACE_DTIO:
10965 case INTERFACE_USER_OP:
10966 case INTERFACE_GENERIC:
10967 {
10968 const bool is_op = (op_type == INTERFACE_USER_OP);
10969 gfc_symtree* st;
10970
10971 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
10972 tb = st ? st->n.tb : NULL;
10973 break;
10974 }
10975
10976 case INTERFACE_INTRINSIC_OP:
10977 tb = ns->tb_op[op];
10978 break;
10979
10980 default:
10981 gcc_unreachable ();
10982 }
10983
10984 if (tb)
10985 {
10986 if (!tb->is_generic)
10987 {
10988 gcc_assert (op_type == INTERFACE_GENERIC);
10989 gfc_error ("There's already a non-generic procedure with binding name"
10990 " %qs for the derived type %qs at %C",
10991 bind_name, block->name);
10992 goto error;
10993 }
10994
10995 if (tb->access != tbattr.access)
10996 {
10997 gfc_error ("Binding at %C must have the same access as already"
10998 " defined binding %qs", bind_name);
10999 goto error;
11000 }
11001 }
11002 else
11003 {
11004 tb = gfc_get_typebound_proc (NULL);
11005 tb->where = gfc_current_locus;
11006 tb->access = tbattr.access;
11007 tb->is_generic = 1;
11008 tb->u.generic = NULL;
11009
11010 switch (op_type)
11011 {
11012 case INTERFACE_DTIO:
11013 case INTERFACE_GENERIC:
11014 case INTERFACE_USER_OP:
11015 {
11016 const bool is_op = (op_type == INTERFACE_USER_OP);
11017 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
11018 &ns->tb_sym_root, name);
11019 gcc_assert (st);
11020 st->n.tb = tb;
11021
11022 break;
11023 }
11024
11025 case INTERFACE_INTRINSIC_OP:
11026 ns->tb_op[op] = tb;
11027 break;
11028
11029 default:
11030 gcc_unreachable ();
11031 }
11032 }
11033
11034 /* Now, match all following names as specific targets. */
11035 do
11036 {
11037 gfc_symtree* target_st;
11038 gfc_tbp_generic* target;
11039
11040 m = gfc_match_name (name);
11041 if (m == MATCH_ERROR)
11042 goto error;
11043 if (m == MATCH_NO)
11044 {
11045 gfc_error ("Expected specific binding name at %C");
11046 goto error;
11047 }
11048
11049 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
11050
11051 /* See if this is a duplicate specification. */
11052 for (target = tb->u.generic; target; target = target->next)
11053 if (target_st == target->specific_st)
11054 {
11055 gfc_error ("%qs already defined as specific binding for the"
11056 " generic %qs at %C", name, bind_name);
11057 goto error;
11058 }
11059
11060 target = gfc_get_tbp_generic ();
11061 target->specific_st = target_st;
11062 target->specific = NULL;
11063 target->next = tb->u.generic;
11064 target->is_operator = ((op_type == INTERFACE_USER_OP)
11065 || (op_type == INTERFACE_INTRINSIC_OP));
11066 tb->u.generic = target;
11067 }
11068 while (gfc_match (" ,") == MATCH_YES);
11069
11070 /* Here should be the end. */
11071 if (gfc_match_eos () != MATCH_YES)
11072 {
11073 gfc_error ("Junk after GENERIC binding at %C");
11074 goto error;
11075 }
11076
11077 return MATCH_YES;
11078
11079 error:
11080 return MATCH_ERROR;
11081 }
11082
11083
11084 /* Match a FINAL declaration inside a derived type. */
11085
11086 match
gfc_match_final_decl(void)11087 gfc_match_final_decl (void)
11088 {
11089 char name[GFC_MAX_SYMBOL_LEN + 1];
11090 gfc_symbol* sym;
11091 match m;
11092 gfc_namespace* module_ns;
11093 bool first, last;
11094 gfc_symbol* block;
11095
11096 if (gfc_current_form == FORM_FREE)
11097 {
11098 char c = gfc_peek_ascii_char ();
11099 if (!gfc_is_whitespace (c) && c != ':')
11100 return MATCH_NO;
11101 }
11102
11103 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
11104 {
11105 if (gfc_current_form == FORM_FIXED)
11106 return MATCH_NO;
11107
11108 gfc_error ("FINAL declaration at %C must be inside a derived type "
11109 "CONTAINS section");
11110 return MATCH_ERROR;
11111 }
11112
11113 block = gfc_state_stack->previous->sym;
11114 gcc_assert (block);
11115
11116 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
11117 || gfc_state_stack->previous->previous->state != COMP_MODULE)
11118 {
11119 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11120 " specification part of a MODULE");
11121 return MATCH_ERROR;
11122 }
11123
11124 module_ns = gfc_current_ns;
11125 gcc_assert (module_ns);
11126 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
11127
11128 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11129 if (gfc_match (" ::") == MATCH_ERROR)
11130 return MATCH_ERROR;
11131
11132 /* Match the sequence of procedure names. */
11133 first = true;
11134 last = false;
11135 do
11136 {
11137 gfc_finalizer* f;
11138
11139 if (first && gfc_match_eos () == MATCH_YES)
11140 {
11141 gfc_error ("Empty FINAL at %C");
11142 return MATCH_ERROR;
11143 }
11144
11145 m = gfc_match_name (name);
11146 if (m == MATCH_NO)
11147 {
11148 gfc_error ("Expected module procedure name at %C");
11149 return MATCH_ERROR;
11150 }
11151 else if (m != MATCH_YES)
11152 return MATCH_ERROR;
11153
11154 if (gfc_match_eos () == MATCH_YES)
11155 last = true;
11156 if (!last && gfc_match_char (',') != MATCH_YES)
11157 {
11158 gfc_error ("Expected %<,%> at %C");
11159 return MATCH_ERROR;
11160 }
11161
11162 if (gfc_get_symbol (name, module_ns, &sym))
11163 {
11164 gfc_error ("Unknown procedure name %qs at %C", name);
11165 return MATCH_ERROR;
11166 }
11167
11168 /* Mark the symbol as module procedure. */
11169 if (sym->attr.proc != PROC_MODULE
11170 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
11171 return MATCH_ERROR;
11172
11173 /* Check if we already have this symbol in the list, this is an error. */
11174 for (f = block->f2k_derived->finalizers; f; f = f->next)
11175 if (f->proc_sym == sym)
11176 {
11177 gfc_error ("%qs at %C is already defined as FINAL procedure",
11178 name);
11179 return MATCH_ERROR;
11180 }
11181
11182 /* Add this symbol to the list of finalizers. */
11183 gcc_assert (block->f2k_derived);
11184 sym->refs++;
11185 f = XCNEW (gfc_finalizer);
11186 f->proc_sym = sym;
11187 f->proc_tree = NULL;
11188 f->where = gfc_current_locus;
11189 f->next = block->f2k_derived->finalizers;
11190 block->f2k_derived->finalizers = f;
11191
11192 first = false;
11193 }
11194 while (!last);
11195
11196 return MATCH_YES;
11197 }
11198
11199
11200 const ext_attr_t ext_attr_list[] = {
11201 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
11202 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
11203 { "cdecl", EXT_ATTR_CDECL, "cdecl" },
11204 { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
11205 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
11206 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
11207 { NULL, EXT_ATTR_LAST, NULL }
11208 };
11209
11210 /* Match a !GCC$ ATTRIBUTES statement of the form:
11211 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11212 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11213
11214 TODO: We should support all GCC attributes using the same syntax for
11215 the attribute list, i.e. the list in C
11216 __attributes(( attribute-list ))
11217 matches then
11218 !GCC$ ATTRIBUTES attribute-list ::
11219 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11220 saved into a TREE.
11221
11222 As there is absolutely no risk of confusion, we should never return
11223 MATCH_NO. */
11224 match
gfc_match_gcc_attributes(void)11225 gfc_match_gcc_attributes (void)
11226 {
11227 symbol_attribute attr;
11228 char name[GFC_MAX_SYMBOL_LEN + 1];
11229 unsigned id;
11230 gfc_symbol *sym;
11231 match m;
11232
11233 gfc_clear_attr (&attr);
11234 for(;;)
11235 {
11236 char ch;
11237
11238 if (gfc_match_name (name) != MATCH_YES)
11239 return MATCH_ERROR;
11240
11241 for (id = 0; id < EXT_ATTR_LAST; id++)
11242 if (strcmp (name, ext_attr_list[id].name) == 0)
11243 break;
11244
11245 if (id == EXT_ATTR_LAST)
11246 {
11247 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11248 return MATCH_ERROR;
11249 }
11250
11251 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
11252 return MATCH_ERROR;
11253
11254 gfc_gobble_whitespace ();
11255 ch = gfc_next_ascii_char ();
11256 if (ch == ':')
11257 {
11258 /* This is the successful exit condition for the loop. */
11259 if (gfc_next_ascii_char () == ':')
11260 break;
11261 }
11262
11263 if (ch == ',')
11264 continue;
11265
11266 goto syntax;
11267 }
11268
11269 if (gfc_match_eos () == MATCH_YES)
11270 goto syntax;
11271
11272 for(;;)
11273 {
11274 m = gfc_match_name (name);
11275 if (m != MATCH_YES)
11276 return m;
11277
11278 if (find_special (name, &sym, true))
11279 return MATCH_ERROR;
11280
11281 sym->attr.ext_attr |= attr.ext_attr;
11282
11283 if (gfc_match_eos () == MATCH_YES)
11284 break;
11285
11286 if (gfc_match_char (',') != MATCH_YES)
11287 goto syntax;
11288 }
11289
11290 return MATCH_YES;
11291
11292 syntax:
11293 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11294 return MATCH_ERROR;
11295 }
11296
11297
11298 /* Match a !GCC$ UNROLL statement of the form:
11299 !GCC$ UNROLL n
11300
11301 The parameter n is the number of times we are supposed to unroll.
11302
11303 When we come here, we have already matched the !GCC$ UNROLL string. */
11304 match
gfc_match_gcc_unroll(void)11305 gfc_match_gcc_unroll (void)
11306 {
11307 int value;
11308
11309 if (gfc_match_small_int (&value) == MATCH_YES)
11310 {
11311 if (value < 0 || value > USHRT_MAX)
11312 {
11313 gfc_error ("%<GCC unroll%> directive requires a"
11314 " non-negative integral constant"
11315 " less than or equal to %u at %C",
11316 USHRT_MAX
11317 );
11318 return MATCH_ERROR;
11319 }
11320 if (gfc_match_eos () == MATCH_YES)
11321 {
11322 directive_unroll = value == 0 ? 1 : value;
11323 return MATCH_YES;
11324 }
11325 }
11326
11327 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11328 return MATCH_ERROR;
11329 }
11330