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