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