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