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