]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/decl.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
fix changelog entry
[thirdparty/gcc.git] / gcc / fortran / decl.c
CommitLineData
4ee9c684 1/* Declaration statement matcher
1a9745d2 2 Copyright (C) 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4ee9c684 4 Contributed by Andy Vaught
5
c84b470d 6This file is part of GCC.
4ee9c684 7
c84b470d 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
bdabe786 10Software Foundation; either version 3, or (at your option) any later
c84b470d 11version.
4ee9c684 12
c84b470d 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.
4ee9c684 17
18You should have received a copy of the GNU General Public License
bdabe786 19along with GCC; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. */
4ee9c684 21
4ee9c684 22#include "config.h"
7436502b 23#include "system.h"
4ee9c684 24#include "gfortran.h"
25#include "match.h"
26#include "parse.h"
4ee9c684 27
36ae04f2 28/* This flag is set if an old-style length selector is matched
4ee9c684 29 during a type-declaration statement. */
30
31static int old_char_selector;
32
5739e54e 33/* When variables acquire types and attributes from a declaration
4ee9c684 34 statement, they get them from the following static variables. The
35 first part of a declaration sets these variables and the second
36 part copies these into symbol structures. */
37
38static gfc_typespec current_ts;
39
40static symbol_attribute current_attr;
41static gfc_array_spec *current_as;
42static int colon_seen;
43
c5d33754 44/* The current binding label (if any). */
45static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
46/* Need to know how many identifiers are on the current data declaration
47 line in case we're given the BIND(C) attribute with a NAME= specifier. */
48static int num_idents_on_line;
49/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
50 can supply a name if the curr_binding_label is nil and NAME= was not. */
51static int has_name_equals = 0;
52
3b6a4b41 53/* Initializer of the previous enumerator. */
54
55static gfc_expr *last_initializer;
56
57/* History of all the enumerators is maintained, so that
58 kind values of all the enumerators could be updated depending
59 upon the maximum initialized value. */
60
61typedef struct enumerator_history
62{
63 gfc_symbol *sym;
64 gfc_expr *initializer;
65 struct enumerator_history *next;
66}
67enumerator_history;
68
69/* Header of enum history chain. */
70
71static enumerator_history *enum_history = NULL;
72
73/* Pointer of enum history node containing largest initializer. */
74
75static enumerator_history *max_enum = NULL;
76
4ee9c684 77/* gfc_new_block points to the symbol of a newly matched block. */
78
79gfc_symbol *gfc_new_block;
80
81
b4f45d02 82/********************* DATA statement subroutines *********************/
83
1bfea7e8 84static bool in_match_data = false;
85
86bool
87gfc_in_match_data (void)
88{
89 return in_match_data;
90}
91
92void
93gfc_set_in_match_data (bool set_value)
94{
95 in_match_data = set_value;
96}
97
b4f45d02 98/* Free a gfc_data_variable structure and everything beneath it. */
99
100static void
1a9745d2 101free_variable (gfc_data_variable *p)
b4f45d02 102{
103 gfc_data_variable *q;
104
105 for (; p; p = q)
106 {
107 q = p->next;
108 gfc_free_expr (p->expr);
109 gfc_free_iterator (&p->iter, 0);
110 free_variable (p->list);
b4f45d02 111 gfc_free (p);
112 }
113}
114
115
116/* Free a gfc_data_value structure and everything beneath it. */
117
118static void
1a9745d2 119free_value (gfc_data_value *p)
b4f45d02 120{
121 gfc_data_value *q;
122
123 for (; p; p = q)
124 {
125 q = p->next;
126 gfc_free_expr (p->expr);
127 gfc_free (p);
128 }
129}
130
131
132/* Free a list of gfc_data structures. */
133
134void
1a9745d2 135gfc_free_data (gfc_data *p)
b4f45d02 136{
137 gfc_data *q;
138
139 for (; p; p = q)
140 {
141 q = p->next;
b4f45d02 142 free_variable (p->var);
143 free_value (p->value);
b4f45d02 144 gfc_free (p);
145 }
146}
147
148
af29c1f0 149/* Free all data in a namespace. */
1a9745d2 150
af29c1f0 151static void
f6d0e37a 152gfc_free_data_all (gfc_namespace *ns)
af29c1f0 153{
154 gfc_data *d;
155
156 for (;ns->data;)
157 {
158 d = ns->data->next;
159 gfc_free (ns->data);
160 ns->data = d;
161 }
162}
163
164
b4f45d02 165static match var_element (gfc_data_variable *);
166
167/* Match a list of variables terminated by an iterator and a right
168 parenthesis. */
169
170static match
1a9745d2 171var_list (gfc_data_variable *parent)
b4f45d02 172{
173 gfc_data_variable *tail, var;
174 match m;
175
176 m = var_element (&var);
177 if (m == MATCH_ERROR)
178 return MATCH_ERROR;
179 if (m == MATCH_NO)
180 goto syntax;
181
182 tail = gfc_get_data_variable ();
183 *tail = var;
184
185 parent->list = tail;
186
187 for (;;)
188 {
189 if (gfc_match_char (',') != MATCH_YES)
190 goto syntax;
191
192 m = gfc_match_iterator (&parent->iter, 1);
193 if (m == MATCH_YES)
194 break;
195 if (m == MATCH_ERROR)
196 return MATCH_ERROR;
197
198 m = var_element (&var);
199 if (m == MATCH_ERROR)
200 return MATCH_ERROR;
201 if (m == MATCH_NO)
202 goto syntax;
203
204 tail->next = gfc_get_data_variable ();
205 tail = tail->next;
206
207 *tail = var;
208 }
209
210 if (gfc_match_char (')') != MATCH_YES)
211 goto syntax;
212 return MATCH_YES;
213
214syntax:
215 gfc_syntax_error (ST_DATA);
216 return MATCH_ERROR;
217}
218
219
220/* Match a single element in a data variable list, which can be a
221 variable-iterator list. */
222
223static match
1a9745d2 224var_element (gfc_data_variable *new)
b4f45d02 225{
226 match m;
227 gfc_symbol *sym;
228
229 memset (new, 0, sizeof (gfc_data_variable));
230
231 if (gfc_match_char ('(') == MATCH_YES)
232 return var_list (new);
233
234 m = gfc_match_variable (&new->expr, 0);
235 if (m != MATCH_YES)
236 return m;
237
238 sym = new->expr->symtree->n.sym;
239
1a9745d2 240 if (!sym->attr.function && gfc_current_ns->parent
241 && gfc_current_ns->parent == sym->ns)
b4f45d02 242 {
c8df3e9c 243 gfc_error ("Host associated variable '%s' may not be in the DATA "
7698a624 244 "statement at %C", sym->name);
b4f45d02 245 return MATCH_ERROR;
246 }
247
c8df3e9c 248 if (gfc_current_state () != COMP_BLOCK_DATA
1a9745d2 249 && sym->attr.in_common
250 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
251 "common block variable '%s' in DATA statement at %C",
252 sym->name) == FAILURE)
c8df3e9c 253 return MATCH_ERROR;
b4f45d02 254
950683ed 255 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
b4f45d02 256 return MATCH_ERROR;
257
258 return MATCH_YES;
259}
260
261
262/* Match the top-level list of data variables. */
263
264static match
1a9745d2 265top_var_list (gfc_data *d)
b4f45d02 266{
267 gfc_data_variable var, *tail, *new;
268 match m;
269
270 tail = NULL;
271
272 for (;;)
273 {
274 m = var_element (&var);
275 if (m == MATCH_NO)
276 goto syntax;
277 if (m == MATCH_ERROR)
278 return MATCH_ERROR;
279
280 new = gfc_get_data_variable ();
281 *new = var;
282
283 if (tail == NULL)
284 d->var = new;
285 else
286 tail->next = new;
287
288 tail = new;
289
290 if (gfc_match_char ('/') == MATCH_YES)
291 break;
292 if (gfc_match_char (',') != MATCH_YES)
293 goto syntax;
294 }
295
296 return MATCH_YES;
297
298syntax:
299 gfc_syntax_error (ST_DATA);
af29c1f0 300 gfc_free_data_all (gfc_current_ns);
b4f45d02 301 return MATCH_ERROR;
302}
303
304
305static match
1a9745d2 306match_data_constant (gfc_expr **result)
b4f45d02 307{
308 char name[GFC_MAX_SYMBOL_LEN + 1];
309 gfc_symbol *sym;
310 gfc_expr *expr;
311 match m;
096d4ad9 312 locus old_loc;
b4f45d02 313
314 m = gfc_match_literal_constant (&expr, 1);
315 if (m == MATCH_YES)
316 {
317 *result = expr;
318 return MATCH_YES;
319 }
320
321 if (m == MATCH_ERROR)
322 return MATCH_ERROR;
323
324 m = gfc_match_null (result);
325 if (m != MATCH_NO)
326 return m;
327
096d4ad9 328 old_loc = gfc_current_locus;
329
330 /* Should this be a structure component, try to match it
331 before matching a name. */
332 m = gfc_match_rvalue (result);
333 if (m == MATCH_ERROR)
334 return m;
335
336 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
337 {
338 if (gfc_simplify_expr (*result, 0) == FAILURE)
339 m = MATCH_ERROR;
340 return m;
341 }
342
343 gfc_current_locus = old_loc;
344
b4f45d02 345 m = gfc_match_name (name);
346 if (m != MATCH_YES)
347 return m;
348
349 if (gfc_find_symbol (name, NULL, 1, &sym))
350 return MATCH_ERROR;
351
352 if (sym == NULL
353 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
354 {
355 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
356 name);
357 return MATCH_ERROR;
358 }
359 else if (sym->attr.flavor == FL_DERIVED)
360 return gfc_match_structure_constructor (sym, result);
361
362 *result = gfc_copy_expr (sym->value);
363 return MATCH_YES;
364}
365
366
367/* Match a list of values in a DATA statement. The leading '/' has
368 already been seen at this point. */
369
370static match
1a9745d2 371top_val_list (gfc_data *data)
b4f45d02 372{
373 gfc_data_value *new, *tail;
374 gfc_expr *expr;
375 const char *msg;
376 match m;
377
378 tail = NULL;
379
380 for (;;)
381 {
382 m = match_data_constant (&expr);
383 if (m == MATCH_NO)
384 goto syntax;
385 if (m == MATCH_ERROR)
386 return MATCH_ERROR;
387
388 new = gfc_get_data_value ();
389
390 if (tail == NULL)
391 data->value = new;
392 else
393 tail->next = new;
394
395 tail = new;
396
397 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
398 {
399 tail->expr = expr;
400 tail->repeat = 1;
401 }
402 else
403 {
404 signed int tmp;
405 msg = gfc_extract_int (expr, &tmp);
406 gfc_free_expr (expr);
407 if (msg != NULL)
408 {
409 gfc_error (msg);
410 return MATCH_ERROR;
411 }
412 tail->repeat = tmp;
413
414 m = match_data_constant (&tail->expr);
415 if (m == MATCH_NO)
416 goto syntax;
417 if (m == MATCH_ERROR)
418 return MATCH_ERROR;
419 }
420
421 if (gfc_match_char ('/') == MATCH_YES)
422 break;
423 if (gfc_match_char (',') == MATCH_NO)
424 goto syntax;
425 }
426
427 return MATCH_YES;
428
429syntax:
430 gfc_syntax_error (ST_DATA);
af29c1f0 431 gfc_free_data_all (gfc_current_ns);
b4f45d02 432 return MATCH_ERROR;
433}
434
435
436/* Matches an old style initialization. */
437
438static match
439match_old_style_init (const char *name)
440{
441 match m;
442 gfc_symtree *st;
344b937e 443 gfc_symbol *sym;
b4f45d02 444 gfc_data *newdata;
445
446 /* Set up data structure to hold initializers. */
447 gfc_find_sym_tree (name, NULL, 0, &st);
344b937e 448 sym = st->n.sym;
449
b4f45d02 450 newdata = gfc_get_data ();
451 newdata->var = gfc_get_data_variable ();
452 newdata->var->expr = gfc_get_variable_expr (st);
5aed5db3 453 newdata->where = gfc_current_locus;
b4f45d02 454
f6d0e37a 455 /* Match initial value list. This also eats the terminal '/'. */
b4f45d02 456 m = top_val_list (newdata);
457 if (m != MATCH_YES)
458 {
459 gfc_free (newdata);
460 return m;
461 }
462
463 if (gfc_pure (NULL))
464 {
465 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
466 gfc_free (newdata);
467 return MATCH_ERROR;
468 }
469
344b937e 470 /* Mark the variable as having appeared in a data statement. */
471 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
472 {
473 gfc_free (newdata);
474 return MATCH_ERROR;
475 }
476
b4f45d02 477 /* Chain in namespace list of DATA initializers. */
478 newdata->next = gfc_current_ns->data;
479 gfc_current_ns->data = newdata;
480
481 return m;
482}
483
1a9745d2 484
b4f45d02 485/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
39fca56b 486 we are matching a DATA statement and are therefore issuing an error
e14bee04 487 if we encounter something unexpected, if not, we're trying to match
fe06c0d5 488 an old-style initialization expression of the form INTEGER I /2/. */
b4f45d02 489
490match
491gfc_match_data (void)
492{
493 gfc_data *new;
494 match m;
495
1bfea7e8 496 gfc_set_in_match_data (true);
497
b4f45d02 498 for (;;)
499 {
500 new = gfc_get_data ();
501 new->where = gfc_current_locus;
502
503 m = top_var_list (new);
504 if (m != MATCH_YES)
505 goto cleanup;
506
507 m = top_val_list (new);
508 if (m != MATCH_YES)
509 goto cleanup;
510
511 new->next = gfc_current_ns->data;
512 gfc_current_ns->data = new;
513
514 if (gfc_match_eos () == MATCH_YES)
515 break;
516
517 gfc_match_char (','); /* Optional comma */
518 }
519
1bfea7e8 520 gfc_set_in_match_data (false);
521
b4f45d02 522 if (gfc_pure (NULL))
523 {
524 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
525 return MATCH_ERROR;
526 }
527
528 return MATCH_YES;
529
530cleanup:
1bfea7e8 531 gfc_set_in_match_data (false);
b4f45d02 532 gfc_free_data (new);
533 return MATCH_ERROR;
534}
535
536
537/************************ Declaration statements *********************/
538
4ee9c684 539/* Match an intent specification. Since this can only happen after an
540 INTENT word, a legal intent-spec must follow. */
541
542static sym_intent
543match_intent_spec (void)
544{
545
546 if (gfc_match (" ( in out )") == MATCH_YES)
547 return INTENT_INOUT;
548 if (gfc_match (" ( in )") == MATCH_YES)
549 return INTENT_IN;
550 if (gfc_match (" ( out )") == MATCH_YES)
551 return INTENT_OUT;
552
553 gfc_error ("Bad INTENT specification at %C");
554 return INTENT_UNKNOWN;
555}
556
557
558/* Matches a character length specification, which is either a
559 specification expression or a '*'. */
560
561static match
1a9745d2 562char_len_param_value (gfc_expr **expr)
4ee9c684 563{
4ee9c684 564 if (gfc_match_char ('*') == MATCH_YES)
565 {
566 *expr = NULL;
567 return MATCH_YES;
568 }
569
570 return gfc_match_expr (expr);
571}
572
573
574/* A character length is a '*' followed by a literal integer or a
575 char_len_param_value in parenthesis. */
576
577static match
1a9745d2 578match_char_length (gfc_expr **expr)
4ee9c684 579{
3bd3b616 580 int length;
4ee9c684 581 match m;
582
583 m = gfc_match_char ('*');
584 if (m != MATCH_YES)
585 return m;
586
3bd3b616 587 m = gfc_match_small_literal_int (&length, NULL);
4ee9c684 588 if (m == MATCH_ERROR)
589 return m;
590
591 if (m == MATCH_YES)
592 {
593 *expr = gfc_int_expr (length);
594 return m;
595 }
596
597 if (gfc_match_char ('(') == MATCH_NO)
598 goto syntax;
599
600 m = char_len_param_value (expr);
601 if (m == MATCH_ERROR)
602 return m;
603 if (m == MATCH_NO)
604 goto syntax;
605
606 if (gfc_match_char (')') == MATCH_NO)
607 {
608 gfc_free_expr (*expr);
609 *expr = NULL;
610 goto syntax;
611 }
612
613 return MATCH_YES;
614
615syntax:
616 gfc_error ("Syntax error in character length specification at %C");
617 return MATCH_ERROR;
618}
619
620
ee893be6 621/* Special subroutine for finding a symbol. Check if the name is found
622 in the current name space. If not, and we're compiling a function or
623 subroutine and the parent compilation unit is an interface, then check
624 to see if the name we've been given is the name of the interface
625 (located in another namespace). */
4ee9c684 626
627static int
1a9745d2 628find_special (const char *name, gfc_symbol **result)
4ee9c684 629{
630 gfc_state_data *s;
ee893be6 631 int i;
4ee9c684 632
ee893be6 633 i = gfc_get_symbol (name, NULL, result);
e14bee04 634 if (i == 0)
ee893be6 635 goto end;
e14bee04 636
4ee9c684 637 if (gfc_current_state () != COMP_SUBROUTINE
638 && gfc_current_state () != COMP_FUNCTION)
ee893be6 639 goto end;
4ee9c684 640
641 s = gfc_state_stack->previous;
642 if (s == NULL)
ee893be6 643 goto end;
4ee9c684 644
645 if (s->state != COMP_INTERFACE)
ee893be6 646 goto end;
4ee9c684 647 if (s->sym == NULL)
f6d0e37a 648 goto end; /* Nameless interface. */
4ee9c684 649
650 if (strcmp (name, s->sym->name) == 0)
651 {
652 *result = s->sym;
653 return 0;
654 }
655
ee893be6 656end:
657 return i;
4ee9c684 658}
659
660
661/* Special subroutine for getting a symbol node associated with a
662 procedure name, used in SUBROUTINE and FUNCTION statements. The
663 symbol is created in the parent using with symtree node in the
664 child unit pointing to the symbol. If the current namespace has no
665 parent, then the symbol is just created in the current unit. */
666
667static int
1a9745d2 668get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
4ee9c684 669{
670 gfc_symtree *st;
671 gfc_symbol *sym;
672 int rc;
673
d77f260f 674 /* Module functions have to be left in their own namespace because
675 they have potentially (almost certainly!) already been referenced.
676 In this sense, they are rather like external functions. This is
677 fixed up in resolve.c(resolve_entries), where the symbol name-
678 space is set to point to the master function, so that the fake
679 result mechanism can work. */
680 if (module_fcn_entry)
861d824f 681 {
682 /* Present if entry is declared to be a module procedure. */
683 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
c6a05992 684
861d824f 685 if (*result == NULL)
686 rc = gfc_get_symbol (name, NULL, result);
c6a05992 687 else if (gfc_get_symbol (name, NULL, &sym) == 0
688 && sym
689 && sym->ts.type != BT_UNKNOWN
690 && (*result)->ts.type == BT_UNKNOWN
691 && sym->attr.flavor == FL_UNKNOWN)
692 /* Pick up the typespec for the entry, if declared in the function
693 body. Note that this symbol is FL_UNKNOWN because it will
694 only have appeared in a type declaration. The local symtree
695 is set to point to the module symbol and a unique symtree
696 to the local version. This latter ensures a correct clearing
697 of the symbols. */
698 {
699 (*result)->ts = sym->ts;
700 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
701 st->n.sym = *result;
702 st = gfc_get_unique_symtree (gfc_current_ns);
703 st->n.sym = sym;
704 }
861d824f 705 }
858f9894 706 else
707 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
4ee9c684 708
858f9894 709 sym = *result;
c717e399 710 gfc_current_ns->refs++;
4ee9c684 711
858f9894 712 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
713 {
16f49153 714 /* Trap another encompassed procedure with the same name. All
715 these conditions are necessary to avoid picking up an entry
716 whose name clashes with that of the encompassing procedure;
717 this is handled using gsymbols to register unique,globally
718 accessible names. */
858f9894 719 if (sym->attr.flavor != 0
1a9745d2 720 && sym->attr.proc != 0
721 && (sym->attr.subroutine || sym->attr.function)
722 && sym->attr.if_source != IFSRC_UNKNOWN)
858f9894 723 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
724 name, &sym->declared_at);
725
5720fd2f 726 /* Trap a procedure with a name the same as interface in the
727 encompassing scope. */
728 if (sym->attr.generic != 0
db697236 729 && (sym->attr.subroutine || sym->attr.function)
730 && !sym->attr.mod_proc)
5720fd2f 731 gfc_error_now ("Name '%s' at %C is already defined"
732 " as a generic interface at %L",
733 name, &sym->declared_at);
734
858f9894 735 /* Trap declarations of attributes in encompassing scope. The
736 signature for this is that ts.kind is set. Legitimate
737 references only set ts.type. */
738 if (sym->ts.kind != 0
1a9745d2 739 && !sym->attr.implicit_type
740 && sym->attr.proc == 0
741 && gfc_current_ns->parent != NULL
742 && sym->attr.access == 0
743 && !module_fcn_entry)
744 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
745 "and must not have attributes declared at %L",
858f9894 746 name, &sym->declared_at);
747 }
748
749 if (gfc_current_ns->parent == NULL || *result == NULL)
750 return rc;
4ee9c684 751
d77f260f 752 /* Module function entries will already have a symtree in
753 the current namespace but will need one at module level. */
754 if (module_fcn_entry)
861d824f 755 {
756 /* Present if entry is declared to be a module procedure. */
757 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
758 if (st == NULL)
759 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
760 }
d77f260f 761 else
762 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
4ee9c684 763
4ee9c684 764 st->n.sym = sym;
765 sym->refs++;
766
f6d0e37a 767 /* See if the procedure should be a module procedure. */
4ee9c684 768
d77f260f 769 if (((sym->ns->proc_name != NULL
861d824f 770 && sym->ns->proc_name->attr.flavor == FL_MODULE
771 && sym->attr.proc != PROC_MODULE)
772 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
773 && gfc_add_procedure (&sym->attr, PROC_MODULE,
774 sym->name, NULL) == FAILURE)
4ee9c684 775 rc = 2;
776
777 return rc;
778}
779
780
c5d33754 781/* Verify that the given symbol representing a parameter is C
782 interoperable, by checking to see if it was marked as such after
783 its declaration. If the given symbol is not interoperable, a
784 warning is reported, thus removing the need to return the status to
785 the calling function. The standard does not require the user use
786 one of the iso_c_binding named constants to declare an
787 interoperable parameter, but we can't be sure if the param is C
788 interop or not if the user doesn't. For example, integer(4) may be
789 legal Fortran, but doesn't have meaning in C. It may interop with
790 a number of the C types, which causes a problem because the
791 compiler can't know which one. This code is almost certainly not
792 portable, and the user will get what they deserve if the C type
793 across platforms isn't always interoperable with integer(4). If
794 the user had used something like integer(c_int) or integer(c_long),
795 the compiler could have automatically handled the varying sizes
796 across platforms. */
797
798try
799verify_c_interop_param (gfc_symbol *sym)
800{
801 int is_c_interop = 0;
802 try retval = SUCCESS;
803
804 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
805 Don't repeat the checks here. */
806 if (sym->attr.implicit_type)
807 return SUCCESS;
808
809 /* For subroutines or functions that are passed to a BIND(C) procedure,
810 they're interoperable if they're BIND(C) and their params are all
811 interoperable. */
812 if (sym->attr.flavor == FL_PROCEDURE)
813 {
814 if (sym->attr.is_bind_c == 0)
815 {
816 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
817 "attribute to be C interoperable", sym->name,
818 &(sym->declared_at));
819
820 return FAILURE;
821 }
822 else
823 {
824 if (sym->attr.is_c_interop == 1)
825 /* We've already checked this procedure; don't check it again. */
826 return SUCCESS;
827 else
828 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
829 sym->common_block);
830 }
831 }
832
833 /* See if we've stored a reference to a procedure that owns sym. */
834 if (sym->ns != NULL && sym->ns->proc_name != NULL)
835 {
836 if (sym->ns->proc_name->attr.is_bind_c == 1)
837 {
838 is_c_interop =
839 (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
840 == SUCCESS ? 1 : 0);
841
842 if (is_c_interop != 1)
843 {
844 /* Make personalized messages to give better feedback. */
845 if (sym->ts.type == BT_DERIVED)
846 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
847 " procedure '%s' but is not C interoperable "
848 "because derived type '%s' is not C interoperable",
849 sym->name, &(sym->declared_at),
850 sym->ns->proc_name->name,
851 sym->ts.derived->name);
852 else
853 gfc_warning ("Variable '%s' at %L is a parameter to the "
854 "BIND(C) procedure '%s' but may not be C "
855 "interoperable",
856 sym->name, &(sym->declared_at),
857 sym->ns->proc_name->name);
858 }
e4eda3ec 859
860 /* Character strings are only C interoperable if they have a
861 length of 1. */
862 if (sym->ts.type == BT_CHARACTER)
863 {
864 gfc_charlen *cl = sym->ts.cl;
865 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
866 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
867 {
868 gfc_error ("Character argument '%s' at %L "
869 "must be length 1 because "
870 "procedure '%s' is BIND(C)",
871 sym->name, &sym->declared_at,
872 sym->ns->proc_name->name);
873 retval = FAILURE;
874 }
875 }
876
c5d33754 877 /* We have to make sure that any param to a bind(c) routine does
878 not have the allocatable, pointer, or optional attributes,
879 according to J3/04-007, section 5.1. */
880 if (sym->attr.allocatable == 1)
881 {
882 gfc_error ("Variable '%s' at %L cannot have the "
883 "ALLOCATABLE attribute because procedure '%s'"
884 " is BIND(C)", sym->name, &(sym->declared_at),
885 sym->ns->proc_name->name);
886 retval = FAILURE;
887 }
888
889 if (sym->attr.pointer == 1)
890 {
891 gfc_error ("Variable '%s' at %L cannot have the "
892 "POINTER attribute because procedure '%s'"
893 " is BIND(C)", sym->name, &(sym->declared_at),
894 sym->ns->proc_name->name);
895 retval = FAILURE;
896 }
897
898 if (sym->attr.optional == 1)
899 {
900 gfc_error ("Variable '%s' at %L cannot have the "
901 "OPTIONAL attribute because procedure '%s'"
902 " is BIND(C)", sym->name, &(sym->declared_at),
903 sym->ns->proc_name->name);
904 retval = FAILURE;
905 }
906
907 /* Make sure that if it has the dimension attribute, that it is
908 either assumed size or explicit shape. */
909 if (sym->as != NULL)
910 {
911 if (sym->as->type == AS_ASSUMED_SHAPE)
912 {
913 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
914 "argument to the procedure '%s' at %L because "
915 "the procedure is BIND(C)", sym->name,
916 &(sym->declared_at), sym->ns->proc_name->name,
917 &(sym->ns->proc_name->declared_at));
918 retval = FAILURE;
919 }
920
921 if (sym->as->type == AS_DEFERRED)
922 {
923 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
924 "argument to the procedure '%s' at %L because "
925 "the procedure is BIND(C)", sym->name,
926 &(sym->declared_at), sym->ns->proc_name->name,
927 &(sym->ns->proc_name->declared_at));
928 retval = FAILURE;
929 }
930 }
931 }
932 }
933
934 return retval;
935}
936
937
938/* Function called by variable_decl() that adds a name to the symbol table. */
4ee9c684 939
940static try
1a9745d2 941build_sym (const char *name, gfc_charlen *cl,
942 gfc_array_spec **as, locus *var_locus)
4ee9c684 943{
944 symbol_attribute attr;
945 gfc_symbol *sym;
946
ee893be6 947 if (gfc_get_symbol (name, NULL, &sym))
4ee9c684 948 return FAILURE;
949
f6d0e37a 950 /* Start updating the symbol table. Add basic type attribute if present. */
4ee9c684 951 if (current_ts.type != BT_UNKNOWN
1a9745d2 952 && (sym->attr.implicit_type == 0
953 || !gfc_compare_types (&sym->ts, &current_ts))
4ee9c684 954 && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
955 return FAILURE;
956
957 if (sym->ts.type == BT_CHARACTER)
958 sym->ts.cl = cl;
959
960 /* Add dimension attribute if present. */
961 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
962 return FAILURE;
963 *as = NULL;
964
965 /* Add attribute to symbol. The copy is so that we can reset the
966 dimension attribute. */
967 attr = current_attr;
968 attr.dimension = 0;
969
970 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
971 return FAILURE;
972
c5d33754 973 /* Finish any work that may need to be done for the binding label,
974 if it's a bind(c). The bind(c) attr is found before the symbol
975 is made, and before the symbol name (for data decls), so the
976 current_ts is holding the binding label, or nothing if the
977 name= attr wasn't given. Therefore, test here if we're dealing
978 with a bind(c) and make sure the binding label is set correctly. */
979 if (sym->attr.is_bind_c == 1)
980 {
981 if (sym->binding_label[0] == '\0')
982 {
983 /* Here, we're not checking the numIdents (the last param).
984 This could be an error we're letting slip through! */
985 if (set_binding_label (sym->binding_label, sym->name, 1) == FAILURE)
986 return FAILURE;
987 }
988 }
989
990 /* See if we know we're in a common block, and if it's a bind(c)
991 common then we need to make sure we're an interoperable type. */
992 if (sym->attr.in_common == 1)
993 {
994 /* Test the common block object. */
995 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
996 && sym->ts.is_c_interop != 1)
997 {
998 gfc_error_now ("Variable '%s' in common block '%s' at %C "
999 "must be declared with a C interoperable "
1000 "kind since common block '%s' is BIND(C)",
1001 sym->name, sym->common_block->name,
1002 sym->common_block->name);
1003 gfc_clear_error ();
1004 }
1005 }
1006
2457a77e 1007 sym->attr.implied_index = 0;
1008
4ee9c684 1009 return SUCCESS;
1010}
1011
1a9745d2 1012
a270dc8e 1013/* Set character constant to the given length. The constant will be padded or
1014 truncated. */
1015
1016void
1a9745d2 1017gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
a270dc8e 1018{
1a9745d2 1019 char *s;
a270dc8e 1020 int slen;
1021
1022 gcc_assert (expr->expr_type == EXPR_CONSTANT);
1023 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
1024
1025 slen = expr->value.character.length;
1026 if (len != slen)
1027 {
89f528df 1028 s = gfc_getmem (len + 1);
a270dc8e 1029 memcpy (s, expr->value.character.string, MIN (len, slen));
1030 if (len > slen)
1031 memset (&s[slen], ' ', len - slen);
1bfea7e8 1032
1033 if (gfc_option.warn_character_truncation && slen > len)
1034 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1035 "(%d/%d)", &expr->where, slen, len);
1036
1037 /* Apply the standard by 'hand' otherwise it gets cleared for
1038 initializers. */
1039 if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
1040 gfc_error_now ("The CHARACTER elements of the array constructor "
1041 "at %L must have the same length (%d/%d)",
1a9745d2 1042 &expr->where, slen, len);
1bfea7e8 1043
89f528df 1044 s[len] = '\0';
a270dc8e 1045 gfc_free (expr->value.character.string);
1046 expr->value.character.string = s;
1047 expr->value.character.length = len;
1048 }
1049}
4ee9c684 1050
3b6a4b41 1051
e14bee04 1052/* Function to create and update the enumerator history
3b6a4b41 1053 using the information passed as arguments.
e14bee04 1054 Pointer "max_enum" is also updated, to point to
1055 enum history node containing largest initializer.
3b6a4b41 1056
1057 SYM points to the symbol node of enumerator.
f6d0e37a 1058 INIT points to its enumerator value. */
3b6a4b41 1059
e14bee04 1060static void
1a9745d2 1061create_enum_history (gfc_symbol *sym, gfc_expr *init)
3b6a4b41 1062{
1063 enumerator_history *new_enum_history;
1064 gcc_assert (sym != NULL && init != NULL);
1065
1066 new_enum_history = gfc_getmem (sizeof (enumerator_history));
1067
1068 new_enum_history->sym = sym;
1069 new_enum_history->initializer = init;
1070 new_enum_history->next = NULL;
1071
1072 if (enum_history == NULL)
1073 {
1074 enum_history = new_enum_history;
1075 max_enum = enum_history;
1076 }
1077 else
1078 {
1079 new_enum_history->next = enum_history;
1080 enum_history = new_enum_history;
1081
e14bee04 1082 if (mpz_cmp (max_enum->initializer->value.integer,
3b6a4b41 1083 new_enum_history->initializer->value.integer) < 0)
1a9745d2 1084 max_enum = new_enum_history;
3b6a4b41 1085 }
1086}
1087
1088
e14bee04 1089/* Function to free enum kind history. */
3b6a4b41 1090
e14bee04 1091void
1a9745d2 1092gfc_free_enum_history (void)
3b6a4b41 1093{
e14bee04 1094 enumerator_history *current = enum_history;
1095 enumerator_history *next;
3b6a4b41 1096
1097 while (current != NULL)
1098 {
1099 next = current->next;
1100 gfc_free (current);
1101 current = next;
1102 }
1103 max_enum = NULL;
1104 enum_history = NULL;
1105}
1106
1107
4ee9c684 1108/* Function called by variable_decl() that adds an initialization
1109 expression to a symbol. */
1110
1111static try
f6d0e37a 1112add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
4ee9c684 1113{
1114 symbol_attribute attr;
1115 gfc_symbol *sym;
1116 gfc_expr *init;
1117
1118 init = *initp;
1119 if (find_special (name, &sym))
1120 return FAILURE;
1121
1122 attr = sym->attr;
1123
1124 /* If this symbol is confirming an implicit parameter type,
1125 then an initialization expression is not allowed. */
1126 if (attr.flavor == FL_PARAMETER
1127 && sym->value != NULL
1128 && *initp != NULL)
1129 {
1130 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1131 sym->name);
1132 return FAILURE;
1133 }
1134
6cbc841e 1135 if (attr.in_common
1136 && !attr.data
1137 && *initp != NULL)
1138 {
1139 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1140 sym->name);
1141 return FAILURE;
1142 }
1143
4ee9c684 1144 if (init == NULL)
1145 {
1146 /* An initializer is required for PARAMETER declarations. */
1147 if (attr.flavor == FL_PARAMETER)
1148 {
1149 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1150 return FAILURE;
1151 }
1152 }
1153 else
1154 {
1155 /* If a variable appears in a DATA block, it cannot have an
b97f1a18 1156 initializer. */
4ee9c684 1157 if (sym->attr.data)
1158 {
1a9745d2 1159 gfc_error ("Variable '%s' at %C with an initializer already "
1160 "appears in a DATA statement", sym->name);
4ee9c684 1161 return FAILURE;
1162 }
1163
cca3db55 1164 /* Check if the assignment can happen. This has to be put off
1165 until later for a derived type variable. */
4ee9c684 1166 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1167 && gfc_check_assign_symbol (sym, init) == FAILURE)
1168 return FAILURE;
1169
a270dc8e 1170 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1171 {
1172 /* Update symbol character length according initializer. */
1173 if (sym->ts.cl->length == NULL)
1174 {
f6d0e37a 1175 /* If there are multiple CHARACTER variables declared on the
1176 same line, we don't want them to share the same length. */
ea13b9b7 1177 sym->ts.cl = gfc_get_charlen ();
1178 sym->ts.cl->next = gfc_current_ns->cl_list;
1179 gfc_current_ns->cl_list = sym->ts.cl;
e9c873a4 1180
1181 if (sym->attr.flavor == FL_PARAMETER
1a9745d2 1182 && init->expr_type == EXPR_ARRAY)
e9c873a4 1183 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
a270dc8e 1184 }
1185 /* Update initializer character length according symbol. */
1186 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1187 {
1188 int len = mpz_get_si (sym->ts.cl->length->value.integer);
1189 gfc_constructor * p;
1190
1191 if (init->expr_type == EXPR_CONSTANT)
1bfea7e8 1192 gfc_set_constant_character_len (len, init, false);
a270dc8e 1193 else if (init->expr_type == EXPR_ARRAY)
1194 {
39908fd9 1195 /* Build a new charlen to prevent simplification from
1196 deleting the length before it is resolved. */
1197 init->ts.cl = gfc_get_charlen ();
1198 init->ts.cl->next = gfc_current_ns->cl_list;
1199 gfc_current_ns->cl_list = sym->ts.cl;
a270dc8e 1200 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
39908fd9 1201
a270dc8e 1202 for (p = init->value.constructor; p; p = p->next)
1bfea7e8 1203 gfc_set_constant_character_len (len, p->expr, false);
a270dc8e 1204 }
1205 }
1206 }
1207
c5d33754 1208 /* Need to check if the expression we initialized this
1209 to was one of the iso_c_binding named constants. If so,
1210 and we're a parameter (constant), let it be iso_c.
1211 For example:
1212 integer(c_int), parameter :: my_int = c_int
1213 integer(my_int) :: my_int_2
1214 If we mark my_int as iso_c (since we can see it's value
1215 is equal to one of the named constants), then my_int_2
1216 will be considered C interoperable. */
1217 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1218 {
1219 sym->ts.is_iso_c |= init->ts.is_iso_c;
1220 sym->ts.is_c_interop |= init->ts.is_c_interop;
1221 /* attr bits needed for module files. */
1222 sym->attr.is_iso_c |= init->ts.is_iso_c;
1223 sym->attr.is_c_interop |= init->ts.is_c_interop;
1224 if (init->ts.is_iso_c)
1225 sym->ts.f90_type = init->ts.f90_type;
1226 }
1227
4ee9c684 1228 /* Add initializer. Make sure we keep the ranks sane. */
1229 if (sym->attr.dimension && init->rank == 0)
7baa3fb4 1230 {
1231 mpz_t size;
1232 gfc_expr *array;
1233 gfc_constructor *c;
1234 int n;
1235 if (sym->attr.flavor == FL_PARAMETER
1236 && init->expr_type == EXPR_CONSTANT
1237 && spec_size (sym->as, &size) == SUCCESS
1238 && mpz_cmp_si (size, 0) > 0)
1239 {
1240 array = gfc_start_constructor (init->ts.type, init->ts.kind,
1241 &init->where);
1242
1243 array->value.constructor = c = NULL;
1244 for (n = 0; n < (int)mpz_get_si (size); n++)
1245 {
1246 if (array->value.constructor == NULL)
1247 {
1248 array->value.constructor = c = gfc_get_constructor ();
1249 c->expr = init;
1250 }
1251 else
1252 {
1253 c->next = gfc_get_constructor ();
1254 c = c->next;
1255 c->expr = gfc_copy_expr (init);
1256 }
1257 }
1258
1259 array->shape = gfc_get_shape (sym->as->rank);
1260 for (n = 0; n < sym->as->rank; n++)
1261 spec_dimen_size (sym->as, n, &array->shape[n]);
1262
1263 init = array;
1264 mpz_clear (size);
1265 }
1266 init->rank = sym->as->rank;
1267 }
4ee9c684 1268
1269 sym->value = init;
3cd3c667 1270 if (sym->attr.save == SAVE_NONE)
1271 sym->attr.save = SAVE_IMPLICIT;
4ee9c684 1272 *initp = NULL;
1273 }
1274
1275 return SUCCESS;
1276}
1277
1278
1279/* Function called by variable_decl() that adds a name to a structure
1280 being built. */
1281
1282static try
1a9745d2 1283build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1284 gfc_array_spec **as)
4ee9c684 1285{
1286 gfc_component *c;
1287
1288 /* If the current symbol is of the same derived type that we're
1289 constructing, it must have the pointer attribute. */
1290 if (current_ts.type == BT_DERIVED
1291 && current_ts.derived == gfc_current_block ()
1292 && current_attr.pointer == 0)
1293 {
1294 gfc_error ("Component at %C must have the POINTER attribute");
1295 return FAILURE;
1296 }
1297
1a9745d2 1298 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
4ee9c684 1299 {
1300 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1301 {
1302 gfc_error ("Array component of structure at %C must have explicit "
1303 "or deferred shape");
1304 return FAILURE;
1305 }
1306 }
1307
1308 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1309 return FAILURE;
1310
1311 c->ts = current_ts;
1312 c->ts.cl = cl;
1313 gfc_set_component_attr (c, &current_attr);
1314
1315 c->initializer = *init;
1316 *init = NULL;
1317
1318 c->as = *as;
1319 if (c->as != NULL)
1320 c->dimension = 1;
1321 *as = NULL;
1322
1323 /* Check array components. */
1324 if (!c->dimension)
2294b616 1325 {
1326 if (c->allocatable)
1327 {
1328 gfc_error ("Allocatable component at %C must be an array");
1329 return FAILURE;
1330 }
1331 else
1332 return SUCCESS;
1333 }
4ee9c684 1334
1335 if (c->pointer)
1336 {
1337 if (c->as->type != AS_DEFERRED)
1338 {
2294b616 1339 gfc_error ("Pointer array component of structure at %C must have a "
1340 "deferred shape");
1341 return FAILURE;
1342 }
1343 }
1344 else if (c->allocatable)
1345 {
1346 if (c->as->type != AS_DEFERRED)
1347 {
1348 gfc_error ("Allocatable component of structure at %C must have a "
1349 "deferred shape");
4ee9c684 1350 return FAILURE;
1351 }
1352 }
1353 else
1354 {
1355 if (c->as->type != AS_EXPLICIT)
1356 {
1a9745d2 1357 gfc_error ("Array component of structure at %C must have an "
1358 "explicit shape");
4ee9c684 1359 return FAILURE;
1360 }
1361 }
1362
1363 return SUCCESS;
1364}
1365
1366
1367/* Match a 'NULL()', and possibly take care of some side effects. */
1368
1369match
1a9745d2 1370gfc_match_null (gfc_expr **result)
4ee9c684 1371{
1372 gfc_symbol *sym;
1373 gfc_expr *e;
1374 match m;
1375
1376 m = gfc_match (" null ( )");
1377 if (m != MATCH_YES)
1378 return m;
1379
1380 /* The NULL symbol now has to be/become an intrinsic function. */
1381 if (gfc_get_symbol ("null", NULL, &sym))
1382 {
1383 gfc_error ("NULL() initialization at %C is ambiguous");
1384 return MATCH_ERROR;
1385 }
1386
1387 gfc_intrinsic_symbol (sym);
1388
1389 if (sym->attr.proc != PROC_INTRINSIC
950683ed 1390 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1391 sym->name, NULL) == FAILURE
1392 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
4ee9c684 1393 return MATCH_ERROR;
1394
1395 e = gfc_get_expr ();
cbb9e6aa 1396 e->where = gfc_current_locus;
4ee9c684 1397 e->expr_type = EXPR_NULL;
1398 e->ts.type = BT_UNKNOWN;
1399
1400 *result = e;
1401
1402 return MATCH_YES;
1403}
1404
1405
4ee9c684 1406/* Match a variable name with an optional initializer. When this
1407 subroutine is called, a variable is expected to be parsed next.
1408 Depending on what is happening at the moment, updates either the
1409 symbol table or the current interface. */
1410
1411static match
3923b69f 1412variable_decl (int elem)
4ee9c684 1413{
1414 char name[GFC_MAX_SYMBOL_LEN + 1];
1415 gfc_expr *initializer, *char_len;
1416 gfc_array_spec *as;
b549d2a5 1417 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
4ee9c684 1418 gfc_charlen *cl;
1419 locus var_locus;
1420 match m;
1421 try t;
b549d2a5 1422 gfc_symbol *sym;
3b6a4b41 1423 locus old_locus;
4ee9c684 1424
1425 initializer = NULL;
1426 as = NULL;
b549d2a5 1427 cp_as = NULL;
3b6a4b41 1428 old_locus = gfc_current_locus;
4ee9c684 1429
1430 /* When we get here, we've just matched a list of attributes and
1431 maybe a type and a double colon. The next thing we expect to see
1432 is the name of the symbol. */
1433 m = gfc_match_name (name);
1434 if (m != MATCH_YES)
1435 goto cleanup;
1436
cbb9e6aa 1437 var_locus = gfc_current_locus;
4ee9c684 1438
1439 /* Now we could see the optional array spec. or character length. */
1440 m = gfc_match_array_spec (&as);
b549d2a5 1441 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1442 cp_as = gfc_copy_array_spec (as);
1443 else if (m == MATCH_ERROR)
4ee9c684 1444 goto cleanup;
3b6a4b41 1445
4ee9c684 1446 if (m == MATCH_NO)
1447 as = gfc_copy_array_spec (current_as);
1448
1449 char_len = NULL;
1450 cl = NULL;
1451
1452 if (current_ts.type == BT_CHARACTER)
1453 {
1454 switch (match_char_length (&char_len))
1455 {
1456 case MATCH_YES:
1457 cl = gfc_get_charlen ();
1458 cl->next = gfc_current_ns->cl_list;
1459 gfc_current_ns->cl_list = cl;
1460
1461 cl->length = char_len;
1462 break;
1463
3923b69f 1464 /* Non-constant lengths need to be copied after the first
1465 element. */
4ee9c684 1466 case MATCH_NO:
3923b69f 1467 if (elem > 1 && current_ts.cl->length
1a9745d2 1468 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
3923b69f 1469 {
1470 cl = gfc_get_charlen ();
1471 cl->next = gfc_current_ns->cl_list;
1472 gfc_current_ns->cl_list = cl;
1473 cl->length = gfc_copy_expr (current_ts.cl->length);
1474 }
1475 else
1476 cl = current_ts.cl;
1477
4ee9c684 1478 break;
1479
1480 case MATCH_ERROR:
1481 goto cleanup;
1482 }
1483 }
1484
b549d2a5 1485 /* If this symbol has already shown up in a Cray Pointer declaration,
f6d0e37a 1486 then we want to set the type & bail out. */
b549d2a5 1487 if (gfc_option.flag_cray_pointer)
1488 {
1489 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1490 if (sym != NULL && sym->attr.cray_pointee)
1491 {
1492 sym->ts.type = current_ts.type;
1493 sym->ts.kind = current_ts.kind;
1494 sym->ts.cl = cl;
1495 sym->ts.derived = current_ts.derived;
c5d33754 1496 sym->ts.is_c_interop = current_ts.is_c_interop;
1497 sym->ts.is_iso_c = current_ts.is_iso_c;
b549d2a5 1498 m = MATCH_YES;
1499
1500 /* Check to see if we have an array specification. */
1501 if (cp_as != NULL)
1502 {
1503 if (sym->as != NULL)
1504 {
7698a624 1505 gfc_error ("Duplicate array spec for Cray pointee at %C");
b549d2a5 1506 gfc_free_array_spec (cp_as);
1507 m = MATCH_ERROR;
1508 goto cleanup;
1509 }
1510 else
1511 {
1512 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1513 gfc_internal_error ("Couldn't set pointee array spec.");
e14bee04 1514
b549d2a5 1515 /* Fix the array spec. */
e14bee04 1516 m = gfc_mod_pointee_as (sym->as);
b549d2a5 1517 if (m == MATCH_ERROR)
1518 goto cleanup;
1519 }
e14bee04 1520 }
b549d2a5 1521 goto cleanup;
1522 }
1523 else
1524 {
1525 gfc_free_array_spec (cp_as);
1526 }
1527 }
e14bee04 1528
1529
4ee9c684 1530 /* OK, we've successfully matched the declaration. Now put the
1531 symbol in the current namespace, because it might be used in the
fe06c0d5 1532 optional initialization expression for this symbol, e.g. this is
4ee9c684 1533 perfectly legal:
1534
1535 integer, parameter :: i = huge(i)
1536
1537 This is only true for parameters or variables of a basic type.
1538 For components of derived types, it is not true, so we don't
1539 create a symbol for those yet. If we fail to create the symbol,
1540 bail out. */
1541 if (gfc_current_state () != COMP_DERIVED
1542 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1543 {
b8a51d79 1544 m = MATCH_ERROR;
1545 goto cleanup;
1546 }
1547
60fbbf9e 1548 /* An interface body specifies all of the procedure's
1549 characteristics and these shall be consistent with those
1550 specified in the procedure definition, except that the interface
1551 may specify a procedure that is not pure if the procedure is
1552 defined to be pure(12.3.2). */
b8a51d79 1553 if (current_ts.type == BT_DERIVED
1a9745d2 1554 && gfc_current_ns->proc_name
1555 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
c723595c 1556 && current_ts.derived->ns != gfc_current_ns)
1557 {
1558 gfc_symtree *st;
1559 st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
1560 if (!(current_ts.derived->attr.imported
1561 && st != NULL
1562 && st->n.sym == current_ts.derived)
1563 && !gfc_current_ns->has_import_set)
1564 {
1565 gfc_error ("the type of '%s' at %C has not been declared within the "
1566 "interface", name);
1567 m = MATCH_ERROR;
1568 goto cleanup;
1569 }
4ee9c684 1570 }
1571
1572 /* In functions that have a RESULT variable defined, the function
1573 name always refers to function calls. Therefore, the name is
1574 not allowed to appear in specification statements. */
1575 if (gfc_current_state () == COMP_FUNCTION
1576 && gfc_current_block () != NULL
1577 && gfc_current_block ()->result != NULL
1578 && gfc_current_block ()->result != gfc_current_block ()
1579 && strcmp (gfc_current_block ()->name, name) == 0)
1580 {
1581 gfc_error ("Function name '%s' not allowed at %C", name);
1582 m = MATCH_ERROR;
1583 goto cleanup;
1584 }
1585
b4f45d02 1586 /* We allow old-style initializations of the form
1587 integer i /2/, j(4) /3*3, 1/
1588 (if no colon has been seen). These are different from data
1589 statements in that initializers are only allowed to apply to the
1590 variable immediately preceding, i.e.
1591 integer i, j /1, 2/
1592 is not allowed. Therefore we have to do some work manually, that
cca3db55 1593 could otherwise be left to the matchers for DATA statements. */
b4f45d02 1594
1595 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1596 {
1597 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1598 "initialization at %C") == FAILURE)
1599 return MATCH_ERROR;
e14bee04 1600
b4f45d02 1601 return match_old_style_init (name);
1602 }
1603
4ee9c684 1604 /* The double colon must be present in order to have initializers.
1605 Otherwise the statement is ambiguous with an assignment statement. */
1606 if (colon_seen)
1607 {
1608 if (gfc_match (" =>") == MATCH_YES)
1609 {
4ee9c684 1610 if (!current_attr.pointer)
1611 {
1612 gfc_error ("Initialization at %C isn't for a pointer variable");
1613 m = MATCH_ERROR;
1614 goto cleanup;
1615 }
1616
1617 m = gfc_match_null (&initializer);
1618 if (m == MATCH_NO)
1619 {
e4789c62 1620 gfc_error ("Pointer initialization requires a NULL() at %C");
4ee9c684 1621 m = MATCH_ERROR;
1622 }
1623
1624 if (gfc_pure (NULL))
1625 {
1a9745d2 1626 gfc_error ("Initialization of pointer at %C is not allowed in "
1627 "a PURE procedure");
4ee9c684 1628 m = MATCH_ERROR;
1629 }
1630
1631 if (m != MATCH_YES)
1632 goto cleanup;
1633
4ee9c684 1634 }
1635 else if (gfc_match_char ('=') == MATCH_YES)
1636 {
1637 if (current_attr.pointer)
1638 {
1a9745d2 1639 gfc_error ("Pointer initialization at %C requires '=>', "
1640 "not '='");
4ee9c684 1641 m = MATCH_ERROR;
1642 goto cleanup;
1643 }
1644
1645 m = gfc_match_init_expr (&initializer);
1646 if (m == MATCH_NO)
1647 {
1648 gfc_error ("Expected an initialization expression at %C");
1649 m = MATCH_ERROR;
1650 }
1651
1652 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1653 {
1a9745d2 1654 gfc_error ("Initialization of variable at %C is not allowed in "
1655 "a PURE procedure");
4ee9c684 1656 m = MATCH_ERROR;
1657 }
1658
1659 if (m != MATCH_YES)
1660 goto cleanup;
1661 }
8ffad0f9 1662 }
1663
2294b616 1664 if (initializer != NULL && current_attr.allocatable
1665 && gfc_current_state () == COMP_DERIVED)
1666 {
1a9745d2 1667 gfc_error ("Initialization of allocatable component at %C is not "
1668 "allowed");
2294b616 1669 m = MATCH_ERROR;
1670 goto cleanup;
1671 }
1672
d9b3f26b 1673 /* Add the initializer. Note that it is fine if initializer is
4ee9c684 1674 NULL here, because we sometimes also need to check if a
1675 declaration *must* have an initialization expression. */
1676 if (gfc_current_state () != COMP_DERIVED)
1677 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1678 else
d9b3f26b 1679 {
2294b616 1680 if (current_ts.type == BT_DERIVED
1a9745d2 1681 && !current_attr.pointer && !initializer)
d9b3f26b 1682 initializer = gfc_default_initializer (&current_ts);
1683 t = build_struct (name, cl, &initializer, &as);
1684 }
4ee9c684 1685
1686 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1687
1688cleanup:
1689 /* Free stuff up and return. */
1690 gfc_free_expr (initializer);
1691 gfc_free_array_spec (as);
1692
1693 return m;
1694}
1695
1696
d10f89ee 1697/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1698 This assumes that the byte size is equal to the kind number for
1699 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
4ee9c684 1700
1701match
1a9745d2 1702gfc_match_old_kind_spec (gfc_typespec *ts)
4ee9c684 1703{
1704 match m;
3bd3b616 1705 int original_kind;
4ee9c684 1706
1707 if (gfc_match_char ('*') != MATCH_YES)
1708 return MATCH_NO;
1709
3bd3b616 1710 m = gfc_match_small_literal_int (&ts->kind, NULL);
4ee9c684 1711 if (m != MATCH_YES)
1712 return MATCH_ERROR;
1713
b118a35b 1714 original_kind = ts->kind;
1715
4ee9c684 1716 /* Massage the kind numbers for complex types. */
b118a35b 1717 if (ts->type == BT_COMPLEX)
1718 {
1719 if (ts->kind % 2)
1a9745d2 1720 {
1721 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1722 gfc_basic_typename (ts->type), original_kind);
1723 return MATCH_ERROR;
1724 }
b118a35b 1725 ts->kind /= 2;
1726 }
4ee9c684 1727
f2d4ef3b 1728 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
4ee9c684 1729 {
b118a35b 1730 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1a9745d2 1731 gfc_basic_typename (ts->type), original_kind);
4ee9c684 1732 return MATCH_ERROR;
1733 }
1734
be7f01a1 1735 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1736 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1737 return MATCH_ERROR;
1738
4ee9c684 1739 return MATCH_YES;
1740}
1741
1742
1743/* Match a kind specification. Since kinds are generally optional, we
1744 usually return MATCH_NO if something goes wrong. If a "kind="
1745 string is found, then we know we have an error. */
1746
1747match
1a9745d2 1748gfc_match_kind_spec (gfc_typespec *ts)
4ee9c684 1749{
1750 locus where;
1751 gfc_expr *e;
1752 match m, n;
1753 const char *msg;
1754
1755 m = MATCH_NO;
1756 e = NULL;
1757
cbb9e6aa 1758 where = gfc_current_locus;
4ee9c684 1759
1760 if (gfc_match_char ('(') == MATCH_NO)
1761 return MATCH_NO;
1762
1763 /* Also gobbles optional text. */
1764 if (gfc_match (" kind = ") == MATCH_YES)
1765 m = MATCH_ERROR;
1766
1767 n = gfc_match_init_expr (&e);
1768 if (n == MATCH_NO)
1769 gfc_error ("Expected initialization expression at %C");
1770 if (n != MATCH_YES)
1771 return MATCH_ERROR;
1772
1773 if (e->rank != 0)
1774 {
1775 gfc_error ("Expected scalar initialization expression at %C");
1776 m = MATCH_ERROR;
1777 goto no_match;
1778 }
1779
1780 msg = gfc_extract_int (e, &ts->kind);
1781 if (msg != NULL)
1782 {
1783 gfc_error (msg);
1784 m = MATCH_ERROR;
1785 goto no_match;
1786 }
1787
c5d33754 1788 /* Before throwing away the expression, let's see if we had a
1789 C interoperable kind (and store the fact). */
1790 if (e->ts.is_c_interop == 1)
1791 {
1792 /* Mark this as c interoperable if being declared with one
1793 of the named constants from iso_c_binding. */
1794 ts->is_c_interop = e->ts.is_iso_c;
1795 ts->f90_type = e->ts.f90_type;
1796 }
1797
4ee9c684 1798 gfc_free_expr (e);
1799 e = NULL;
1800
c5d33754 1801 /* Ignore errors to this point, if we've gotten here. This means
1802 we ignore the m=MATCH_ERROR from above. */
f2d4ef3b 1803 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
4ee9c684 1804 {
1805 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1806 gfc_basic_typename (ts->type));
4ee9c684 1807 m = MATCH_ERROR;
4ee9c684 1808 }
c5d33754 1809 else if (gfc_match_char (')') != MATCH_YES)
4ee9c684 1810 {
d67fc9ae 1811 gfc_error ("Missing right parenthesis at %C");
c5d33754 1812 m = MATCH_ERROR;
4ee9c684 1813 }
c5d33754 1814 else
1815 /* All tests passed. */
1816 m = MATCH_YES;
4ee9c684 1817
c5d33754 1818 if(m == MATCH_ERROR)
1819 gfc_current_locus = where;
1820
1821 /* Return what we know from the test(s). */
1822 return m;
4ee9c684 1823
1824no_match:
1825 gfc_free_expr (e);
cbb9e6aa 1826 gfc_current_locus = where;
4ee9c684 1827 return m;
1828}
1829
1830
1831/* Match the various kind/length specifications in a CHARACTER
1832 declaration. We don't return MATCH_NO. */
1833
1834static match
1a9745d2 1835match_char_spec (gfc_typespec *ts)
4ee9c684 1836{
2fe2caa6 1837 int kind, seen_length;
4ee9c684 1838 gfc_charlen *cl;
1839 gfc_expr *len;
1840 match m;
c5d33754 1841 gfc_expr *kind_expr = NULL;
b8a891cb 1842 kind = gfc_default_character_kind;
4ee9c684 1843 len = NULL;
1844 seen_length = 0;
1845
1846 /* Try the old-style specification first. */
1847 old_char_selector = 0;
1848
1849 m = match_char_length (&len);
1850 if (m != MATCH_NO)
1851 {
1852 if (m == MATCH_YES)
1853 old_char_selector = 1;
1854 seen_length = 1;
1855 goto done;
1856 }
1857
1858 m = gfc_match_char ('(');
1859 if (m != MATCH_YES)
1860 {
c5d33754 1861 m = MATCH_YES; /* Character without length is a single char. */
4ee9c684 1862 goto done;
1863 }
1864
c5d33754 1865 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
4ee9c684 1866 if (gfc_match (" kind =") == MATCH_YES)
1867 {
c5d33754 1868 m = gfc_match_small_int_expr(&kind, &kind_expr);
1869
4ee9c684 1870 if (m == MATCH_ERROR)
1871 goto done;
1872 if (m == MATCH_NO)
1873 goto syntax;
1874
1875 if (gfc_match (" , len =") == MATCH_NO)
1876 goto rparen;
1877
1878 m = char_len_param_value (&len);
1879 if (m == MATCH_NO)
1880 goto syntax;
1881 if (m == MATCH_ERROR)
1882 goto done;
1883 seen_length = 1;
1884
1885 goto rparen;
1886 }
1887
f6d0e37a 1888 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
4ee9c684 1889 if (gfc_match (" len =") == MATCH_YES)
1890 {
1891 m = char_len_param_value (&len);
1892 if (m == MATCH_NO)
1893 goto syntax;
1894 if (m == MATCH_ERROR)
1895 goto done;
1896 seen_length = 1;
1897
1898 if (gfc_match_char (')') == MATCH_YES)
1899 goto done;
1900
1901 if (gfc_match (" , kind =") != MATCH_YES)
1902 goto syntax;
1903
c5d33754 1904 gfc_match_small_int_expr(&kind, &kind_expr);
4ee9c684 1905
f2d4ef3b 1906 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
4ee9c684 1907 {
1908 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1909 return MATCH_YES;
1910 }
1911
1912 goto rparen;
1913 }
1914
f6d0e37a 1915 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
4ee9c684 1916 m = char_len_param_value (&len);
1917 if (m == MATCH_NO)
1918 goto syntax;
1919 if (m == MATCH_ERROR)
1920 goto done;
1921 seen_length = 1;
1922
1923 m = gfc_match_char (')');
1924 if (m == MATCH_YES)
1925 goto done;
1926
1927 if (gfc_match_char (',') != MATCH_YES)
1928 goto syntax;
1929
c5d33754 1930 gfc_match (" kind ="); /* Gobble optional text. */
4ee9c684 1931
c5d33754 1932 m = gfc_match_small_int_expr(&kind, &kind_expr);
4ee9c684 1933 if (m == MATCH_ERROR)
1934 goto done;
1935 if (m == MATCH_NO)
1936 goto syntax;
1937
1938rparen:
1939 /* Require a right-paren at this point. */
1940 m = gfc_match_char (')');
1941 if (m == MATCH_YES)
1942 goto done;
1943
1944syntax:
1945 gfc_error ("Syntax error in CHARACTER declaration at %C");
1946 m = MATCH_ERROR;
a3cbe8cc 1947 gfc_free_expr (len);
1948 return m;
4ee9c684 1949
1950done:
a3cbe8cc 1951 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
4ee9c684 1952 {
1953 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1954 m = MATCH_ERROR;
1955 }
1956
a3cbe8cc 1957 if (seen_length == 1 && len != NULL
1958 && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN)
1959 {
1960 gfc_error ("Expression at %C must be of INTEGER type");
1961 m = MATCH_ERROR;
1962 }
1963
4ee9c684 1964 if (m != MATCH_YES)
1965 {
1966 gfc_free_expr (len);
c5d33754 1967 gfc_free_expr (kind_expr);
4ee9c684 1968 return m;
1969 }
1970
1971 /* Do some final massaging of the length values. */
1972 cl = gfc_get_charlen ();
1973 cl->next = gfc_current_ns->cl_list;
1974 gfc_current_ns->cl_list = cl;
1975
1976 if (seen_length == 0)
1977 cl->length = gfc_int_expr (1);
1978 else
2fe2caa6 1979 cl->length = len;
4ee9c684 1980
1981 ts->cl = cl;
1982 ts->kind = kind;
1983
c5d33754 1984 /* We have to know if it was a c interoperable kind so we can
1985 do accurate type checking of bind(c) procs, etc. */
1986 if (kind_expr != NULL)
1987 {
1988 /* Mark this as c interoperable if being declared with one
1989 of the named constants from iso_c_binding. */
1990 ts->is_c_interop = kind_expr->ts.is_iso_c;
1991 gfc_free_expr (kind_expr);
1992 }
1993 else if (len != NULL)
1994 {
1995 /* Here, we might have parsed something such as:
1996 character(c_char)
1997 In this case, the parsing code above grabs the c_char when
1998 looking for the length (line 1690, roughly). it's the last
1999 testcase for parsing the kind params of a character variable.
2000 However, it's not actually the length. this seems like it
2001 could be an error.
2002 To see if the user used a C interop kind, test the expr
2003 of the so called length, and see if it's C interoperable. */
2004 ts->is_c_interop = len->ts.is_iso_c;
2005 }
2006
4ee9c684 2007 return MATCH_YES;
2008}
2009
2010
2011/* Matches a type specification. If successful, sets the ts structure
2012 to the matched specification. This is necessary for FUNCTION and
2013 IMPLICIT statements.
2014
e14bee04 2015 If implicit_flag is nonzero, then we don't check for the optional
39351103 2016 kind specification. Not doing so is needed for matching an IMPLICIT
4ee9c684 2017 statement correctly. */
2018
39351103 2019static match
1a9745d2 2020match_type_spec (gfc_typespec *ts, int implicit_flag)
4ee9c684 2021{
2022 char name[GFC_MAX_SYMBOL_LEN + 1];
2023 gfc_symbol *sym;
2024 match m;
18f3698a 2025 int c;
4ee9c684 2026
2027 gfc_clear_ts (ts);
2028
c5d33754 2029 /* Clear the current binding label, in case one is given. */
2030 curr_binding_label[0] = '\0';
2031
25b29122 2032 if (gfc_match (" byte") == MATCH_YES)
2033 {
e14bee04 2034 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
25b29122 2035 == FAILURE)
2036 return MATCH_ERROR;
2037
2038 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2039 {
2040 gfc_error ("BYTE type used at %C "
2041 "is not available on the target machine");
2042 return MATCH_ERROR;
2043 }
e14bee04 2044
25b29122 2045 ts->type = BT_INTEGER;
2046 ts->kind = 1;
2047 return MATCH_YES;
2048 }
2049
4ee9c684 2050 if (gfc_match (" integer") == MATCH_YES)
2051 {
2052 ts->type = BT_INTEGER;
b8a891cb 2053 ts->kind = gfc_default_integer_kind;
4ee9c684 2054 goto get_kind;
2055 }
2056
2057 if (gfc_match (" character") == MATCH_YES)
2058 {
2059 ts->type = BT_CHARACTER;
39351103 2060 if (implicit_flag == 0)
2061 return match_char_spec (ts);
2062 else
2063 return MATCH_YES;
4ee9c684 2064 }
2065
2066 if (gfc_match (" real") == MATCH_YES)
2067 {
2068 ts->type = BT_REAL;
b8a891cb 2069 ts->kind = gfc_default_real_kind;
4ee9c684 2070 goto get_kind;
2071 }
2072
2073 if (gfc_match (" double precision") == MATCH_YES)
2074 {
2075 ts->type = BT_REAL;
b8a891cb 2076 ts->kind = gfc_default_double_kind;
4ee9c684 2077 return MATCH_YES;
2078 }
2079
2080 if (gfc_match (" complex") == MATCH_YES)
2081 {
2082 ts->type = BT_COMPLEX;
b8a891cb 2083 ts->kind = gfc_default_complex_kind;
4ee9c684 2084 goto get_kind;
2085 }
2086
2087 if (gfc_match (" double complex") == MATCH_YES)
2088 {
be7f01a1 2089 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2090 "conform to the Fortran 95 standard") == FAILURE)
2091 return MATCH_ERROR;
2092
4ee9c684 2093 ts->type = BT_COMPLEX;
b8a891cb 2094 ts->kind = gfc_default_double_kind;
4ee9c684 2095 return MATCH_YES;
2096 }
2097
2098 if (gfc_match (" logical") == MATCH_YES)
2099 {
2100 ts->type = BT_LOGICAL;
b8a891cb 2101 ts->kind = gfc_default_logical_kind;
4ee9c684 2102 goto get_kind;
2103 }
2104
2105 m = gfc_match (" type ( %n )", name);
2106 if (m != MATCH_YES)
2107 return m;
2108
2109 /* Search for the name but allow the components to be defined later. */
2110 if (gfc_get_ha_symbol (name, &sym))
2111 {
2112 gfc_error ("Type name '%s' at %C is ambiguous", name);
2113 return MATCH_ERROR;
2114 }
2115
2116 if (sym->attr.flavor != FL_DERIVED
950683ed 2117 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4ee9c684 2118 return MATCH_ERROR;
2119
2120 ts->type = BT_DERIVED;
2121 ts->kind = 0;
2122 ts->derived = sym;
2123
2124 return MATCH_YES;
2125
2126get_kind:
2127 /* For all types except double, derived and character, look for an
2128 optional kind specifier. MATCH_NO is actually OK at this point. */
39351103 2129 if (implicit_flag == 1)
4ee9c684 2130 return MATCH_YES;
2131
18f3698a 2132 if (gfc_current_form == FORM_FREE)
2133 {
2134 c = gfc_peek_char();
2135 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1a9745d2 2136 && c != ':' && c != ',')
18f3698a 2137 return MATCH_NO;
2138 }
2139
4ee9c684 2140 m = gfc_match_kind_spec (ts);
2141 if (m == MATCH_NO && ts->type != BT_CHARACTER)
2142 m = gfc_match_old_kind_spec (ts);
2143
2144 if (m == MATCH_NO)
2145 m = MATCH_YES; /* No kind specifier found. */
2146
2147 return m;
2148}
2149
2150
39351103 2151/* Match an IMPLICIT NONE statement. Actually, this statement is
2152 already matched in parse.c, or we would not end up here in the
2153 first place. So the only thing we need to check, is if there is
2154 trailing garbage. If not, the match is successful. */
2155
2156match
2157gfc_match_implicit_none (void)
2158{
39351103 2159 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2160}
2161
2162
2163/* Match the letter range(s) of an IMPLICIT statement. */
2164
2165static match
b70528c7 2166match_implicit_range (void)
39351103 2167{
2168 int c, c1, c2, inner;
2169 locus cur_loc;
2170
2171 cur_loc = gfc_current_locus;
2172
2173 gfc_gobble_whitespace ();
2174 c = gfc_next_char ();
2175 if (c != '(')
2176 {
2177 gfc_error ("Missing character range in IMPLICIT at %C");
2178 goto bad;
2179 }
2180
2181 inner = 1;
2182 while (inner)
2183 {
2184 gfc_gobble_whitespace ();
2185 c1 = gfc_next_char ();
2186 if (!ISALPHA (c1))
2187 goto bad;
2188
2189 gfc_gobble_whitespace ();
2190 c = gfc_next_char ();
2191
2192 switch (c)
2193 {
2194 case ')':
f6d0e37a 2195 inner = 0; /* Fall through. */
39351103 2196
2197 case ',':
2198 c2 = c1;
2199 break;
2200
2201 case '-':
2202 gfc_gobble_whitespace ();
2203 c2 = gfc_next_char ();
2204 if (!ISALPHA (c2))
2205 goto bad;
2206
2207 gfc_gobble_whitespace ();
2208 c = gfc_next_char ();
2209
2210 if ((c != ',') && (c != ')'))
2211 goto bad;
2212 if (c == ')')
2213 inner = 0;
2214
2215 break;
2216
2217 default:
2218 goto bad;
2219 }
2220
2221 if (c1 > c2)
2222 {
2223 gfc_error ("Letters must be in alphabetic order in "
2224 "IMPLICIT statement at %C");
2225 goto bad;
2226 }
2227
2228 /* See if we can add the newly matched range to the pending
1a9745d2 2229 implicits from this IMPLICIT statement. We do not check for
2230 conflicts with whatever earlier IMPLICIT statements may have
2231 set. This is done when we've successfully finished matching
2232 the current one. */
b70528c7 2233 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
39351103 2234 goto bad;
2235 }
2236
2237 return MATCH_YES;
2238
2239bad:
2240 gfc_syntax_error (ST_IMPLICIT);
2241
2242 gfc_current_locus = cur_loc;
2243 return MATCH_ERROR;
2244}
2245
2246
2247/* Match an IMPLICIT statement, storing the types for
2248 gfc_set_implicit() if the statement is accepted by the parser.
2249 There is a strange looking, but legal syntactic construction
2250 possible. It looks like:
2251
2252 IMPLICIT INTEGER (a-b) (c-d)
2253
2254 This is legal if "a-b" is a constant expression that happens to
2255 equal one of the legal kinds for integers. The real problem
2256 happens with an implicit specification that looks like:
2257
2258 IMPLICIT INTEGER (a-b)
2259
2260 In this case, a typespec matcher that is "greedy" (as most of the
2261 matchers are) gobbles the character range as a kindspec, leaving
2262 nothing left. We therefore have to go a bit more slowly in the
2263 matching process by inhibiting the kindspec checking during
2264 typespec matching and checking for a kind later. */
2265
2266match
2267gfc_match_implicit (void)
2268{
2269 gfc_typespec ts;
2270 locus cur_loc;
2271 int c;
2272 match m;
2273
2274 /* We don't allow empty implicit statements. */
2275 if (gfc_match_eos () == MATCH_YES)
2276 {
2277 gfc_error ("Empty IMPLICIT statement at %C");
2278 return MATCH_ERROR;
2279 }
2280
39351103 2281 do
2282 {
b70528c7 2283 /* First cleanup. */
2284 gfc_clear_new_implicit ();
2285
39351103 2286 /* A basic type is mandatory here. */
2287 m = match_type_spec (&ts, 1);
2288 if (m == MATCH_ERROR)
2289 goto error;
2290 if (m == MATCH_NO)
2291 goto syntax;
2292
2293 cur_loc = gfc_current_locus;
b70528c7 2294 m = match_implicit_range ();
39351103 2295
2296 if (m == MATCH_YES)
2297 {
b70528c7 2298 /* We may have <TYPE> (<RANGE>). */
39351103 2299 gfc_gobble_whitespace ();
2300 c = gfc_next_char ();
2301 if ((c == '\n') || (c == ','))
b70528c7 2302 {
2303 /* Check for CHARACTER with no length parameter. */
2304 if (ts.type == BT_CHARACTER && !ts.cl)
2305 {
b8a891cb 2306 ts.kind = gfc_default_character_kind;
b70528c7 2307 ts.cl = gfc_get_charlen ();
2308 ts.cl->next = gfc_current_ns->cl_list;
2309 gfc_current_ns->cl_list = ts.cl;
2310 ts.cl->length = gfc_int_expr (1);
2311 }
2312
2313 /* Record the Successful match. */
2314 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2315 return MATCH_ERROR;
2316 continue;
2317 }
39351103 2318
2319 gfc_current_locus = cur_loc;
2320 }
2321
b70528c7 2322 /* Discard the (incorrectly) matched range. */
2323 gfc_clear_new_implicit ();
2324
2325 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2326 if (ts.type == BT_CHARACTER)
2327 m = match_char_spec (&ts);
2328 else
39351103 2329 {
b70528c7 2330 m = gfc_match_kind_spec (&ts);
39351103 2331 if (m == MATCH_NO)
b70528c7 2332 {
2333 m = gfc_match_old_kind_spec (&ts);
2334 if (m == MATCH_ERROR)
2335 goto error;
2336 if (m == MATCH_NO)
2337 goto syntax;
2338 }
39351103 2339 }
b70528c7 2340 if (m == MATCH_ERROR)
2341 goto error;
39351103 2342
b70528c7 2343 m = match_implicit_range ();
39351103 2344 if (m == MATCH_ERROR)
2345 goto error;
2346 if (m == MATCH_NO)
2347 goto syntax;
2348
2349 gfc_gobble_whitespace ();
2350 c = gfc_next_char ();
2351 if ((c != '\n') && (c != ','))
2352 goto syntax;
2353
b70528c7 2354 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2355 return MATCH_ERROR;
39351103 2356 }
2357 while (c == ',');
2358
b70528c7 2359 return MATCH_YES;
39351103 2360
2361syntax:
2362 gfc_syntax_error (ST_IMPLICIT);
2363
2364error:
2365 return MATCH_ERROR;
2366}
2367
f6d0e37a 2368
d67fc9ae 2369match
2370gfc_match_import (void)
2371{
2372 char name[GFC_MAX_SYMBOL_LEN + 1];
2373 match m;
2374 gfc_symbol *sym;
2375 gfc_symtree *st;
2376
f6d0e37a 2377 if (gfc_current_ns->proc_name == NULL
2378 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
d67fc9ae 2379 {
2380 gfc_error ("IMPORT statement at %C only permitted in "
2381 "an INTERFACE body");
2382 return MATCH_ERROR;
2383 }
2384
1a9745d2 2385 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
d67fc9ae 2386 == FAILURE)
2387 return MATCH_ERROR;
2388
2389 if (gfc_match_eos () == MATCH_YES)
2390 {
2391 /* All host variables should be imported. */
2392 gfc_current_ns->has_import_set = 1;
2393 return MATCH_YES;
2394 }
2395
2396 if (gfc_match (" ::") == MATCH_YES)
2397 {
2398 if (gfc_match_eos () == MATCH_YES)
1a9745d2 2399 {
2400 gfc_error ("Expecting list of named entities at %C");
2401 return MATCH_ERROR;
2402 }
d67fc9ae 2403 }
2404
2405 for(;;)
2406 {
2407 m = gfc_match (" %n", name);
2408 switch (m)
2409 {
2410 case MATCH_YES:
096d4ad9 2411 if (gfc_current_ns->parent != NULL
f6d0e37a 2412 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
096d4ad9 2413 {
2414 gfc_error ("Type name '%s' at %C is ambiguous", name);
2415 return MATCH_ERROR;
2416 }
2417 else if (gfc_current_ns->proc_name->ns->parent != NULL
f6d0e37a 2418 && gfc_find_symbol (name,
2419 gfc_current_ns->proc_name->ns->parent,
2420 1, &sym))
1a9745d2 2421 {
2422 gfc_error ("Type name '%s' at %C is ambiguous", name);
2423 return MATCH_ERROR;
2424 }
2425
2426 if (sym == NULL)
2427 {
2428 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2429 "at %C - does not exist.", name);
2430 return MATCH_ERROR;
2431 }
2432
e14bee04 2433 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
1a9745d2 2434 {
2435 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2436 "at %C.", name);
2437 goto next_item;
2438 }
2439
2440 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2441 st->n.sym = sym;
2442 sym->refs++;
c723595c 2443 sym->attr.imported = 1;
d67fc9ae 2444
2445 goto next_item;
2446
2447 case MATCH_NO:
2448 break;
2449
2450 case MATCH_ERROR:
2451 return MATCH_ERROR;
2452 }
2453
2454 next_item:
2455 if (gfc_match_eos () == MATCH_YES)
2456 break;
2457 if (gfc_match_char (',') != MATCH_YES)
2458 goto syntax;
2459 }
2460
2461 return MATCH_YES;
2462
2463syntax:
2464 gfc_error ("Syntax error in IMPORT statement at %C");
2465 return MATCH_ERROR;
2466}
39351103 2467
f6d0e37a 2468
4ee9c684 2469/* Matches an attribute specification including array specs. If
2470 successful, leaves the variables current_attr and current_as
2471 holding the specification. Also sets the colon_seen variable for
2472 later use by matchers associated with initializations.
2473
2474 This subroutine is a little tricky in the sense that we don't know
2475 if we really have an attr-spec until we hit the double colon.
2476 Until that time, we can only return MATCH_NO. This forces us to
2477 check for duplicate specification at this level. */
2478
2479static match
2480match_attr_spec (void)
2481{
4ee9c684 2482 /* Modifiers that can exist in a type statement. */
2483 typedef enum
2484 { GFC_DECL_BEGIN = 0,
2485 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2486 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
3ea52af3 2487 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2488 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
c5d33754 2489 DECL_IS_BIND_C, DECL_COLON, DECL_NONE,
4ee9c684 2490 GFC_DECL_END /* Sentinel */
2491 }
2492 decl_types;
2493
2494/* GFC_DECL_END is the sentinel, index starts at 0. */
2495#define NUM_DECL GFC_DECL_END
2496
2497 static mstring decls[] = {
2498 minit (", allocatable", DECL_ALLOCATABLE),
2499 minit (", dimension", DECL_DIMENSION),
2500 minit (", external", DECL_EXTERNAL),
2501 minit (", intent ( in )", DECL_IN),
2502 minit (", intent ( out )", DECL_OUT),
2503 minit (", intent ( in out )", DECL_INOUT),
2504 minit (", intrinsic", DECL_INTRINSIC),
2505 minit (", optional", DECL_OPTIONAL),
2506 minit (", parameter", DECL_PARAMETER),
2507 minit (", pointer", DECL_POINTER),
3ea52af3 2508 minit (", protected", DECL_PROTECTED),
4ee9c684 2509 minit (", private", DECL_PRIVATE),
2510 minit (", public", DECL_PUBLIC),
2511 minit (", save", DECL_SAVE),
2512 minit (", target", DECL_TARGET),
8f6339b6 2513 minit (", value", DECL_VALUE),
ef814c81 2514 minit (", volatile", DECL_VOLATILE),
4ee9c684 2515 minit ("::", DECL_COLON),
2516 minit (NULL, DECL_NONE)
2517 };
2518
2519 locus start, seen_at[NUM_DECL];
2520 int seen[NUM_DECL];
2521 decl_types d;
2522 const char *attr;
2523 match m;
2524 try t;
c5d33754 2525 char peek_char;
4ee9c684 2526
2527 gfc_clear_attr (&current_attr);
cbb9e6aa 2528 start = gfc_current_locus;
4ee9c684 2529
2530 current_as = NULL;
2531 colon_seen = 0;
2532
2533 /* See if we get all of the keywords up to the final double colon. */
2534 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2535 seen[d] = 0;
2536
2537 for (;;)
2538 {
2539 d = (decl_types) gfc_match_strings (decls);
c5d33754 2540
2541 if (d == DECL_NONE)
2542 {
2543 /* See if we can find the bind(c) since all else failed.
2544 We need to skip over any whitespace and stop on the ','. */
2545 gfc_gobble_whitespace ();
2546 peek_char = gfc_peek_char ();
2547 if (peek_char == ',')
2548 {
2549 /* Chomp the comma. */
2550 peek_char = gfc_next_char ();
2551 /* Try and match the bind(c). */
f3f9b222 2552 if (gfc_match_bind_c (NULL) == MATCH_YES)
c5d33754 2553 d = DECL_IS_BIND_C;
c5d33754 2554 }
2555 }
f3f9b222 2556
4ee9c684 2557 if (d == DECL_NONE || d == DECL_COLON)
2558 break;
e14bee04 2559
4ee9c684 2560 seen[d]++;
cbb9e6aa 2561 seen_at[d] = gfc_current_locus;
4ee9c684 2562
2563 if (d == DECL_DIMENSION)
2564 {
2565 m = gfc_match_array_spec (&current_as);
2566
2567 if (m == MATCH_NO)
2568 {
2569 gfc_error ("Missing dimension specification at %C");
2570 m = MATCH_ERROR;
2571 }
2572
2573 if (m == MATCH_ERROR)
2574 goto cleanup;
2575 }
2576 }
2577
2578 /* No double colon, so assume that we've been looking at something
2579 else the whole time. */
2580 if (d == DECL_NONE)
2581 {
2582 m = MATCH_NO;
2583 goto cleanup;
2584 }
2585
2586 /* Since we've seen a double colon, we have to be looking at an
2587 attr-spec. This means that we can now issue errors. */
2588 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2589 if (seen[d] > 1)
2590 {
2591 switch (d)
2592 {
2593 case DECL_ALLOCATABLE:
2594 attr = "ALLOCATABLE";
2595 break;
2596 case DECL_DIMENSION:
2597 attr = "DIMENSION";
2598 break;
2599 case DECL_EXTERNAL:
2600 attr = "EXTERNAL";
2601 break;
2602 case DECL_IN:
2603 attr = "INTENT (IN)";
2604 break;
2605 case DECL_OUT:
2606 attr = "INTENT (OUT)";
2607 break;
2608 case DECL_INOUT:
2609 attr = "INTENT (IN OUT)";
2610 break;
2611 case DECL_INTRINSIC:
2612 attr = "INTRINSIC";
2613 break;
2614 case DECL_OPTIONAL:
2615 attr = "OPTIONAL";
2616 break;
2617 case DECL_PARAMETER:
2618 attr = "PARAMETER";
2619 break;
2620 case DECL_POINTER:
2621 attr = "POINTER";
2622 break;
3ea52af3 2623 case DECL_PROTECTED:
2624 attr = "PROTECTED";
2625 break;
4ee9c684 2626 case DECL_PRIVATE:
2627 attr = "PRIVATE";
2628 break;
2629 case DECL_PUBLIC:
2630 attr = "PUBLIC";
2631 break;
2632 case DECL_SAVE:
2633 attr = "SAVE";
2634 break;
2635 case DECL_TARGET:
2636 attr = "TARGET";
2637 break;
c5d33754 2638 case DECL_IS_BIND_C:
2639 attr = "IS_BIND_C";
2640 break;
2641 case DECL_VALUE:
2642 attr = "VALUE";
2643 break;
ef814c81 2644 case DECL_VOLATILE:
2645 attr = "VOLATILE";
2646 break;
4ee9c684 2647 default:
f6d0e37a 2648 attr = NULL; /* This shouldn't happen. */
4ee9c684 2649 }
2650
2651 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2652 m = MATCH_ERROR;
2653 goto cleanup;
2654 }
2655
2656 /* Now that we've dealt with duplicate attributes, add the attributes
2657 to the current attribute. */
2658 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2659 {
2660 if (seen[d] == 0)
2661 continue;
2662
2663 if (gfc_current_state () == COMP_DERIVED
2664 && d != DECL_DIMENSION && d != DECL_POINTER
e14bee04 2665 && d != DECL_COLON && d != DECL_PRIVATE
2666 && d != DECL_PUBLIC && d != DECL_NONE)
4ee9c684 2667 {
2294b616 2668 if (d == DECL_ALLOCATABLE)
2669 {
1a9745d2 2670 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2671 "attribute at %C in a TYPE definition")
e14bee04 2672 == FAILURE)
2294b616 2673 {
2674 m = MATCH_ERROR;
2675 goto cleanup;
2676 }
1a9745d2 2677 }
2678 else
2294b616 2679 {
2680 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
e14bee04 2681 &seen_at[d]);
2294b616 2682 m = MATCH_ERROR;
2683 goto cleanup;
2684 }
4ee9c684 2685 }
2686
ea13b9b7 2687 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
1a9745d2 2688 && gfc_current_state () != COMP_MODULE)
ea13b9b7 2689 {
2690 if (d == DECL_PRIVATE)
2691 attr = "PRIVATE";
2692 else
2693 attr = "PUBLIC";
e14bee04 2694 if (gfc_current_state () == COMP_DERIVED
2695 && gfc_state_stack->previous
2696 && gfc_state_stack->previous->state == COMP_MODULE)
2697 {
2698 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2699 "at %L in a TYPE definition", attr,
2700 &seen_at[d])
2701 == FAILURE)
2702 {
2703 m = MATCH_ERROR;
2704 goto cleanup;
2705 }
2706 }
2707 else
2708 {
2709 gfc_error ("%s attribute at %L is not allowed outside of the "
2710 "specification part of a module", attr, &seen_at[d]);
2711 m = MATCH_ERROR;
2712 goto cleanup;
2713 }
ea13b9b7 2714 }
2715
4ee9c684 2716 switch (d)
2717 {
2718 case DECL_ALLOCATABLE:
2719 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2720 break;
2721
2722 case DECL_DIMENSION:
950683ed 2723 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
4ee9c684 2724 break;
2725
2726 case DECL_EXTERNAL:
2727 t = gfc_add_external (&current_attr, &seen_at[d]);
2728 break;
2729
2730 case DECL_IN:
2731 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2732 break;
2733
2734 case DECL_OUT:
2735 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2736 break;
2737
2738 case DECL_INOUT:
2739 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2740 break;
2741
2742 case DECL_INTRINSIC:
2743 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2744 break;
2745
2746 case DECL_OPTIONAL:
2747 t = gfc_add_optional (&current_attr, &seen_at[d]);
2748 break;
2749
2750 case DECL_PARAMETER:
950683ed 2751 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
4ee9c684 2752 break;
2753
2754 case DECL_POINTER:
2755 t = gfc_add_pointer (&current_attr, &seen_at[d]);
2756 break;
2757
3ea52af3 2758 case DECL_PROTECTED:
2759 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2760 {
2761 gfc_error ("PROTECTED at %C only allowed in specification "
2762 "part of a module");
2763 t = FAILURE;
2764 break;
2765 }
2766
1a9745d2 2767 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2768 "attribute at %C")
3ea52af3 2769 == FAILURE)
2770 t = FAILURE;
2771 else
2772 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
2773 break;
2774
4ee9c684 2775 case DECL_PRIVATE:
950683ed 2776 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2777 &seen_at[d]);
4ee9c684 2778 break;
2779
2780 case DECL_PUBLIC:
950683ed 2781 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2782 &seen_at[d]);
4ee9c684 2783 break;
2784
2785 case DECL_SAVE:
950683ed 2786 t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
4ee9c684 2787 break;
2788
2789 case DECL_TARGET:
2790 t = gfc_add_target (&current_attr, &seen_at[d]);
2791 break;
2792
c5d33754 2793 case DECL_IS_BIND_C:
2794 t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
2795 break;
2796
8f6339b6 2797 case DECL_VALUE:
1a9745d2 2798 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2799 "at %C")
8f6339b6 2800 == FAILURE)
2801 t = FAILURE;
2802 else
2803 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
2804 break;
2805
ef814c81 2806 case DECL_VOLATILE:
2807 if (gfc_notify_std (GFC_STD_F2003,
1a9745d2 2808 "Fortran 2003: VOLATILE attribute at %C")
ef814c81 2809 == FAILURE)
2810 t = FAILURE;
2811 else
2812 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2813 break;
2814
4ee9c684 2815 default:
2816 gfc_internal_error ("match_attr_spec(): Bad attribute");
2817 }
2818
2819 if (t == FAILURE)
2820 {
2821 m = MATCH_ERROR;
2822 goto cleanup;
2823 }
2824 }
2825
2826 colon_seen = 1;
2827 return MATCH_YES;
2828
2829cleanup:
cbb9e6aa 2830 gfc_current_locus = start;
4ee9c684 2831 gfc_free_array_spec (current_as);
2832 current_as = NULL;
2833 return m;
2834}
2835
2836
c5d33754 2837/* Set the binding label, dest_label, either with the binding label
2838 stored in the given gfc_typespec, ts, or if none was provided, it
2839 will be the symbol name in all lower case, as required by the draft
2840 (J3/04-007, section 15.4.1). If a binding label was given and
2841 there is more than one argument (num_idents), it is an error. */
2842
2843try
2844set_binding_label (char *dest_label, const char *sym_name, int num_idents)
2845{
2846 if (curr_binding_label[0] != '\0')
2847 {
2848 if (num_idents > 1 || num_idents_on_line > 1)
2849 {
2850 gfc_error ("Multiple identifiers provided with "
2851 "single NAME= specifier at %C");
2852 return FAILURE;
2853 }
2854
2855 /* Binding label given; store in temp holder til have sym. */
2856 strncpy (dest_label, curr_binding_label,
2857 strlen (curr_binding_label) + 1);
2858 }
2859 else
2860 {
2861 /* No binding label given, and the NAME= specifier did not exist,
2862 which means there was no NAME="". */
2863 if (sym_name != NULL && has_name_equals == 0)
2864 strncpy (dest_label, sym_name, strlen (sym_name) + 1);
2865 }
2866
2867 return SUCCESS;
2868}
2869
2870
2871/* Set the status of the given common block as being BIND(C) or not,
2872 depending on the given parameter, is_bind_c. */
2873
2874void
2875set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
2876{
2877 com_block->is_bind_c = is_bind_c;
2878 return;
2879}
2880
2881
2882/* Verify that the given gfc_typespec is for a C interoperable type. */
2883
2884try
2885verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
2886{
2887 try t;
2888
2889 /* Make sure the kind used is appropriate for the type.
2890 The f90_type is unknown if an integer constant was
2891 used (e.g., real(4), bind(c) :: myFloat). */
2892 if (ts->f90_type != BT_UNKNOWN)
2893 {
2894 t = gfc_validate_c_kind (ts);
2895 if (t != SUCCESS)
2896 {
2897 /* Print an error, but continue parsing line. */
2898 gfc_error_now ("C kind parameter is for type %s but "
2899 "symbol '%s' at %L is of type %s",
2900 gfc_basic_typename (ts->f90_type),
2901 name, where,
2902 gfc_basic_typename (ts->type));
2903 }
2904 }
2905
2906 /* Make sure the kind is C interoperable. This does not care about the
2907 possible error above. */
2908 if (ts->type == BT_DERIVED && ts->derived != NULL)
2909 return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
2910 else if (ts->is_c_interop != 1)
2911 return FAILURE;
2912
2913 return SUCCESS;
2914}
2915
2916
2917/* Verify that the variables of a given common block, which has been
2918 defined with the attribute specifier bind(c), to be of a C
2919 interoperable type. Errors will be reported here, if
2920 encountered. */
2921
2922try
2923verify_com_block_vars_c_interop (gfc_common_head *com_block)
2924{
2925 gfc_symbol *curr_sym = NULL;
2926 try retval = SUCCESS;
2927
2928 curr_sym = com_block->head;
2929
2930 /* Make sure we have at least one symbol. */
2931 if (curr_sym == NULL)
2932 return retval;
2933
2934 /* Here we know we have a symbol, so we'll execute this loop
2935 at least once. */
2936 do
2937 {
2938 /* The second to last param, 1, says this is in a common block. */
2939 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
2940 curr_sym = curr_sym->common_next;
2941 } while (curr_sym != NULL);
2942
2943 return retval;
2944}
2945
2946
2947/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
2948 an appropriate error message is reported. */
2949
2950try
2951verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
2952 int is_in_common, gfc_common_head *com_block)
2953{
2954 try retval = SUCCESS;
4f7bb9ec 2955
2956 if (tmp_sym->attr.function && tmp_sym->result != NULL)
2957 {
2958 tmp_sym = tmp_sym->result;
2959 /* Make sure it wasn't an implicitly typed result. */
2960 if (tmp_sym->attr.implicit_type)
2961 {
2962 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
2963 "%L may not be C interoperable", tmp_sym->name,
2964 &tmp_sym->declared_at);
2965 tmp_sym->ts.f90_type = tmp_sym->ts.type;
2966 /* Mark it as C interoperable to prevent duplicate warnings. */
2967 tmp_sym->ts.is_c_interop = 1;
2968 tmp_sym->attr.is_c_interop = 1;
2969 }
2970 }
c5d33754 2971
2972 /* Here, we know we have the bind(c) attribute, so if we have
2973 enough type info, then verify that it's a C interop kind.
2974 The info could be in the symbol already, or possibly still in
2975 the given ts (current_ts), so look in both. */
2976 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
2977 {
2978 if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
2979 &(tmp_sym->declared_at)) != SUCCESS)
2980 {
2981 /* See if we're dealing with a sym in a common block or not. */
2982 if (is_in_common == 1)
2983 {
2984 gfc_warning ("Variable '%s' in common block '%s' at %L "
2985 "may not be a C interoperable "
2986 "kind though common block '%s' is BIND(C)",
2987 tmp_sym->name, com_block->name,
2988 &(tmp_sym->declared_at), com_block->name);
2989 }
2990 else
2991 {
2992 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
2993 gfc_error ("Type declaration '%s' at %L is not C "
2994 "interoperable but it is BIND(C)",
2995 tmp_sym->name, &(tmp_sym->declared_at));
2996 else
2997 gfc_warning ("Variable '%s' at %L "
2998 "may not be a C interoperable "
2999 "kind but it is bind(c)",
3000 tmp_sym->name, &(tmp_sym->declared_at));
3001 }
3002 }
3003
3004 /* Variables declared w/in a common block can't be bind(c)
3005 since there's no way for C to see these variables, so there's
3006 semantically no reason for the attribute. */
3007 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3008 {
3009 gfc_error ("Variable '%s' in common block '%s' at "
3010 "%L cannot be declared with BIND(C) "
3011 "since it is not a global",
3012 tmp_sym->name, com_block->name,
3013 &(tmp_sym->declared_at));
3014 retval = FAILURE;
3015 }
3016
3017 /* Scalar variables that are bind(c) can not have the pointer
3018 or allocatable attributes. */
3019 if (tmp_sym->attr.is_bind_c == 1)
3020 {
3021 if (tmp_sym->attr.pointer == 1)
3022 {
3023 gfc_error ("Variable '%s' at %L cannot have both the "
3024 "POINTER and BIND(C) attributes",
3025 tmp_sym->name, &(tmp_sym->declared_at));
3026 retval = FAILURE;
3027 }
3028
3029 if (tmp_sym->attr.allocatable == 1)
3030 {
3031 gfc_error ("Variable '%s' at %L cannot have both the "
3032 "ALLOCATABLE and BIND(C) attributes",
3033 tmp_sym->name, &(tmp_sym->declared_at));
3034 retval = FAILURE;
3035 }
3036
3037 /* If it is a BIND(C) function, make sure the return value is a
3038 scalar value. The previous tests in this function made sure
3039 the type is interoperable. */
3040 if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3041 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3042 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3043
3044 /* BIND(C) functions can not return a character string. */
3045 if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3046 if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3047 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3048 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3049 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3050 "be a character string", tmp_sym->name,
3051 &(tmp_sym->declared_at));
3052 }
3053 }
3054
3055 /* See if the symbol has been marked as private. If it has, make sure
3056 there is no binding label and warn the user if there is one. */
3057 if (tmp_sym->attr.access == ACCESS_PRIVATE
3058 && tmp_sym->binding_label[0] != '\0')
3059 /* Use gfc_warning_now because we won't say that the symbol fails
3060 just because of this. */
3061 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3062 "given the binding label '%s'", tmp_sym->name,
3063 &(tmp_sym->declared_at), tmp_sym->binding_label);
3064
3065 return retval;
3066}
3067
3068
3069/* Set the appropriate fields for a symbol that's been declared as
3070 BIND(C) (the is_bind_c flag and the binding label), and verify that
3071 the type is C interoperable. Errors are reported by the functions
3072 used to set/test these fields. */
3073
3074try
3075set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3076{
3077 try retval = SUCCESS;
3078
3079 /* TODO: Do we need to make sure the vars aren't marked private? */
3080
3081 /* Set the is_bind_c bit in symbol_attribute. */
3082 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3083
3084 if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3085 num_idents) != SUCCESS)
3086 return FAILURE;
3087
3088 return retval;
3089}
3090
3091
3092/* Set the fields marking the given common block as BIND(C), including
3093 a binding label, and report any errors encountered. */
3094
3095try
3096set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3097{
3098 try retval = SUCCESS;
3099
3100 /* destLabel, common name, typespec (which may have binding label). */
3101 if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3102 != SUCCESS)
3103 return FAILURE;
3104
3105 /* Set the given common block (com_block) to being bind(c) (1). */
3106 set_com_block_bind_c (com_block, 1);
3107
3108 return retval;
3109}
3110
3111
3112/* Retrieve the list of one or more identifiers that the given bind(c)
3113 attribute applies to. */
3114
3115try
3116get_bind_c_idents (void)
3117{
3118 char name[GFC_MAX_SYMBOL_LEN + 1];
3119 int num_idents = 0;
3120 gfc_symbol *tmp_sym = NULL;
3121 match found_id;
3122 gfc_common_head *com_block = NULL;
3123
3124 if (gfc_match_name (name) == MATCH_YES)
3125 {
3126 found_id = MATCH_YES;
3127 gfc_get_ha_symbol (name, &tmp_sym);
3128 }
3129 else if (match_common_name (name) == MATCH_YES)
3130 {
3131 found_id = MATCH_YES;
3132 com_block = gfc_get_common (name, 0);
3133 }
3134 else
3135 {
3136 gfc_error ("Need either entity or common block name for "
3137 "attribute specification statement at %C");
3138 return FAILURE;
3139 }
3140
3141 /* Save the current identifier and look for more. */
3142 do
3143 {
3144 /* Increment the number of identifiers found for this spec stmt. */
3145 num_idents++;
3146
3147 /* Make sure we have a sym or com block, and verify that it can
3148 be bind(c). Set the appropriate field(s) and look for more
3149 identifiers. */
3150 if (tmp_sym != NULL || com_block != NULL)
3151 {
3152 if (tmp_sym != NULL)
3153 {
3154 if (set_verify_bind_c_sym (tmp_sym, num_idents)
3155 != SUCCESS)
3156 return FAILURE;
3157 }
3158 else
3159 {
3160 if (set_verify_bind_c_com_block(com_block, num_idents)
3161 != SUCCESS)
3162 return FAILURE;
3163 }
3164
3165 /* Look to see if we have another identifier. */
3166 tmp_sym = NULL;
3167 if (gfc_match_eos () == MATCH_YES)
3168 found_id = MATCH_NO;
3169 else if (gfc_match_char (',') != MATCH_YES)
3170 found_id = MATCH_NO;
3171 else if (gfc_match_name (name) == MATCH_YES)
3172 {
3173 found_id = MATCH_YES;
3174 gfc_get_ha_symbol (name, &tmp_sym);
3175 }
3176 else if (match_common_name (name) == MATCH_YES)
3177 {
3178 found_id = MATCH_YES;
3179 com_block = gfc_get_common (name, 0);
3180 }
3181 else
3182 {
3183 gfc_error ("Missing entity or common block name for "
3184 "attribute specification statement at %C");
3185 return FAILURE;
3186 }
3187 }
3188 else
3189 {
3190 gfc_internal_error ("Missing symbol");
3191 }
3192 } while (found_id == MATCH_YES);
3193
3194 /* if we get here we were successful */
3195 return SUCCESS;
3196}
3197
3198
3199/* Try and match a BIND(C) attribute specification statement. */
3200
3201match
3202gfc_match_bind_c_stmt (void)
3203{
3204 match found_match = MATCH_NO;
3205 gfc_typespec *ts;
3206
3207 ts = &current_ts;
3208
3209 /* This may not be necessary. */
3210 gfc_clear_ts (ts);
3211 /* Clear the temporary binding label holder. */
3212 curr_binding_label[0] = '\0';
3213
3214 /* Look for the bind(c). */
3215 found_match = gfc_match_bind_c (NULL);
3216
3217 if (found_match == MATCH_YES)
3218 {
3219 /* Look for the :: now, but it is not required. */
3220 gfc_match (" :: ");
3221
3222 /* Get the identifier(s) that needs to be updated. This may need to
3223 change to hand the flag(s) for the attr specified so all identifiers
3224 found can have all appropriate parts updated (assuming that the same
3225 spec stmt can have multiple attrs, such as both bind(c) and
3226 allocatable...). */
3227 if (get_bind_c_idents () != SUCCESS)
3228 /* Error message should have printed already. */
3229 return MATCH_ERROR;
3230 }
3231
3232 return found_match;
3233}
3234
3235
4ee9c684 3236/* Match a data declaration statement. */
3237
3238match
3239gfc_match_data_decl (void)
3240{
3241 gfc_symbol *sym;
3242 match m;
3923b69f 3243 int elem;
4ee9c684 3244
c5d33754 3245 num_idents_on_line = 0;
3246
39351103 3247 m = match_type_spec (&current_ts, 0);
4ee9c684 3248 if (m != MATCH_YES)
3249 return m;
3250
3251 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3252 {
3253 sym = gfc_use_derived (current_ts.derived);
3254
3255 if (sym == NULL)
3256 {
3257 m = MATCH_ERROR;
3258 goto cleanup;
3259 }
3260
3261 current_ts.derived = sym;
3262 }
3263
3264 m = match_attr_spec ();
3265 if (m == MATCH_ERROR)
3266 {
3267 m = MATCH_NO;
3268 goto cleanup;
3269 }
3270
3271 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
3272 {
3273
3274 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3275 goto ok;
3276
40cf8078 3277 gfc_find_symbol (current_ts.derived->name,
1a9745d2 3278 current_ts.derived->ns->parent, 1, &sym);
4ee9c684 3279
40cf8078 3280 /* Any symbol that we find had better be a type definition
1a9745d2 3281 which has its components defined. */
40cf8078 3282 if (sym != NULL && sym->attr.flavor == FL_DERIVED
1a9745d2 3283 && current_ts.derived->components != NULL)
4ee9c684 3284 goto ok;
3285
40cf8078 3286 /* Now we have an error, which we signal, and then fix up
3287 because the knock-on is plain and simple confusing. */
3288 gfc_error_now ("Derived type at %C has not been previously defined "
1a9745d2 3289 "and so cannot appear in a derived type definition");
40cf8078 3290 current_attr.pointer = 1;
3291 goto ok;
4ee9c684 3292 }
3293
3294ok:
3295 /* If we have an old-style character declaration, and no new-style
3296 attribute specifications, then there a comma is optional between
3297 the type specification and the variable list. */
3298 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3299 gfc_match_char (',');
3300
3923b69f 3301 /* Give the types/attributes to symbols that follow. Give the element
3302 a number so that repeat character length expressions can be copied. */
3303 elem = 1;
4ee9c684 3304 for (;;)
3305 {
c5d33754 3306 num_idents_on_line++;
3923b69f 3307 m = variable_decl (elem++);
4ee9c684 3308 if (m == MATCH_ERROR)
3309 goto cleanup;
3310 if (m == MATCH_NO)
3311 break;
3312
3313 if (gfc_match_eos () == MATCH_YES)
3314 goto cleanup;
3315 if (gfc_match_char (',') != MATCH_YES)
3316 break;
3317 }
3318
8f0bdb23 3319 if (gfc_error_flag_test () == 0)
3320 gfc_error ("Syntax error in data declaration at %C");
4ee9c684 3321 m = MATCH_ERROR;
3322
af29c1f0 3323 gfc_free_data_all (gfc_current_ns);
3324
4ee9c684 3325cleanup:
3326 gfc_free_array_spec (current_as);
3327 current_as = NULL;
3328 return m;
3329}
3330
3331
3332/* Match a prefix associated with a function or subroutine
3333 declaration. If the typespec pointer is nonnull, then a typespec
3334 can be matched. Note that if nothing matches, MATCH_YES is
3335 returned (the null string was matched). */
3336
3337static match
1a9745d2 3338match_prefix (gfc_typespec *ts)
4ee9c684 3339{
3340 int seen_type;
3341
3342 gfc_clear_attr (&current_attr);
3343 seen_type = 0;
3344
3345loop:
3346 if (!seen_type && ts != NULL
39351103 3347 && match_type_spec (ts, 0) == MATCH_YES
4ee9c684 3348 && gfc_match_space () == MATCH_YES)
3349 {
3350
3351 seen_type = 1;
3352 goto loop;
3353 }
3354
3355 if (gfc_match ("elemental% ") == MATCH_YES)
3356 {
3357 if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3358 return MATCH_ERROR;
3359
3360 goto loop;
3361 }
3362
3363 if (gfc_match ("pure% ") == MATCH_YES)
3364 {
3365 if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3366 return MATCH_ERROR;
3367
3368 goto loop;
3369 }
3370
3371 if (gfc_match ("recursive% ") == MATCH_YES)
3372 {
3373 if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3374 return MATCH_ERROR;
3375
3376 goto loop;
3377 }
3378
3379 /* At this point, the next item is not a prefix. */
3380 return MATCH_YES;
3381}
3382
3383
3384/* Copy attributes matched by match_prefix() to attributes on a symbol. */
3385
3386static try
1a9745d2 3387copy_prefix (symbol_attribute *dest, locus *where)
4ee9c684 3388{
4ee9c684 3389 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3390 return FAILURE;
3391
3392 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3393 return FAILURE;
3394
3395 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3396 return FAILURE;
3397
3398 return SUCCESS;
3399}
3400
3401
3402/* Match a formal argument list. */
3403
3404match
1a9745d2 3405gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
4ee9c684 3406{
3407 gfc_formal_arglist *head, *tail, *p, *q;
3408 char name[GFC_MAX_SYMBOL_LEN + 1];
3409 gfc_symbol *sym;
3410 match m;
3411
3412 head = tail = NULL;
3413
3414 if (gfc_match_char ('(') != MATCH_YES)
3415 {
3416 if (null_flag)
3417 goto ok;
3418 return MATCH_NO;
3419 }
3420
3421 if (gfc_match_char (')') == MATCH_YES)
3422 goto ok;
3423
3424 for (;;)
3425 {
3426 if (gfc_match_char ('*') == MATCH_YES)
3427 sym = NULL;
3428 else
3429 {
3430 m = gfc_match_name (name);
3431 if (m != MATCH_YES)
3432 goto cleanup;
3433
3434 if (gfc_get_symbol (name, NULL, &sym))
3435 goto cleanup;
3436 }
3437
3438 p = gfc_get_formal_arglist ();
3439
3440 if (head == NULL)
3441 head = tail = p;
3442 else
3443 {
3444 tail->next = p;
3445 tail = p;
3446 }
3447
3448 tail->sym = sym;
3449
3450 /* We don't add the VARIABLE flavor because the name could be a
1a9745d2 3451 dummy procedure. We don't apply these attributes to formal
3452 arguments of statement functions. */
4ee9c684 3453 if (sym != NULL && !st_flag
950683ed 3454 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
4ee9c684 3455 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3456 {
3457 m = MATCH_ERROR;
3458 goto cleanup;
3459 }
3460
3461 /* The name of a program unit can be in a different namespace,
1a9745d2 3462 so check for it explicitly. After the statement is accepted,
3463 the name is checked for especially in gfc_get_symbol(). */
4ee9c684 3464 if (gfc_new_block != NULL && sym != NULL
3465 && strcmp (sym->name, gfc_new_block->name) == 0)
3466 {
3467 gfc_error ("Name '%s' at %C is the name of the procedure",
3468 sym->name);
3469 m = MATCH_ERROR;
3470 goto cleanup;
3471 }
3472
3473 if (gfc_match_char (')') == MATCH_YES)
3474 goto ok;
3475
3476 m = gfc_match_char (',');
3477 if (m != MATCH_YES)
3478 {
3479 gfc_error ("Unexpected junk in formal argument list at %C");
3480 goto cleanup;
3481 }
3482 }
3483
3484ok:
3485 /* Check for duplicate symbols in the formal argument list. */
3486 if (head != NULL)
3487 {
3488 for (p = head; p->next; p = p->next)
3489 {
3490 if (p->sym == NULL)
3491 continue;
3492
3493 for (q = p->next; q; q = q->next)
3494 if (p->sym == q->sym)
3495 {
1a9745d2 3496 gfc_error ("Duplicate symbol '%s' in formal argument list "
3497 "at %C", p->sym->name);
4ee9c684 3498
3499 m = MATCH_ERROR;
3500 goto cleanup;
3501 }
3502 }
3503 }
3504
f6d0e37a 3505 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3506 == FAILURE)
4ee9c684 3507 {
3508 m = MATCH_ERROR;
3509 goto cleanup;
3510 }
3511
3512 return MATCH_YES;
3513
3514cleanup:
3515 gfc_free_formal_arglist (head);
3516 return m;
3517}
3518
3519
3520/* Match a RESULT specification following a function declaration or
3521 ENTRY statement. Also matches the end-of-statement. */
3522
3523static match
f6d0e37a 3524match_result (gfc_symbol *function, gfc_symbol **result)
4ee9c684 3525{
3526 char name[GFC_MAX_SYMBOL_LEN + 1];
3527 gfc_symbol *r;
3528 match m;
3529
3530 if (gfc_match (" result (") != MATCH_YES)
3531 return MATCH_NO;
3532
3533 m = gfc_match_name (name);
3534 if (m != MATCH_YES)
3535 return m;
3536
c5d33754 3537 /* Get the right paren, and that's it because there could be the
3538 bind(c) attribute after the result clause. */
3539 if (gfc_match_char(')') != MATCH_YES)
4ee9c684 3540 {
c5d33754 3541 /* TODO: should report the missing right paren here. */
4ee9c684 3542 return MATCH_ERROR;
3543 }
3544
3545 if (strcmp (function->name, name) == 0)
3546 {
1a9745d2 3547 gfc_error ("RESULT variable at %C must be different than function name");
4ee9c684 3548 return MATCH_ERROR;
3549 }
3550
3551 if (gfc_get_symbol (name, NULL, &r))
3552 return MATCH_ERROR;
3553
950683ed 3554 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3555 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
4ee9c684 3556 return MATCH_ERROR;
3557
3558 *result = r;
3559
3560 return MATCH_YES;
3561}
3562
3563
c5d33754 3564/* Match a function suffix, which could be a combination of a result
3565 clause and BIND(C), either one, or neither. The draft does not
3566 require them to come in a specific order. */
3567
3568match
3569gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3570{
3571 match is_bind_c; /* Found bind(c). */
3572 match is_result; /* Found result clause. */
3573 match found_match; /* Status of whether we've found a good match. */
3574 int peek_char; /* Character we're going to peek at. */
3575
3576 /* Initialize to having found nothing. */
3577 found_match = MATCH_NO;
3578 is_bind_c = MATCH_NO;
3579 is_result = MATCH_NO;
3580
3581 /* Get the next char to narrow between result and bind(c). */
3582 gfc_gobble_whitespace ();
3583 peek_char = gfc_peek_char ();
3584
3585 switch (peek_char)
3586 {
3587 case 'r':
3588 /* Look for result clause. */
3589 is_result = match_result (sym, result);
3590 if (is_result == MATCH_YES)
3591 {
3592 /* Now see if there is a bind(c) after it. */
3593 is_bind_c = gfc_match_bind_c (sym);
3594 /* We've found the result clause and possibly bind(c). */
3595 found_match = MATCH_YES;
3596 }
3597 else
3598 /* This should only be MATCH_ERROR. */
3599 found_match = is_result;
3600 break;
3601 case 'b':
3602 /* Look for bind(c) first. */
3603 is_bind_c = gfc_match_bind_c (sym);
3604 if (is_bind_c == MATCH_YES)
3605 {
3606 /* Now see if a result clause followed it. */
3607 is_result = match_result (sym, result);
3608 found_match = MATCH_YES;
3609 }
3610 else
3611 {
3612 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
3613 found_match = MATCH_ERROR;
3614 }
3615 break;
3616 default:
3617 gfc_error ("Unexpected junk after function declaration at %C");
3618 found_match = MATCH_ERROR;
3619 break;
3620 }
3621
c5d33754 3622 if (is_bind_c == MATCH_YES)
3623 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3624 == FAILURE)
3625 return MATCH_ERROR;
3626
3627 return found_match;
3628}
3629
3630
4ee9c684 3631/* Match a function declaration. */
3632
3633match
3634gfc_match_function_decl (void)
3635{
3636 char name[GFC_MAX_SYMBOL_LEN + 1];
3637 gfc_symbol *sym, *result;
3638 locus old_loc;
3639 match m;
c5d33754 3640 match suffix_match;
3641 match found_match; /* Status returned by match func. */
4ee9c684 3642
3643 if (gfc_current_state () != COMP_NONE
3644 && gfc_current_state () != COMP_INTERFACE
3645 && gfc_current_state () != COMP_CONTAINS)
3646 return MATCH_NO;
3647
3648 gfc_clear_ts (&current_ts);
3649
cbb9e6aa 3650 old_loc = gfc_current_locus;
4ee9c684 3651
3652 m = match_prefix (&current_ts);
3653 if (m != MATCH_YES)
3654 {
cbb9e6aa 3655 gfc_current_locus = old_loc;
4ee9c684 3656 return m;
3657 }
3658
3659 if (gfc_match ("function% %n", name) != MATCH_YES)
3660 {
cbb9e6aa 3661 gfc_current_locus = old_loc;
4ee9c684 3662 return MATCH_NO;
3663 }
d77f260f 3664 if (get_proc_name (name, &sym, false))
4ee9c684 3665 return MATCH_ERROR;
3666 gfc_new_block = sym;
3667
3668 m = gfc_match_formal_arglist (sym, 0, 0);
3669 if (m == MATCH_NO)
9b435b6d 3670 {
3671 gfc_error ("Expected formal argument list in function "
1a9745d2 3672 "definition at %C");
9b435b6d 3673 m = MATCH_ERROR;
3674 goto cleanup;
3675 }
4ee9c684 3676 else if (m == MATCH_ERROR)
3677 goto cleanup;
3678
3679 result = NULL;
3680
c5d33754 3681 /* According to the draft, the bind(c) and result clause can
3682 come in either order after the formal_arg_list (i.e., either
3683 can be first, both can exist together or by themselves or neither
3684 one). Therefore, the match_result can't match the end of the
3685 string, and check for the bind(c) or result clause in either order. */
3686 found_match = gfc_match_eos ();
3687
3688 /* Make sure that it isn't already declared as BIND(C). If it is, it
3689 must have been marked BIND(C) with a BIND(C) attribute and that is
3690 not allowed for procedures. */
3691 if (sym->attr.is_bind_c == 1)
3692 {
3693 sym->attr.is_bind_c = 0;
3694 if (sym->old_symbol != NULL)
3695 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3696 "variables or common blocks",
3697 &(sym->old_symbol->declared_at));
3698 else
3699 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3700 "variables or common blocks", &gfc_current_locus);
4ee9c684 3701 }
3702
c5d33754 3703 if (found_match != MATCH_YES)
4ee9c684 3704 {
c5d33754 3705 /* If we haven't found the end-of-statement, look for a suffix. */
3706 suffix_match = gfc_match_suffix (sym, &result);
3707 if (suffix_match == MATCH_YES)
3708 /* Need to get the eos now. */
3709 found_match = gfc_match_eos ();
3710 else
3711 found_match = suffix_match;
4ee9c684 3712 }
3713
c5d33754 3714 if(found_match != MATCH_YES)
3715 m = MATCH_ERROR;
4ee9c684 3716 else
3717 {
c5d33754 3718 /* Make changes to the symbol. */
3719 m = MATCH_ERROR;
3720
3721 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
3722 goto cleanup;
3723
3724 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
3725 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3726 goto cleanup;
4ee9c684 3727
c5d33754 3728 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
3729 && !sym->attr.implicit_type)
3730 {
3731 gfc_error ("Function '%s' at %C already has a type of %s", name,
3732 gfc_basic_typename (sym->ts.type));
3733 goto cleanup;
3734 }
3735
3736 if (result == NULL)
3737 {
3738 sym->ts = current_ts;
3739 sym->result = sym;
3740 }
3741 else
3742 {
3743 result->ts = current_ts;
3744 sym->result = result;
3745 }
3746
3747 return MATCH_YES;
3748 }
4ee9c684 3749
3750cleanup:
cbb9e6aa 3751 gfc_current_locus = old_loc;
4ee9c684 3752 return m;
3753}
3754
1a9745d2 3755
3756/* This is mostly a copy of parse.c(add_global_procedure) but modified to
3757 pass the name of the entry, rather than the gfc_current_block name, and
3758 to return false upon finding an existing global entry. */
858f9894 3759
3760static bool
1a9745d2 3761add_global_entry (const char *name, int sub)
858f9894 3762{
3763 gfc_gsymbol *s;
3764
3765 s = gfc_get_gsymbol(name);
3766
3767 if (s->defined
1a9745d2 3768 || (s->type != GSYM_UNKNOWN
3769 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
858f9894 3770 global_used(s, NULL);
3771 else
3772 {
3773 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3774 s->where = gfc_current_locus;
3775 s->defined = 1;
3776 return true;
3777 }
3778 return false;
3779}
4ee9c684 3780
1a9745d2 3781
4ee9c684 3782/* Match an ENTRY statement. */
3783
3784match
3785gfc_match_entry (void)
3786{
1b716045 3787 gfc_symbol *proc;
3788 gfc_symbol *result;
3789 gfc_symbol *entry;
4ee9c684 3790 char name[GFC_MAX_SYMBOL_LEN + 1];
3791 gfc_compile_state state;
3792 match m;
1b716045 3793 gfc_entry_list *el;
7b5e1acc 3794 locus old_loc;
d77f260f 3795 bool module_procedure;
4ee9c684 3796
3797 m = gfc_match_name (name);
3798 if (m != MATCH_YES)
3799 return m;
3800
1b716045 3801 state = gfc_current_state ();
ea37f786 3802 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
1b716045 3803 {
ea37f786 3804 switch (state)
3805 {
3806 case COMP_PROGRAM:
3807 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
3808 break;
3809 case COMP_MODULE:
3810 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
3811 break;
3812 case COMP_BLOCK_DATA:
1a9745d2 3813 gfc_error ("ENTRY statement at %C cannot appear within "
3814 "a BLOCK DATA");
ea37f786 3815 break;
3816 case COMP_INTERFACE:
1a9745d2 3817 gfc_error ("ENTRY statement at %C cannot appear within "
3818 "an INTERFACE");
ea37f786 3819 break;
3820 case COMP_DERIVED:
1a9745d2 3821 gfc_error ("ENTRY statement at %C cannot appear within "
3822 "a DERIVED TYPE block");
ea37f786 3823 break;
3824 case COMP_IF:
1a9745d2 3825 gfc_error ("ENTRY statement at %C cannot appear within "
3826 "an IF-THEN block");
ea37f786 3827 break;
3828 case COMP_DO:
1a9745d2 3829 gfc_error ("ENTRY statement at %C cannot appear within "
3830 "a DO block");
ea37f786 3831 break;
3832 case COMP_SELECT:
1a9745d2 3833 gfc_error ("ENTRY statement at %C cannot appear within "
3834 "a SELECT block");
ea37f786 3835 break;
3836 case COMP_FORALL:
1a9745d2 3837 gfc_error ("ENTRY statement at %C cannot appear within "
3838 "a FORALL block");
ea37f786 3839 break;
3840 case COMP_WHERE:
1a9745d2 3841 gfc_error ("ENTRY statement at %C cannot appear within "
3842 "a WHERE block");
ea37f786 3843 break;
3844 case COMP_CONTAINS:
1a9745d2 3845 gfc_error ("ENTRY statement at %C cannot appear within "
3846 "a contained subprogram");
ea37f786 3847 break;
3848 default:
3849 gfc_internal_error ("gfc_match_entry(): Bad state");
3850 }
1b716045 3851 return MATCH_ERROR;
3852 }
3853
d77f260f 3854 module_procedure = gfc_current_ns->parent != NULL
1a9745d2 3855 && gfc_current_ns->parent->proc_name
3856 && gfc_current_ns->parent->proc_name->attr.flavor
3857 == FL_MODULE;
d77f260f 3858
1b716045 3859 if (gfc_current_ns->parent != NULL
3860 && gfc_current_ns->parent->proc_name
d77f260f 3861 && !module_procedure)
1b716045 3862 {
3863 gfc_error("ENTRY statement at %C cannot appear in a "
3864 "contained procedure");
3865 return MATCH_ERROR;
3866 }
3867
d77f260f 3868 /* Module function entries need special care in get_proc_name
3869 because previous references within the function will have
3870 created symbols attached to the current namespace. */
3871 if (get_proc_name (name, &entry,
3872 gfc_current_ns->parent != NULL
3873 && module_procedure
3874 && gfc_current_ns->proc_name->attr.function))
4ee9c684 3875 return MATCH_ERROR;
3876
1b716045 3877 proc = gfc_current_block ();
3878
3879 if (state == COMP_SUBROUTINE)
4ee9c684 3880 {
950683ed 3881 /* An entry in a subroutine. */
858f9894 3882 if (!add_global_entry (name, 1))
3883 return MATCH_ERROR;
3884
4ee9c684 3885 m = gfc_match_formal_arglist (entry, 0, 1);
3886 if (m != MATCH_YES)
3887 return MATCH_ERROR;
3888
950683ed 3889 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3890 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4ee9c684 3891 return MATCH_ERROR;
1b716045 3892 }
3893 else
3894 {
7b5e1acc 3895 /* An entry in a function.
1a9745d2 3896 We need to take special care because writing
3897 ENTRY f()
3898 as
3899 ENTRY f
3900 is allowed, whereas
3901 ENTRY f() RESULT (r)
3902 can't be written as
3903 ENTRY f RESULT (r). */
858f9894 3904 if (!add_global_entry (name, 0))
3905 return MATCH_ERROR;
3906
7b5e1acc 3907 old_loc = gfc_current_locus;
3908 if (gfc_match_eos () == MATCH_YES)
3909 {
3910 gfc_current_locus = old_loc;
3911 /* Match the empty argument list, and add the interface to
3912 the symbol. */
3913 m = gfc_match_formal_arglist (entry, 0, 1);
3914 }
3915 else
3916 m = gfc_match_formal_arglist (entry, 0, 0);
3917
4ee9c684 3918 if (m != MATCH_YES)
3919 return MATCH_ERROR;
3920
4ee9c684 3921 result = NULL;
3922
3923 if (gfc_match_eos () == MATCH_YES)
3924 {
950683ed 3925 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3926 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4ee9c684 3927 return MATCH_ERROR;
3928
c6871095 3929 entry->result = entry;
4ee9c684 3930 }
3931 else
3932 {
1b716045 3933 m = match_result (proc, &result);
4ee9c684 3934 if (m == MATCH_NO)
3935 gfc_syntax_error (ST_ENTRY);
3936 if (m != MATCH_YES)
3937 return MATCH_ERROR;
3938
950683ed 3939 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3940 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
1a9745d2 3941 || gfc_add_function (&entry->attr, result->name, NULL)
3942 == FAILURE)
4ee9c684 3943 return MATCH_ERROR;
c6871095 3944
3945 entry->result = result;
4ee9c684 3946 }
4ee9c684 3947 }
3948
3949 if (gfc_match_eos () != MATCH_YES)
3950 {
3951 gfc_syntax_error (ST_ENTRY);
3952 return MATCH_ERROR;
3953 }
3954
1b716045 3955 entry->attr.recursive = proc->attr.recursive;
3956 entry->attr.elemental = proc->attr.elemental;
3957 entry->attr.pure = proc->attr.pure;
4ee9c684 3958
1b716045 3959 el = gfc_get_entry_list ();
3960 el->sym = entry;
3961 el->next = gfc_current_ns->entries;
3962 gfc_current_ns->entries = el;
3963 if (el->next)
3964 el->id = el->next->id + 1;
3965 else
3966 el->id = 1;
4ee9c684 3967
1b716045 3968 new_st.op = EXEC_ENTRY;
3969 new_st.ext.entry = el;
3970
3971 return MATCH_YES;
4ee9c684 3972}
3973
3974
3975/* Match a subroutine statement, including optional prefixes. */
3976
3977match
3978gfc_match_subroutine (void)
3979{
3980 char name[GFC_MAX_SYMBOL_LEN + 1];
3981 gfc_symbol *sym;
3982 match m;
c5d33754 3983 match is_bind_c;
3984 char peek_char;
4ee9c684 3985
3986 if (gfc_current_state () != COMP_NONE
3987 && gfc_current_state () != COMP_INTERFACE
3988 && gfc_current_state () != COMP_CONTAINS)
3989 return MATCH_NO;
3990
3991 m = match_prefix (NULL);
3992 if (m != MATCH_YES)
3993 return m;
3994
3995 m = gfc_match ("subroutine% %n", name);
3996 if (m != MATCH_YES)
3997 return m;
3998
d77f260f 3999 if (get_proc_name (name, &sym, false))
4ee9c684 4000 return MATCH_ERROR;
4001 gfc_new_block = sym;
4002
c5d33754 4003 /* Check what next non-whitespace character is so we can tell if there
4004 where the required parens if we have a BIND(C). */
4005 gfc_gobble_whitespace ();
4006 peek_char = gfc_peek_char ();
4007
950683ed 4008 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4ee9c684 4009 return MATCH_ERROR;
4010
4011 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4012 return MATCH_ERROR;
4013
c5d33754 4014 /* Make sure that it isn't already declared as BIND(C). If it is, it
4015 must have been marked BIND(C) with a BIND(C) attribute and that is
4016 not allowed for procedures. */
4017 if (sym->attr.is_bind_c == 1)
4018 {
4019 sym->attr.is_bind_c = 0;
4020 if (sym->old_symbol != NULL)
4021 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4022 "variables or common blocks",
4023 &(sym->old_symbol->declared_at));
4024 else
4025 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4026 "variables or common blocks", &gfc_current_locus);
4027 }
4028
4029 /* Here, we are just checking if it has the bind(c) attribute, and if
4030 so, then we need to make sure it's all correct. If it doesn't,
4031 we still need to continue matching the rest of the subroutine line. */
4032 is_bind_c = gfc_match_bind_c (sym);
4033 if (is_bind_c == MATCH_ERROR)
4034 {
4035 /* There was an attempt at the bind(c), but it was wrong. An
4036 error message should have been printed w/in the gfc_match_bind_c
4037 so here we'll just return the MATCH_ERROR. */
4038 return MATCH_ERROR;
4039 }
4040
4041 if (is_bind_c == MATCH_YES)
4042 {
4043 if (peek_char != '(')
4044 {
4045 gfc_error ("Missing required parentheses before BIND(C) at %C");
4046 return MATCH_ERROR;
4047 }
4048 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4049 == FAILURE)
4050 return MATCH_ERROR;
4051 }
4052
4ee9c684 4053 if (gfc_match_eos () != MATCH_YES)
4054 {
4055 gfc_syntax_error (ST_SUBROUTINE);
4056 return MATCH_ERROR;
4057 }
4058
4059 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4060 return MATCH_ERROR;
4061
4062 return MATCH_YES;
4063}
4064
4065
c5d33754 4066/* Match a BIND(C) specifier, with the optional 'name=' specifier if
4067 given, and set the binding label in either the given symbol (if not
a0527218 4068 NULL), or in the current_ts. The symbol may be NULL because we may
c5d33754 4069 encounter the BIND(C) before the declaration itself. Return
4070 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4071 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4072 or MATCH_YES if the specifier was correct and the binding label and
4073 bind(c) fields were set correctly for the given symbol or the
4074 current_ts. */
4075
4076match
4077gfc_match_bind_c (gfc_symbol *sym)
4078{
4079 /* binding label, if exists */
4080 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4081 match double_quote;
4082 match single_quote;
4083 int has_name_equals = 0;
4084
4085 /* Initialize the flag that specifies whether we encountered a NAME=
4086 specifier or not. */
4087 has_name_equals = 0;
4088
4089 /* Init the first char to nil so we can catch if we don't have
4090 the label (name attr) or the symbol name yet. */
4091 binding_label[0] = '\0';
4092
4093 /* This much we have to be able to match, in this order, if
4094 there is a bind(c) label. */
4095 if (gfc_match (" bind ( c ") != MATCH_YES)
4096 return MATCH_NO;
4097
4098 /* Now see if there is a binding label, or if we've reached the
4099 end of the bind(c) attribute without one. */
4100 if (gfc_match_char (',') == MATCH_YES)
4101 {
4102 if (gfc_match (" name = ") != MATCH_YES)
4103 {
4104 gfc_error ("Syntax error in NAME= specifier for binding label "
4105 "at %C");
4106 /* should give an error message here */
4107 return MATCH_ERROR;
4108 }
4109
4110 has_name_equals = 1;
4111
4112 /* Get the opening quote. */
4113 double_quote = MATCH_YES;
4114 single_quote = MATCH_YES;
4115 double_quote = gfc_match_char ('"');
4116 if (double_quote != MATCH_YES)
4117 single_quote = gfc_match_char ('\'');
4118 if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4119 {
4120 gfc_error ("Syntax error in NAME= specifier for binding label "
4121 "at %C");
4122 return MATCH_ERROR;
4123 }
4124
4125 /* Grab the binding label, using functions that will not lower
4126 case the names automatically. */
4127 if (gfc_match_name_C (binding_label) != MATCH_YES)
4128 return MATCH_ERROR;
4129
4130 /* Get the closing quotation. */
4131 if (double_quote == MATCH_YES)
4132 {
4133 if (gfc_match_char ('"') != MATCH_YES)
4134 {
4135 gfc_error ("Missing closing quote '\"' for binding label at %C");
4136 /* User started string with '"' so looked to match it. */
4137 return MATCH_ERROR;
4138 }
4139 }
4140 else
4141 {
4142 if (gfc_match_char ('\'') != MATCH_YES)
4143 {
4144 gfc_error ("Missing closing quote '\'' for binding label at %C");
4145 /* User started string with "'" char. */
4146 return MATCH_ERROR;
4147 }
4148 }
4149 }
4150
4151 /* Get the required right paren. */
4152 if (gfc_match_char (')') != MATCH_YES)
4153 {
4154 gfc_error ("Missing closing paren for binding label at %C");
4155 return MATCH_ERROR;
4156 }
4157
4158 /* Save the binding label to the symbol. If sym is null, we're
4159 probably matching the typespec attributes of a declaration and
4160 haven't gotten the name yet, and therefore, no symbol yet. */
4161 if (binding_label[0] != '\0')
4162 {
4163 if (sym != NULL)
4164 {
4165 strncpy (sym->binding_label, binding_label,
4166 strlen (binding_label)+1);
4167 }
4168 else
4169 strncpy (curr_binding_label, binding_label,
4170 strlen (binding_label) + 1);
4171 }
4172 else
4173 {
4174 /* No binding label, but if symbol isn't null, we
4175 can set the label for it here. */
4176 /* TODO: If the name= was given and no binding label (name=""), we simply
4177 will let fortran mangle the symbol name as it usually would.
4178 However, this could still let C call it if the user looked up the
4179 symbol in the object file. Should the name set during mangling in
4180 trans-decl.c be marked with characters that are invalid for C to
4181 prevent this? */
4182 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4183 strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4184 }
94fa7146 4185
4186 if (has_name_equals && current_interface.type == INTERFACE_ABSTRACT)
4187 {
4188 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4189 return MATCH_ERROR;
4190 }
4191
c5d33754 4192 return MATCH_YES;
4193}
4194
4195
231e961a 4196/* Return nonzero if we're currently compiling a contained procedure. */
c0985832 4197
4198static int
4199contained_procedure (void)
4200{
4201 gfc_state_data *s;
4202
4203 for (s=gfc_state_stack; s; s=s->previous)
4204 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
1a9745d2 4205 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
c0985832 4206 return 1;
4207
4208 return 0;
4209}
4210
e14bee04 4211/* Set the kind of each enumerator. The kind is selected such that it is
3b6a4b41 4212 interoperable with the corresponding C enumeration type, making
4213 sure that -fshort-enums is honored. */
4214
4215static void
4216set_enum_kind(void)
4217{
4218 enumerator_history *current_history = NULL;
4219 int kind;
4220 int i;
4221
4222 if (max_enum == NULL || enum_history == NULL)
4223 return;
4224
4225 if (!gfc_option.fshort_enums)
e14bee04 4226 return;
4227
3b6a4b41 4228 i = 0;
4229 do
4230 {
4231 kind = gfc_integer_kinds[i++].kind;
4232 }
e14bee04 4233 while (kind < gfc_c_int_kind
3b6a4b41 4234 && gfc_check_integer_range (max_enum->initializer->value.integer,
4235 kind) != ARITH_OK);
4236
4237 current_history = enum_history;
4238 while (current_history != NULL)
4239 {
4240 current_history->sym->ts.kind = kind;
4241 current_history = current_history->next;
4242 }
4243}
4244
1a9745d2 4245
4ee9c684 4246/* Match any of the various end-block statements. Returns the type of
4247 END to the caller. The END INTERFACE, END IF, END DO and END
4248 SELECT statements cannot be replaced by a single END statement. */
4249
4250match
1a9745d2 4251gfc_match_end (gfc_statement *st)
4ee9c684 4252{
4253 char name[GFC_MAX_SYMBOL_LEN + 1];
4254 gfc_compile_state state;
4255 locus old_loc;
4256 const char *block_name;
4257 const char *target;
c0985832 4258 int eos_ok;
4ee9c684 4259 match m;
4260
cbb9e6aa 4261 old_loc = gfc_current_locus;
4ee9c684 4262 if (gfc_match ("end") != MATCH_YES)
4263 return MATCH_NO;
4264
4265 state = gfc_current_state ();
1a9745d2 4266 block_name = gfc_current_block () == NULL
4267 ? NULL : gfc_current_block ()->name;
4ee9c684 4268
4269 if (state == COMP_CONTAINS)
4270 {
4271 state = gfc_state_stack->previous->state;
1a9745d2 4272 block_name = gfc_state_stack->previous->sym == NULL
4273 ? NULL : gfc_state_stack->previous->sym->name;
4ee9c684 4274 }
4275
4276 switch (state)
4277 {
4278 case COMP_NONE:
4279 case COMP_PROGRAM:
4280 *st = ST_END_PROGRAM;
4281 target = " program";
c0985832 4282 eos_ok = 1;
4ee9c684 4283 break;
4284
4285 case COMP_SUBROUTINE:
4286 *st = ST_END_SUBROUTINE;
4287 target = " subroutine";
c0985832 4288 eos_ok = !contained_procedure ();
4ee9c684 4289 break;
4290
4291 case COMP_FUNCTION:
4292 *st = ST_END_FUNCTION;
4293 target = " function";
c0985832 4294 eos_ok = !contained_procedure ();
4ee9c684 4295 break;
4296
4297 case COMP_BLOCK_DATA:
4298 *st = ST_END_BLOCK_DATA;
4299 target = " block data";
c0985832 4300 eos_ok = 1;
4ee9c684 4301 break;
4302
4303 case COMP_MODULE:
4304 *st = ST_END_MODULE;
4305 target = " module";
c0985832 4306 eos_ok = 1;
4ee9c684 4307 break;
4308
4309 case COMP_INTERFACE:
4310 *st = ST_END_INTERFACE;
4311 target = " interface";
c0985832 4312 eos_ok = 0;
4ee9c684 4313 break;
4314
4315 case COMP_DERIVED:
4316 *st = ST_END_TYPE;
4317 target = " type";
c0985832 4318 eos_ok = 0;
4ee9c684 4319 break;
4320
4321 case COMP_IF:
4322 *st = ST_ENDIF;
4323 target = " if";
c0985832 4324 eos_ok = 0;
4ee9c684 4325 break;
4326
4327 case COMP_DO:
4328 *st = ST_ENDDO;
4329 target = " do";
c0985832 4330 eos_ok = 0;
4ee9c684 4331 break;
4332
4333 case COMP_SELECT:
4334 *st = ST_END_SELECT;
4335 target = " select";
c0985832 4336 eos_ok = 0;
4ee9c684 4337 break;
4338
4339 case COMP_FORALL:
4340 *st = ST_END_FORALL;
4341 target = " forall";
c0985832 4342 eos_ok = 0;
4ee9c684 4343 break;
4344
4345 case COMP_WHERE:
4346 *st = ST_END_WHERE;
4347 target = " where";
c0985832 4348 eos_ok = 0;
4ee9c684 4349 break;
4350
3b6a4b41 4351 case COMP_ENUM:
4352 *st = ST_END_ENUM;
4353 target = " enum";
4354 eos_ok = 0;
4355 last_initializer = NULL;
4356 set_enum_kind ();
4357 gfc_free_enum_history ();
4358 break;
4359
4ee9c684 4360 default:
4361 gfc_error ("Unexpected END statement at %C");
4362 goto cleanup;
4363 }
4364
4365 if (gfc_match_eos () == MATCH_YES)
4366 {
c0985832 4367 if (!eos_ok)
4ee9c684 4368 {
f6d0e37a 4369 /* We would have required END [something]. */
d197c9ee 4370 gfc_error ("%s statement expected at %L",
4371 gfc_ascii_statement (*st), &old_loc);
4ee9c684 4372 goto cleanup;
4373 }
4374
4375 return MATCH_YES;
4376 }
4377
4378 /* Verify that we've got the sort of end-block that we're expecting. */
4379 if (gfc_match (target) != MATCH_YES)
4380 {
4381 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
4382 goto cleanup;
4383 }
4384
4385 /* If we're at the end, make sure a block name wasn't required. */
4386 if (gfc_match_eos () == MATCH_YES)
4387 {
4388
0d0ce415 4389 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
4390 && *st != ST_END_FORALL && *st != ST_END_WHERE)
4ee9c684 4391 return MATCH_YES;
4392
4393 if (gfc_current_block () == NULL)
4394 return MATCH_YES;
4395
4396 gfc_error ("Expected block name of '%s' in %s statement at %C",
4397 block_name, gfc_ascii_statement (*st));
4398
4399 return MATCH_ERROR;
4400 }
4401
4402 /* END INTERFACE has a special handler for its several possible endings. */
4403 if (*st == ST_END_INTERFACE)
4404 return gfc_match_end_interface ();
4405
f6d0e37a 4406 /* We haven't hit the end of statement, so what is left must be an
4407 end-name. */
4ee9c684 4408 m = gfc_match_space ();
4409 if (m == MATCH_YES)
4410 m = gfc_match_name (name);
4411
4412 if (m == MATCH_NO)
4413 gfc_error ("Expected terminating name at %C");
4414 if (m != MATCH_YES)
4415 goto cleanup;
4416
4417 if (block_name == NULL)
4418 goto syntax;
4419
4420 if (strcmp (name, block_name) != 0)
4421 {
4422 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
4423 gfc_ascii_statement (*st));
4424 goto cleanup;
4425 }
4426
4427 if (gfc_match_eos () == MATCH_YES)
4428 return MATCH_YES;
4429
4430syntax:
4431 gfc_syntax_error (*st);
4432
4433cleanup:
cbb9e6aa 4434 gfc_current_locus = old_loc;
4ee9c684 4435 return MATCH_ERROR;
4436}
4437
4438
4439
4440/***************** Attribute declaration statements ****************/
4441
4442/* Set the attribute of a single variable. */
4443
4444static match
4445attr_decl1 (void)
4446{
4447 char name[GFC_MAX_SYMBOL_LEN + 1];
4448 gfc_array_spec *as;
4449 gfc_symbol *sym;
4450 locus var_locus;
4451 match m;
4452
4453 as = NULL;
4454
4455 m = gfc_match_name (name);
4456 if (m != MATCH_YES)
4457 goto cleanup;
4458
4459 if (find_special (name, &sym))
4460 return MATCH_ERROR;
4461
cbb9e6aa 4462 var_locus = gfc_current_locus;
4ee9c684 4463
4464 /* Deal with possible array specification for certain attributes. */
4465 if (current_attr.dimension
4466 || current_attr.allocatable
4467 || current_attr.pointer
4468 || current_attr.target)
4469 {
4470 m = gfc_match_array_spec (&as);
4471 if (m == MATCH_ERROR)
4472 goto cleanup;
4473
4474 if (current_attr.dimension && m == MATCH_NO)
4475 {
1a9745d2 4476 gfc_error ("Missing array specification at %L in DIMENSION "
4477 "statement", &var_locus);
4ee9c684 4478 m = MATCH_ERROR;
4479 goto cleanup;
4480 }
4481
4482 if ((current_attr.allocatable || current_attr.pointer)
4483 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
4484 {
1a9745d2 4485 gfc_error ("Array specification must be deferred at %L", &var_locus);
4ee9c684 4486 m = MATCH_ERROR;
4487 goto cleanup;
4488 }
4489 }
4490
1a9745d2 4491 /* Update symbol table. DIMENSION attribute is set
4492 in gfc_set_array_spec(). */
4ee9c684 4493 if (current_attr.dimension == 0
4494 && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
4495 {
4496 m = MATCH_ERROR;
4497 goto cleanup;
4498 }
4499
4500 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
4501 {
4502 m = MATCH_ERROR;
4503 goto cleanup;
4504 }
e14bee04 4505
b549d2a5 4506 if (sym->attr.cray_pointee && sym->as != NULL)
4507 {
4508 /* Fix the array spec. */
4509 m = gfc_mod_pointee_as (sym->as);
4510 if (m == MATCH_ERROR)
4511 goto cleanup;
4512 }
4ee9c684 4513
25dd7350 4514 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
14efb9b7 4515 {
4516 m = MATCH_ERROR;
4517 goto cleanup;
4518 }
4519
4ee9c684 4520 if ((current_attr.external || current_attr.intrinsic)
4521 && sym->attr.flavor != FL_PROCEDURE
950683ed 4522 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
4ee9c684 4523 {
4524 m = MATCH_ERROR;
4525 goto cleanup;
4526 }
4527
4528 return MATCH_YES;
4529
4530cleanup:
4531 gfc_free_array_spec (as);
4532 return m;
4533}
4534
4535
4536/* Generic attribute declaration subroutine. Used for attributes that
4537 just have a list of names. */
4538
4539static match
4540attr_decl (void)
4541{
4542 match m;
4543
4544 /* Gobble the optional double colon, by simply ignoring the result
4545 of gfc_match(). */
4546 gfc_match (" ::");
4547
4548 for (;;)
4549 {
4550 m = attr_decl1 ();
4551 if (m != MATCH_YES)
4552 break;
4553
4554 if (gfc_match_eos () == MATCH_YES)
4555 {
4556 m = MATCH_YES;
4557 break;
4558 }
4559
4560 if (gfc_match_char (',') != MATCH_YES)
4561 {
4562 gfc_error ("Unexpected character in variable list at %C");
4563 m = MATCH_ERROR;
4564 break;
4565 }
4566 }
4567
4568 return m;
4569}
4570
4571
b549d2a5 4572/* This routine matches Cray Pointer declarations of the form:
4573 pointer ( <pointer>, <pointee> )
4574 or
e14bee04 4575 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
4576 The pointer, if already declared, should be an integer. Otherwise, we
b549d2a5 4577 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
4578 be either a scalar, or an array declaration. No space is allocated for
e14bee04 4579 the pointee. For the statement
b549d2a5 4580 pointer (ipt, ar(10))
4581 any subsequent uses of ar will be translated (in C-notation) as
e14bee04 4582 ar(i) => ((<type> *) ipt)(i)
b7bf3f81 4583 After gimplification, pointee variable will disappear in the code. */
b549d2a5 4584
4585static match
4586cray_pointer_decl (void)
4587{
4588 match m;
4589 gfc_array_spec *as;
4590 gfc_symbol *cptr; /* Pointer symbol. */
4591 gfc_symbol *cpte; /* Pointee symbol. */
4592 locus var_locus;
4593 bool done = false;
4594
4595 while (!done)
4596 {
4597 if (gfc_match_char ('(') != MATCH_YES)
4598 {
4599 gfc_error ("Expected '(' at %C");
e14bee04 4600 return MATCH_ERROR;
b549d2a5 4601 }
e14bee04 4602
b549d2a5 4603 /* Match pointer. */
4604 var_locus = gfc_current_locus;
4605 gfc_clear_attr (&current_attr);
4606 gfc_add_cray_pointer (&current_attr, &var_locus);
4607 current_ts.type = BT_INTEGER;
4608 current_ts.kind = gfc_index_integer_kind;
4609
e14bee04 4610 m = gfc_match_symbol (&cptr, 0);
b549d2a5 4611 if (m != MATCH_YES)
4612 {
4613 gfc_error ("Expected variable name at %C");
4614 return m;
4615 }
e14bee04 4616
b549d2a5 4617 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
4618 return MATCH_ERROR;
4619
e14bee04 4620 gfc_set_sym_referenced (cptr);
b549d2a5 4621
4622 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
4623 {
4624 cptr->ts.type = BT_INTEGER;
e14bee04 4625 cptr->ts.kind = gfc_index_integer_kind;
b549d2a5 4626 }
4627 else if (cptr->ts.type != BT_INTEGER)
4628 {
7698a624 4629 gfc_error ("Cray pointer at %C must be an integer");
b549d2a5 4630 return MATCH_ERROR;
4631 }
4632 else if (cptr->ts.kind < gfc_index_integer_kind)
4633 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
7698a624 4634 " memory addresses require %d bytes",
1a9745d2 4635 cptr->ts.kind, gfc_index_integer_kind);
b549d2a5 4636
4637 if (gfc_match_char (',') != MATCH_YES)
4638 {
4639 gfc_error ("Expected \",\" at %C");
e14bee04 4640 return MATCH_ERROR;
b549d2a5 4641 }
4642
e14bee04 4643 /* Match Pointee. */
b549d2a5 4644 var_locus = gfc_current_locus;
4645 gfc_clear_attr (&current_attr);
4646 gfc_add_cray_pointee (&current_attr, &var_locus);
4647 current_ts.type = BT_UNKNOWN;
4648 current_ts.kind = 0;
4649
4650 m = gfc_match_symbol (&cpte, 0);
4651 if (m != MATCH_YES)
4652 {
4653 gfc_error ("Expected variable name at %C");
4654 return m;
4655 }
e14bee04 4656
b549d2a5 4657 /* Check for an optional array spec. */
4658 m = gfc_match_array_spec (&as);
4659 if (m == MATCH_ERROR)
4660 {
4661 gfc_free_array_spec (as);
4662 return m;
4663 }
4664 else if (m == MATCH_NO)
4665 {
4666 gfc_free_array_spec (as);
4667 as = NULL;
4668 }
4669
4670 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
4671 return MATCH_ERROR;
4672
4673 gfc_set_sym_referenced (cpte);
4674
4675 if (cpte->as == NULL)
4676 {
4677 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
4678 gfc_internal_error ("Couldn't set Cray pointee array spec.");
4679 }
4680 else if (as != NULL)
4681 {
7698a624 4682 gfc_error ("Duplicate array spec for Cray pointee at %C");
b549d2a5 4683 gfc_free_array_spec (as);
4684 return MATCH_ERROR;
4685 }
4686
4687 as = NULL;
4688
4689 if (cpte->as != NULL)
4690 {
4691 /* Fix array spec. */
4692 m = gfc_mod_pointee_as (cpte->as);
4693 if (m == MATCH_ERROR)
4694 return m;
4695 }
4696
4697 /* Point the Pointee at the Pointer. */
b7bf3f81 4698 cpte->cp_pointer = cptr;
b549d2a5 4699
4700 if (gfc_match_char (')') != MATCH_YES)
4701 {
4702 gfc_error ("Expected \")\" at %C");
4703 return MATCH_ERROR;
4704 }
4705 m = gfc_match_char (',');
4706 if (m != MATCH_YES)
4707 done = true; /* Stop searching for more declarations. */
4708
4709 }
4710
4711 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
4712 || gfc_match_eos () != MATCH_YES)
4713 {
4714 gfc_error ("Expected \",\" or end of statement at %C");
4715 return MATCH_ERROR;
4716 }
4717 return MATCH_YES;
4718}
4719
4720
4ee9c684 4721match
4722gfc_match_external (void)
4723{
4724
4725 gfc_clear_attr (&current_attr);
14efb9b7 4726 current_attr.external = 1;
4ee9c684 4727
4728 return attr_decl ();
4729}
4730
4731
4ee9c684 4732match
4733gfc_match_intent (void)
4734{
4735 sym_intent intent;
4736
4737 intent = match_intent_spec ();
4738 if (intent == INTENT_UNKNOWN)
4739 return MATCH_ERROR;
4740
4741 gfc_clear_attr (&current_attr);
14efb9b7 4742 current_attr.intent = intent;
4ee9c684 4743
4744 return attr_decl ();
4745}
4746
4747
4748match
4749gfc_match_intrinsic (void)
4750{
4751
4752 gfc_clear_attr (&current_attr);
14efb9b7 4753 current_attr.intrinsic = 1;
4ee9c684 4754
4755 return attr_decl ();
4756}
4757
4758
4759match
4760gfc_match_optional (void)
4761{
4762
4763 gfc_clear_attr (&current_attr);
14efb9b7 4764 current_attr.optional = 1;
4ee9c684 4765
4766 return attr_decl ();
4767}
4768
4769
4770match
4771gfc_match_pointer (void)
4772{
b549d2a5 4773 gfc_gobble_whitespace ();
4774 if (gfc_peek_char () == '(')
4775 {
4776 if (!gfc_option.flag_cray_pointer)
4777 {
1a9745d2 4778 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
4779 "flag");
b549d2a5 4780 return MATCH_ERROR;
4781 }
4782 return cray_pointer_decl ();
4783 }
4784 else
4785 {
4786 gfc_clear_attr (&current_attr);
14efb9b7 4787 current_attr.pointer = 1;
b549d2a5 4788
4789 return attr_decl ();
4790 }
4ee9c684 4791}
4792
4793
4794match
4795gfc_match_allocatable (void)
4796{
4ee9c684 4797 gfc_clear_attr (&current_attr);
14efb9b7 4798 current_attr.allocatable = 1;
4ee9c684 4799
4800 return attr_decl ();
4801}
4802
4803
4804match
4805gfc_match_dimension (void)
4806{
4ee9c684 4807 gfc_clear_attr (&current_attr);
14efb9b7 4808 current_attr.dimension = 1;
4ee9c684 4809
4810 return attr_decl ();
4811}
4812
4813
4814match
4815gfc_match_target (void)
4816{
4ee9c684 4817 gfc_clear_attr (&current_attr);
14efb9b7 4818 current_attr.target = 1;
4ee9c684 4819
4820 return attr_decl ();
4821}
4822
4823
4824/* Match the list of entities being specified in a PUBLIC or PRIVATE
4825 statement. */
4826
4827static match
4828access_attr_decl (gfc_statement st)
4829{
4830 char name[GFC_MAX_SYMBOL_LEN + 1];
4831 interface_type type;
4832 gfc_user_op *uop;
4833 gfc_symbol *sym;
4834 gfc_intrinsic_op operator;
4835 match m;
4836
4837 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4838 goto done;
4839
4840 for (;;)
4841 {
4842 m = gfc_match_generic_spec (&type, name, &operator);
4843 if (m == MATCH_NO)
4844 goto syntax;
4845 if (m == MATCH_ERROR)
4846 return MATCH_ERROR;
4847
4848 switch (type)
4849 {
4850 case INTERFACE_NAMELESS:
94fa7146 4851 case INTERFACE_ABSTRACT:
4ee9c684 4852 goto syntax;
4853
4854 case INTERFACE_GENERIC:
4855 if (gfc_get_symbol (name, NULL, &sym))
4856 goto done;
4857
1a9745d2 4858 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
4859 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
950683ed 4860 sym->name, NULL) == FAILURE)
4ee9c684 4861 return MATCH_ERROR;
4862
4863 break;
4864
4865 case INTERFACE_INTRINSIC_OP:
4866 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
4867 {
4868 gfc_current_ns->operator_access[operator] =
4869 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
4870 }
4871 else
4872 {
4873 gfc_error ("Access specification of the %s operator at %C has "
4874 "already been specified", gfc_op2string (operator));
4875 goto done;
4876 }
4877
4878 break;
4879
4880 case INTERFACE_USER_OP:
4881 uop = gfc_get_uop (name);
4882
4883 if (uop->access == ACCESS_UNKNOWN)
4884 {
1a9745d2 4885 uop->access = (st == ST_PUBLIC)
4886 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
4ee9c684 4887 }
4888 else
4889 {
1a9745d2 4890 gfc_error ("Access specification of the .%s. operator at %C "
4891 "has already been specified", sym->name);
4ee9c684 4892 goto done;
4893 }
4894
4895 break;
4896 }
4897
4898 if (gfc_match_char (',') == MATCH_NO)
4899 break;
4900 }
4901
4902 if (gfc_match_eos () != MATCH_YES)
4903 goto syntax;
4904 return MATCH_YES;
4905
4906syntax:
4907 gfc_syntax_error (st);
4908
4909done:
4910 return MATCH_ERROR;
4911}
4912
4913
3ea52af3 4914match
4915gfc_match_protected (void)
4916{
4917 gfc_symbol *sym;
4918 match m;
4919
4920 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4921 {
4922 gfc_error ("PROTECTED at %C only allowed in specification "
4923 "part of a module");
4924 return MATCH_ERROR;
4925
4926 }
4927
1a9745d2 4928 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
3ea52af3 4929 == FAILURE)
4930 return MATCH_ERROR;
4931
4932 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4933 {
4934 return MATCH_ERROR;
4935 }
4936
4937 if (gfc_match_eos () == MATCH_YES)
4938 goto syntax;
4939
4940 for(;;)
4941 {
4942 m = gfc_match_symbol (&sym, 0);
4943 switch (m)
4944 {
4945 case MATCH_YES:
1a9745d2 4946 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
4947 == FAILURE)
3ea52af3 4948 return MATCH_ERROR;
4949 goto next_item;
4950
4951 case MATCH_NO:
4952 break;
4953
4954 case MATCH_ERROR:
4955 return MATCH_ERROR;
4956 }
4957
4958 next_item:
4959 if (gfc_match_eos () == MATCH_YES)
4960 break;
4961 if (gfc_match_char (',') != MATCH_YES)
4962 goto syntax;
4963 }
4964
4965 return MATCH_YES;
4966
4967syntax:
4968 gfc_error ("Syntax error in PROTECTED statement at %C");
4969 return MATCH_ERROR;
4970}
4971
4972
a0527218 4973/* The PRIVATE statement is a bit weird in that it can be an attribute
4ee9c684 4974 declaration, but also works as a standlone statement inside of a
4975 type declaration or a module. */
4976
4977match
1a9745d2 4978gfc_match_private (gfc_statement *st)
4ee9c684 4979{
4980
4981 if (gfc_match ("private") != MATCH_YES)
4982 return MATCH_NO;
4983
e14bee04 4984 if (gfc_current_state () != COMP_MODULE
4985 && (gfc_current_state () != COMP_DERIVED
4986 || !gfc_state_stack->previous
4987 || gfc_state_stack->previous->state != COMP_MODULE))
4988 {
4989 gfc_error ("PRIVATE statement at %C is only allowed in the "
4990 "specification part of a module");
4991 return MATCH_ERROR;
4992 }
4993
4ee9c684 4994 if (gfc_current_state () == COMP_DERIVED)
4995 {
4996 if (gfc_match_eos () == MATCH_YES)
4997 {
4998 *st = ST_PRIVATE;
4999 return MATCH_YES;
5000 }
5001
5002 gfc_syntax_error (ST_PRIVATE);
5003 return MATCH_ERROR;
5004 }
5005
5006 if (gfc_match_eos () == MATCH_YES)
5007 {
5008 *st = ST_PRIVATE;
5009 return MATCH_YES;
5010 }
5011
5012 *st = ST_ATTR_DECL;
5013 return access_attr_decl (ST_PRIVATE);
5014}
5015
5016
5017match
1a9745d2 5018gfc_match_public (gfc_statement *st)
4ee9c684 5019{
5020
5021 if (gfc_match ("public") != MATCH_YES)
5022 return MATCH_NO;
5023
e14bee04 5024 if (gfc_current_state () != COMP_MODULE)
5025 {
5026 gfc_error ("PUBLIC statement at %C is only allowed in the "
5027 "specification part of a module");
5028 return MATCH_ERROR;
5029 }
5030
4ee9c684 5031 if (gfc_match_eos () == MATCH_YES)
5032 {
5033 *st = ST_PUBLIC;
5034 return MATCH_YES;
5035 }
5036
5037 *st = ST_ATTR_DECL;
5038 return access_attr_decl (ST_PUBLIC);
5039}
5040
5041
5042/* Workhorse for gfc_match_parameter. */
5043
5044static match
5045do_parm (void)
5046{
5047 gfc_symbol *sym;
5048 gfc_expr *init;
5049 match m;
5050
5051 m = gfc_match_symbol (&sym, 0);
5052 if (m == MATCH_NO)
5053 gfc_error ("Expected variable name at %C in PARAMETER statement");
5054
5055 if (m != MATCH_YES)
5056 return m;
5057
5058 if (gfc_match_char ('=') == MATCH_NO)
5059 {
5060 gfc_error ("Expected = sign in PARAMETER statement at %C");
5061 return MATCH_ERROR;
5062 }
5063
5064 m = gfc_match_init_expr (&init);
5065 if (m == MATCH_NO)
5066 gfc_error ("Expected expression at %C in PARAMETER statement");
5067 if (m != MATCH_YES)
5068 return m;
5069
5070 if (sym->ts.type == BT_UNKNOWN
5071 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5072 {
5073 m = MATCH_ERROR;
5074 goto cleanup;
5075 }
5076
5077 if (gfc_check_assign_symbol (sym, init) == FAILURE
950683ed 5078 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
4ee9c684 5079 {
5080 m = MATCH_ERROR;
5081 goto cleanup;
5082 }
5083
c1b6da4a 5084 if (sym->ts.type == BT_CHARACTER
5085 && sym->ts.cl != NULL
5086 && sym->ts.cl->length != NULL
5087 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5088 && init->expr_type == EXPR_CONSTANT
5089 && init->ts.type == BT_CHARACTER
5090 && init->ts.kind == 1)
5091 gfc_set_constant_character_len (
1bfea7e8 5092 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
c1b6da4a 5093
4ee9c684 5094 sym->value = init;
5095 return MATCH_YES;
5096
5097cleanup:
5098 gfc_free_expr (init);
5099 return m;
5100}
5101
5102
5103/* Match a parameter statement, with the weird syntax that these have. */
5104
5105match
5106gfc_match_parameter (void)
5107{
5108 match m;
5109
5110 if (gfc_match_char ('(') == MATCH_NO)
5111 return MATCH_NO;
5112
5113 for (;;)
5114 {
5115 m = do_parm ();
5116 if (m != MATCH_YES)
5117 break;
5118
5119 if (gfc_match (" )%t") == MATCH_YES)
5120 break;
5121
5122 if (gfc_match_char (',') != MATCH_YES)
5123 {
5124 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5125 m = MATCH_ERROR;
5126 break;
5127 }
5128 }
5129
5130 return m;
5131}
5132
5133
5134/* Save statements have a special syntax. */
5135
5136match
5137gfc_match_save (void)
5138{
82f5ee13 5139 char n[GFC_MAX_SYMBOL_LEN+1];
5140 gfc_common_head *c;
4ee9c684 5141 gfc_symbol *sym;
5142 match m;
5143
5144 if (gfc_match_eos () == MATCH_YES)
5145 {
5146 if (gfc_current_ns->seen_save)
5147 {
1a9745d2 5148 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5149 "follows previous SAVE statement")
76e82f95 5150 == FAILURE)
5151 return MATCH_ERROR;
4ee9c684 5152 }
5153
5154 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5155 return MATCH_YES;
5156 }
5157
5158 if (gfc_current_ns->save_all)
5159 {
1a9745d2 5160 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5161 "blanket SAVE statement")
76e82f95 5162 == FAILURE)
5163 return MATCH_ERROR;
4ee9c684 5164 }
5165
5166 gfc_match (" ::");
5167
5168 for (;;)
5169 {
5170 m = gfc_match_symbol (&sym, 0);
5171 switch (m)
5172 {
5173 case MATCH_YES:
1a9745d2 5174 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
5175 == FAILURE)
4ee9c684 5176 return MATCH_ERROR;
5177 goto next_item;
5178
5179 case MATCH_NO:
5180 break;
5181
5182 case MATCH_ERROR:
5183 return MATCH_ERROR;
5184 }
5185
82f5ee13 5186 m = gfc_match (" / %n /", &n);
4ee9c684 5187 if (m == MATCH_ERROR)
5188 return MATCH_ERROR;
5189 if (m == MATCH_NO)
5190 goto syntax;
5191
403ddc45 5192 c = gfc_get_common (n, 0);
82f5ee13 5193 c->saved = 1;
5194
4ee9c684 5195 gfc_current_ns->seen_save = 1;
5196
5197 next_item:
5198 if (gfc_match_eos () == MATCH_YES)
5199 break;
5200 if (gfc_match_char (',') != MATCH_YES)
5201 goto syntax;
5202 }
5203
5204 return MATCH_YES;
5205
5206syntax:
5207 gfc_error ("Syntax error in SAVE statement at %C");
5208 return MATCH_ERROR;
5209}
5210
5211
8f6339b6 5212match
5213gfc_match_value (void)
5214{
5215 gfc_symbol *sym;
5216 match m;
5217
1a9745d2 5218 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
8f6339b6 5219 == FAILURE)
5220 return MATCH_ERROR;
5221
5222 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5223 {
5224 return MATCH_ERROR;
5225 }
5226
5227 if (gfc_match_eos () == MATCH_YES)
5228 goto syntax;
5229
5230 for(;;)
5231 {
5232 m = gfc_match_symbol (&sym, 0);
5233 switch (m)
5234 {
5235 case MATCH_YES:
1a9745d2 5236 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
5237 == FAILURE)
8f6339b6 5238 return MATCH_ERROR;
5239 goto next_item;
5240
5241 case MATCH_NO:
5242 break;
5243
5244 case MATCH_ERROR:
5245 return MATCH_ERROR;
5246 }
5247
5248 next_item:
5249 if (gfc_match_eos () == MATCH_YES)
5250 break;
5251 if (gfc_match_char (',') != MATCH_YES)
5252 goto syntax;
5253 }
5254
5255 return MATCH_YES;
5256
5257syntax:
5258 gfc_error ("Syntax error in VALUE statement at %C");
5259 return MATCH_ERROR;
5260}
5261
f6d0e37a 5262
ef814c81 5263match
5264gfc_match_volatile (void)
5265{
5266 gfc_symbol *sym;
5267 match m;
5268
1a9745d2 5269 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
ef814c81 5270 == FAILURE)
5271 return MATCH_ERROR;
5272
5273 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5274 {
5275 return MATCH_ERROR;
5276 }
5277
5278 if (gfc_match_eos () == MATCH_YES)
5279 goto syntax;
5280
5281 for(;;)
5282 {
2f241857 5283 /* VOLATILE is special because it can be added to host-associated
5284 symbols locally. */
5285 m = gfc_match_symbol (&sym, 1);
ef814c81 5286 switch (m)
5287 {
5288 case MATCH_YES:
1a9745d2 5289 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
5290 == FAILURE)
ef814c81 5291 return MATCH_ERROR;
5292 goto next_item;
5293
5294 case MATCH_NO:
5295 break;
5296
5297 case MATCH_ERROR:
5298 return MATCH_ERROR;
5299 }
5300
5301 next_item:
5302 if (gfc_match_eos () == MATCH_YES)
5303 break;
5304 if (gfc_match_char (',') != MATCH_YES)
5305 goto syntax;
5306 }
5307
5308 return MATCH_YES;
5309
5310syntax:
5311 gfc_error ("Syntax error in VOLATILE statement at %C");
5312 return MATCH_ERROR;
5313}
5314
5315
4ee9c684 5316/* Match a module procedure statement. Note that we have to modify
5317 symbols in the parent's namespace because the current one was there
89d91d02 5318 to receive symbols that are in an interface's formal argument list. */
4ee9c684 5319
5320match
5321gfc_match_modproc (void)
5322{
5323 char name[GFC_MAX_SYMBOL_LEN + 1];
5324 gfc_symbol *sym;
5325 match m;
63d42079 5326 gfc_namespace *module_ns;
4ee9c684 5327
5328 if (gfc_state_stack->state != COMP_INTERFACE
5329 || gfc_state_stack->previous == NULL
5330 || current_interface.type == INTERFACE_NAMELESS)
5331 {
1a9745d2 5332 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5333 "interface");
4ee9c684 5334 return MATCH_ERROR;
5335 }
5336
63d42079 5337 module_ns = gfc_current_ns->parent;
5338 for (; module_ns; module_ns = module_ns->parent)
5339 if (module_ns->proc_name->attr.flavor == FL_MODULE)
5340 break;
5341
5342 if (module_ns == NULL)
5343 return MATCH_ERROR;
5344
4ee9c684 5345 for (;;)
5346 {
5347 m = gfc_match_name (name);
5348 if (m == MATCH_NO)
5349 goto syntax;
5350 if (m != MATCH_YES)
5351 return MATCH_ERROR;
5352
63d42079 5353 if (gfc_get_symbol (name, module_ns, &sym))
4ee9c684 5354 return MATCH_ERROR;
5355
5356 if (sym->attr.proc != PROC_MODULE
950683ed 5357 && gfc_add_procedure (&sym->attr, PROC_MODULE,
5358 sym->name, NULL) == FAILURE)
4ee9c684 5359 return MATCH_ERROR;
5360
5361 if (gfc_add_interface (sym) == FAILURE)
5362 return MATCH_ERROR;
5363
3186f695 5364 sym->attr.mod_proc = 1;
5365
4ee9c684 5366 if (gfc_match_eos () == MATCH_YES)
5367 break;
5368 if (gfc_match_char (',') != MATCH_YES)
5369 goto syntax;
5370 }
5371
5372 return MATCH_YES;
5373
5374syntax:
5375 gfc_syntax_error (ST_MODULE_PROC);
5376 return MATCH_ERROR;
5377}
5378
5379
c5d33754 5380/* Match the optional attribute specifiers for a type declaration.
5381 Return MATCH_ERROR if an error is encountered in one of the handled
5382 attributes (public, private, bind(c)), MATCH_NO if what's found is
5383 not a handled attribute, and MATCH_YES otherwise. TODO: More error
5384 checking on attribute conflicts needs to be done. */
4ee9c684 5385
5386match
c5d33754 5387gfc_get_type_attr_spec (symbol_attribute *attr)
4ee9c684 5388{
c5d33754 5389 /* See if the derived type is marked as private. */
4ee9c684 5390 if (gfc_match (" , private") == MATCH_YES)
5391 {
e14bee04 5392 if (gfc_current_state () != COMP_MODULE)
4ee9c684 5393 {
e14bee04 5394 gfc_error ("Derived type at %C can only be PRIVATE in the "
5395 "specification part of a module");
4ee9c684 5396 return MATCH_ERROR;
5397 }
5398
c5d33754 5399 if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4ee9c684 5400 return MATCH_ERROR;
4ee9c684 5401 }
c5d33754 5402 else if (gfc_match (" , public") == MATCH_YES)
4ee9c684 5403 {
e14bee04 5404 if (gfc_current_state () != COMP_MODULE)
4ee9c684 5405 {
e14bee04 5406 gfc_error ("Derived type at %C can only be PUBLIC in the "
5407 "specification part of a module");
4ee9c684 5408 return MATCH_ERROR;
5409 }
5410
c5d33754 5411 if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4ee9c684 5412 return MATCH_ERROR;
4ee9c684 5413 }
33e86520 5414 else if (gfc_match(" , bind ( c )") == MATCH_YES)
c5d33754 5415 {
5416 /* If the type is defined to be bind(c) it then needs to make
5417 sure that all fields are interoperable. This will
5418 need to be a semantic check on the finished derived type.
5419 See 15.2.3 (lines 9-12) of F2003 draft. */
5420 if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
5421 return MATCH_ERROR;
5422
5423 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
5424 }
5425 else
5426 return MATCH_NO;
5427
5428 /* If we get here, something matched. */
5429 return MATCH_YES;
5430}
5431
5432
5433/* Match the beginning of a derived type declaration. If a type name
5434 was the result of a function, then it is possible to have a symbol
5435 already to be known as a derived type yet have no components. */
5436
5437match
5438gfc_match_derived_decl (void)
5439{
5440 char name[GFC_MAX_SYMBOL_LEN + 1];
5441 symbol_attribute attr;
5442 gfc_symbol *sym;
5443 match m;
5444 match is_type_attr_spec = MATCH_NO;
33e86520 5445 bool seen_attr = false;
c5d33754 5446
5447 if (gfc_current_state () == COMP_DERIVED)
5448 return MATCH_NO;
5449
5450 gfc_clear_attr (&attr);
5451
5452 do
5453 {
5454 is_type_attr_spec = gfc_get_type_attr_spec (&attr);
5455 if (is_type_attr_spec == MATCH_ERROR)
5456 return MATCH_ERROR;
33e86520 5457 if (is_type_attr_spec == MATCH_YES)
5458 seen_attr = true;
c5d33754 5459 } while (is_type_attr_spec == MATCH_YES);
4ee9c684 5460
33e86520 5461 if (gfc_match (" ::") != MATCH_YES && seen_attr)
4ee9c684 5462 {
5463 gfc_error ("Expected :: in TYPE definition at %C");
5464 return MATCH_ERROR;
5465 }
5466
5467 m = gfc_match (" %n%t", name);
5468 if (m != MATCH_YES)
5469 return m;
5470
a3055431 5471 /* Make sure the name is not the name of an intrinsic type. */
5472 if (gfc_is_intrinsic_typename (name))
4ee9c684 5473 {
1a9745d2 5474 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5475 "type", name);
4ee9c684 5476 return MATCH_ERROR;
5477 }
5478
5479 if (gfc_get_symbol (name, NULL, &sym))
5480 return MATCH_ERROR;
5481
5482 if (sym->ts.type != BT_UNKNOWN)
5483 {
5484 gfc_error ("Derived type name '%s' at %C already has a basic type "
5485 "of %s", sym->name, gfc_typename (&sym->ts));
5486 return MATCH_ERROR;
5487 }
5488
5489 /* The symbol may already have the derived attribute without the
5490 components. The ways this can happen is via a function
5491 definition, an INTRINSIC statement or a subtype in another
5492 derived type that is a pointer. The first part of the AND clause
b14e2757 5493 is true if a the symbol is not the return value of a function. */
4ee9c684 5494 if (sym->attr.flavor != FL_DERIVED
950683ed 5495 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4ee9c684 5496 return MATCH_ERROR;
5497
5498 if (sym->components != NULL)
5499 {
1a9745d2 5500 gfc_error ("Derived type definition of '%s' at %C has already been "
5501 "defined", sym->name);
4ee9c684 5502 return MATCH_ERROR;
5503 }
5504
5505 if (attr.access != ACCESS_UNKNOWN
950683ed 5506 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4ee9c684 5507 return MATCH_ERROR;
5508
c5d33754 5509 /* See if the derived type was labeled as bind(c). */
5510 if (attr.is_bind_c != 0)
5511 sym->attr.is_bind_c = attr.is_bind_c;
5512
4ee9c684 5513 gfc_new_block = sym;
5514
5515 return MATCH_YES;
5516}
b549d2a5 5517
5518
5519/* Cray Pointees can be declared as:
5520 pointer (ipt, a (n,m,...,*))
5521 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
5522 cheat and set a constant bound of 1 for the last dimension, if this
5523 is the case. Since there is no bounds-checking for Cray Pointees,
5524 this will be okay. */
5525
5526try
5527gfc_mod_pointee_as (gfc_array_spec *as)
5528{
5529 as->cray_pointee = true; /* This will be useful to know later. */
5530 if (as->type == AS_ASSUMED_SIZE)
5531 {
5532 as->type = AS_EXPLICIT;
5533 as->upper[as->rank - 1] = gfc_int_expr (1);
5534 as->cp_was_assumed = true;
5535 }
5536 else if (as->type == AS_ASSUMED_SHAPE)
5537 {
5538 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
5539 return MATCH_ERROR;
5540 }
5541 return MATCH_YES;
5542}
3b6a4b41 5543
5544
5545/* Match the enum definition statement, here we are trying to match
5546 the first line of enum definition statement.
5547 Returns MATCH_YES if match is found. */
5548
5549match
5550gfc_match_enum (void)
5551{
5552 match m;
5553
5554 m = gfc_match_eos ();
5555 if (m != MATCH_YES)
5556 return m;
5557
60fbbf9e 5558 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
3b6a4b41 5559 == FAILURE)
5560 return MATCH_ERROR;
5561
5562 return MATCH_YES;
5563}
5564
5565
60fbbf9e 5566/* Match a variable name with an optional initializer. When this
5567 subroutine is called, a variable is expected to be parsed next.
5568 Depending on what is happening at the moment, updates either the
5569 symbol table or the current interface. */
5570
5571static match
5572enumerator_decl (void)
5573{
5574 char name[GFC_MAX_SYMBOL_LEN + 1];
5575 gfc_expr *initializer;
5576 gfc_array_spec *as = NULL;
5577 gfc_symbol *sym;
5578 locus var_locus;
5579 match m;
5580 try t;
5581 locus old_locus;
5582
5583 initializer = NULL;
5584 old_locus = gfc_current_locus;
5585
5586 /* When we get here, we've just matched a list of attributes and
5587 maybe a type and a double colon. The next thing we expect to see
5588 is the name of the symbol. */
5589 m = gfc_match_name (name);
5590 if (m != MATCH_YES)
5591 goto cleanup;
5592
5593 var_locus = gfc_current_locus;
5594
5595 /* OK, we've successfully matched the declaration. Now put the
5596 symbol in the current namespace. If we fail to create the symbol,
5597 bail out. */
5598 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
5599 {
5600 m = MATCH_ERROR;
5601 goto cleanup;
5602 }
5603
5604 /* The double colon must be present in order to have initializers.
5605 Otherwise the statement is ambiguous with an assignment statement. */
5606 if (colon_seen)
5607 {
5608 if (gfc_match_char ('=') == MATCH_YES)
5609 {
5610 m = gfc_match_init_expr (&initializer);
5611 if (m == MATCH_NO)
5612 {
5613 gfc_error ("Expected an initialization expression at %C");
5614 m = MATCH_ERROR;
5615 }
5616
5617 if (m != MATCH_YES)
5618 goto cleanup;
5619 }
5620 }
5621
5622 /* If we do not have an initializer, the initialization value of the
5623 previous enumerator (stored in last_initializer) is incremented
5624 by 1 and is used to initialize the current enumerator. */
5625 if (initializer == NULL)
5626 initializer = gfc_enum_initializer (last_initializer, old_locus);
e14bee04 5627
60fbbf9e 5628 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
5629 {
5630 gfc_error("ENUMERATOR %L not initialized with integer expression",
5631 &var_locus);
e14bee04 5632 m = MATCH_ERROR;
60fbbf9e 5633 gfc_free_enum_history ();
5634 goto cleanup;
5635 }
5636
5637 /* Store this current initializer, for the next enumerator variable
5638 to be parsed. add_init_expr_to_sym() zeros initializer, so we
5639 use last_initializer below. */
5640 last_initializer = initializer;
5641 t = add_init_expr_to_sym (name, &initializer, &var_locus);
5642
5643 /* Maintain enumerator history. */
5644 gfc_find_symbol (name, NULL, 0, &sym);
5645 create_enum_history (sym, last_initializer);
5646
5647 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
5648
5649cleanup:
5650 /* Free stuff up and return. */
5651 gfc_free_expr (initializer);
5652
5653 return m;
5654}
5655
5656
f6d0e37a 5657/* Match the enumerator definition statement. */
3b6a4b41 5658
5659match
5660gfc_match_enumerator_def (void)
5661{
5662 match m;
60fbbf9e 5663 try t;
e14bee04 5664
3b6a4b41 5665 gfc_clear_ts (&current_ts);
e14bee04 5666
3b6a4b41 5667 m = gfc_match (" enumerator");
5668 if (m != MATCH_YES)
5669 return m;
60fbbf9e 5670
5671 m = gfc_match (" :: ");
5672 if (m == MATCH_ERROR)
5673 return m;
5674
5675 colon_seen = (m == MATCH_YES);
e14bee04 5676
3b6a4b41 5677 if (gfc_current_state () != COMP_ENUM)
5678 {
5679 gfc_error ("ENUM definition statement expected before %C");
5680 gfc_free_enum_history ();
5681 return MATCH_ERROR;
5682 }
5683
5684 (&current_ts)->type = BT_INTEGER;
5685 (&current_ts)->kind = gfc_c_int_kind;
e14bee04 5686
60fbbf9e 5687 gfc_clear_attr (&current_attr);
5688 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
5689 if (t == FAILURE)
3b6a4b41 5690 {
60fbbf9e 5691 m = MATCH_ERROR;
3b6a4b41 5692 goto cleanup;
5693 }
5694
3b6a4b41 5695 for (;;)
5696 {
60fbbf9e 5697 m = enumerator_decl ();
3b6a4b41 5698 if (m == MATCH_ERROR)
5699 goto cleanup;
5700 if (m == MATCH_NO)
5701 break;
5702
5703 if (gfc_match_eos () == MATCH_YES)
5704 goto cleanup;
5705 if (gfc_match_char (',') != MATCH_YES)
5706 break;
5707 }
5708
5709 if (gfc_current_state () == COMP_ENUM)
5710 {
5711 gfc_free_enum_history ();
5712 gfc_error ("Syntax error in ENUMERATOR definition at %C");
5713 m = MATCH_ERROR;
5714 }
5715
5716cleanup:
5717 gfc_free_array_spec (current_as);
5718 current_as = NULL;
5719 return m;
5720
5721}
5722
Mirror of https://gcc.gnu.org/git/gcc.git