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