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