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