]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/decl.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
tree-flow.h (multiplier_allowed_in_address_p): Adjust prototype.
[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
PT		 1222 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1223 && current_ts.derived->ns != gfc_current_ns)
1224 {
1225 gfc_error ("the type of '%s' at %C has not been declared within the "
1226 "interface", name);
6de9cd9a
DN		 1227 m = MATCH_ERROR;
1228 goto cleanup;
1229 }
1230
1231 /* In functions that have a RESULT variable defined, the function
1232 name always refers to function calls. Therefore, the name is
1233 not allowed to appear in specification statements. */
1234 if (gfc_current_state () == COMP_FUNCTION
1235 && gfc_current_block () != NULL
1236 && gfc_current_block ()->result != NULL
1237 && gfc_current_block ()->result != gfc_current_block ()
1238 && strcmp (gfc_current_block ()->name, name) == 0)
1239 {
1240 gfc_error ("Function name '%s' not allowed at %C", name);
1241 m = MATCH_ERROR;
1242 goto cleanup;
1243 }
1244
294fbfc8
TS		 1245 /* We allow old-style initializations of the form
1246 integer i /2/, j(4) /3*3, 1/
1247 (if no colon has been seen). These are different from data
1248 statements in that initializers are only allowed to apply to the
1249 variable immediately preceding, i.e.
1250 integer i, j /1, 2/
1251 is not allowed. Therefore we have to do some work manually, that
75d17889 1252 could otherwise be left to the matchers for DATA statements. */
294fbfc8
TS		 1253
1254 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1255 {
1256 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1257 "initialization at %C") == FAILURE)
1258 return MATCH_ERROR;
1259
1260 return match_old_style_init (name);
1261 }
1262
6de9cd9a
DN		 1263 /* The double colon must be present in order to have initializers.
1264 Otherwise the statement is ambiguous with an assignment statement. */
1265 if (colon_seen)
1266 {
1267 if (gfc_match (" =>") == MATCH_YES)
1268 {
1269
1270 if (!current_attr.pointer)
1271 {
1272 gfc_error ("Initialization at %C isn't for a pointer variable");
1273 m = MATCH_ERROR;
1274 goto cleanup;
1275 }
1276
1277 m = gfc_match_null (&initializer);
1278 if (m == MATCH_NO)
1279 {
def66134 1280 gfc_error ("Pointer initialization requires a NULL() at %C");
6de9cd9a
DN		 1281 m = MATCH_ERROR;
1282 }
1283
1284 if (gfc_pure (NULL))
1285 {
1286 gfc_error
1287 ("Initialization of pointer at %C is not allowed in a "
1288 "PURE procedure");
1289 m = MATCH_ERROR;
1290 }
1291
1292 if (m != MATCH_YES)
1293 goto cleanup;
1294
6de9cd9a
DN		 1295 }
1296 else if (gfc_match_char ('=') == MATCH_YES)
1297 {
1298 if (current_attr.pointer)
1299 {
1300 gfc_error
1301 ("Pointer initialization at %C requires '=>', not '='");
1302 m = MATCH_ERROR;
1303 goto cleanup;
1304 }
1305
1306 m = gfc_match_init_expr (&initializer);
1307 if (m == MATCH_NO)
1308 {
1309 gfc_error ("Expected an initialization expression at %C");
1310 m = MATCH_ERROR;
1311 }
1312
1313 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1314 {
1315 gfc_error
1316 ("Initialization of variable at %C is not allowed in a "
1317 "PURE procedure");
1318 m = MATCH_ERROR;
1319 }
1320
1321 if (m != MATCH_YES)
1322 goto cleanup;
1323 }
cb44ab82
VL		 1324 }
1325
5046aff5
PT		 1326 if (initializer != NULL && current_attr.allocatable
1327 && gfc_current_state () == COMP_DERIVED)
1328 {
1329 gfc_error ("Initialization of allocatable component at %C is not allowed");
1330 m = MATCH_ERROR;
1331 goto cleanup;
1332 }
1333
25d8f0a2
TS		 1334 /* Check if we are parsing an enumeration and if the current enumerator
1335 variable has an initializer or not. If it does not have an
1336 initializer, the initialization value of the previous enumerator
1337 (stored in last_initializer) is incremented by 1 and is used to
1338 initialize the current enumerator. */
1339 if (gfc_current_state () == COMP_ENUM)
1340 {
1341 if (initializer == NULL)
1342 initializer = gfc_enum_initializer (last_initializer, old_locus);
1343
1344 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
1345 {
1346 gfc_error("ENUMERATOR %L not initialized with integer expression",
1347 &var_locus);
1348 m = MATCH_ERROR;
1349 gfc_free_enum_history ();
1350 goto cleanup;
1351 }
1352
1353 /* Store this current initializer, for the next enumerator
1354 variable to be parsed. */
1355 last_initializer = initializer;
1356 }
1357
54b4ba60 1358 /* Add the initializer. Note that it is fine if initializer is
6de9cd9a
DN		 1359 NULL here, because we sometimes also need to check if a
1360 declaration *must* have an initialization expression. */
1361 if (gfc_current_state () != COMP_DERIVED)
1362 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1363 else
54b4ba60 1364 {
5046aff5
PT		 1365 if (current_ts.type == BT_DERIVED
1366 && !current_attr.pointer
1367 && !initializer)
54b4ba60
PB		 1368 initializer = gfc_default_initializer (&current_ts);
1369 t = build_struct (name, cl, &initializer, &as);
1370 }
6de9cd9a
DN		 1371
1372 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1373
1374cleanup:
1375 /* Free stuff up and return. */
1376 gfc_free_expr (initializer);
1377 gfc_free_array_spec (as);
1378
1379 return m;
1380}
1381
1382
1383/* Match an extended-f77 kind specification. */
1384
1385match
1386gfc_match_old_kind_spec (gfc_typespec * ts)
1387{
1388 match m;
5cf54585 1389 int original_kind;
6de9cd9a
DN		 1390
1391 if (gfc_match_char ('*') != MATCH_YES)
1392 return MATCH_NO;
1393
5cf54585 1394 m = gfc_match_small_literal_int (&ts->kind, NULL);
6de9cd9a
DN		 1395 if (m != MATCH_YES)
1396 return MATCH_ERROR;
1397
e45b3c75
ES		 1398 original_kind = ts->kind;
1399
6de9cd9a 1400 /* Massage the kind numbers for complex types. */
e45b3c75
ES		 1401 if (ts->type == BT_COMPLEX)
1402 {
1403 if (ts->kind % 2)
1404 {
1405 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1406 gfc_basic_typename (ts->type), original_kind);
1407 return MATCH_ERROR;
1408 }
1409 ts->kind /= 2;
1410 }
6de9cd9a 1411
e7a2d5fb 1412 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
6de9cd9a 1413 {
e45b3c75
ES		 1414 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1415 gfc_basic_typename (ts->type), original_kind);
6de9cd9a
DN		 1416 return MATCH_ERROR;
1417 }
1418
df8652dc
SK		 1419 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1420 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1421 return MATCH_ERROR;
1422
6de9cd9a
DN		 1423 return MATCH_YES;
1424}
1425
1426
1427/* Match a kind specification. Since kinds are generally optional, we
1428 usually return MATCH_NO if something goes wrong. If a "kind="
1429 string is found, then we know we have an error. */
1430
1431match
1432gfc_match_kind_spec (gfc_typespec * ts)
1433{
1434 locus where;
1435 gfc_expr *e;
1436 match m, n;
1437 const char *msg;
1438
1439 m = MATCH_NO;
1440 e = NULL;
1441
63645982 1442 where = gfc_current_locus;
6de9cd9a
DN		 1443
1444 if (gfc_match_char ('(') == MATCH_NO)
1445 return MATCH_NO;
1446
1447 /* Also gobbles optional text. */
1448 if (gfc_match (" kind = ") == MATCH_YES)
1449 m = MATCH_ERROR;
1450
1451 n = gfc_match_init_expr (&e);
1452 if (n == MATCH_NO)
1453 gfc_error ("Expected initialization expression at %C");
1454 if (n != MATCH_YES)
1455 return MATCH_ERROR;
1456
1457 if (e->rank != 0)
1458 {
1459 gfc_error ("Expected scalar initialization expression at %C");
1460 m = MATCH_ERROR;
1461 goto no_match;
1462 }
1463
1464 msg = gfc_extract_int (e, &ts->kind);
1465 if (msg != NULL)
1466 {
1467 gfc_error (msg);
1468 m = MATCH_ERROR;
1469 goto no_match;
1470 }
1471
1472 gfc_free_expr (e);
1473 e = NULL;
1474
e7a2d5fb 1475 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
6de9cd9a
DN		 1476 {
1477 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1478 gfc_basic_typename (ts->type));
1479
1480 m = MATCH_ERROR;
1481 goto no_match;
1482 }
1483
1484 if (gfc_match_char (')') != MATCH_YES)
1485 {
1486 gfc_error ("Missing right paren at %C");
1487 goto no_match;
1488 }
1489
1490 return MATCH_YES;
1491
1492no_match:
1493 gfc_free_expr (e);
63645982 1494 gfc_current_locus = where;
6de9cd9a
DN		 1495 return m;
1496}
1497
1498
1499/* Match the various kind/length specifications in a CHARACTER
1500 declaration. We don't return MATCH_NO. */
1501
1502static match
1503match_char_spec (gfc_typespec * ts)
1504{
1505 int i, kind, seen_length;
1506 gfc_charlen *cl;
1507 gfc_expr *len;
1508 match m;
1509
9d64df18 1510 kind = gfc_default_character_kind;
6de9cd9a
DN		 1511 len = NULL;
1512 seen_length = 0;
1513
1514 /* Try the old-style specification first. */
1515 old_char_selector = 0;
1516
1517 m = match_char_length (&len);
1518 if (m != MATCH_NO)
1519 {
1520 if (m == MATCH_YES)
1521 old_char_selector = 1;
1522 seen_length = 1;
1523 goto done;
1524 }
1525
1526 m = gfc_match_char ('(');
1527 if (m != MATCH_YES)
1528 {
1529 m = MATCH_YES; /* character without length is a single char */
1530 goto done;
1531 }
1532
1533 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1534 if (gfc_match (" kind =") == MATCH_YES)
1535 {
1536 m = gfc_match_small_int (&kind);
1537 if (m == MATCH_ERROR)
1538 goto done;
1539 if (m == MATCH_NO)
1540 goto syntax;
1541
1542 if (gfc_match (" , len =") == MATCH_NO)
1543 goto rparen;
1544
1545 m = char_len_param_value (&len);
1546 if (m == MATCH_NO)
1547 goto syntax;
1548 if (m == MATCH_ERROR)
1549 goto done;
1550 seen_length = 1;
1551
1552 goto rparen;
1553 }
1554
1555 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1556 if (gfc_match (" len =") == MATCH_YES)
1557 {
1558 m = char_len_param_value (&len);
1559 if (m == MATCH_NO)
1560 goto syntax;
1561 if (m == MATCH_ERROR)
1562 goto done;
1563 seen_length = 1;
1564
1565 if (gfc_match_char (')') == MATCH_YES)
1566 goto done;
1567
1568 if (gfc_match (" , kind =") != MATCH_YES)
1569 goto syntax;
1570
1571 gfc_match_small_int (&kind);
1572
e7a2d5fb 1573 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
6de9cd9a
DN		 1574 {
1575 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1576 return MATCH_YES;
1577 }
1578
1579 goto rparen;
1580 }
1581
1582 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1583 m = char_len_param_value (&len);
1584 if (m == MATCH_NO)
1585 goto syntax;
1586 if (m == MATCH_ERROR)
1587 goto done;
1588 seen_length = 1;
1589
1590 m = gfc_match_char (')');
1591 if (m == MATCH_YES)
1592 goto done;
1593
1594 if (gfc_match_char (',') != MATCH_YES)
1595 goto syntax;
1596
1597 gfc_match (" kind ="); /* Gobble optional text */
1598
1599 m = gfc_match_small_int (&kind);
1600 if (m == MATCH_ERROR)
1601 goto done;
1602 if (m == MATCH_NO)
1603 goto syntax;
1604
1605rparen:
1606 /* Require a right-paren at this point. */
1607 m = gfc_match_char (')');
1608 if (m == MATCH_YES)
1609 goto done;
1610
1611syntax:
1612 gfc_error ("Syntax error in CHARACTER declaration at %C");
1613 m = MATCH_ERROR;
1614
1615done:
e7a2d5fb 1616 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
6de9cd9a
DN		 1617 {
1618 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1619 m = MATCH_ERROR;
1620 }
1621
1622 if (m != MATCH_YES)
1623 {
1624 gfc_free_expr (len);
1625 return m;
1626 }
1627
1628 /* Do some final massaging of the length values. */
1629 cl = gfc_get_charlen ();
1630 cl->next = gfc_current_ns->cl_list;
1631 gfc_current_ns->cl_list = cl;
1632
1633 if (seen_length == 0)
1634 cl->length = gfc_int_expr (1);
1635 else
1636 {
1637 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1638 cl->length = len;
1639 else
1640 {
1641 gfc_free_expr (len);
1642 cl->length = gfc_int_expr (0);
1643 }
1644 }
1645
1646 ts->cl = cl;
1647 ts->kind = kind;
1648
1649 return MATCH_YES;
1650}
1651
1652
1653/* Matches a type specification. If successful, sets the ts structure
1654 to the matched specification. This is necessary for FUNCTION and
1655 IMPLICIT statements.
1656
e5ddaa24
TS		 1657 If implicit_flag is nonzero, then we don't check for the optional
1658 kind specification. Not doing so is needed for matching an IMPLICIT
6de9cd9a
DN		 1659 statement correctly. */
1660
e5ddaa24
TS		 1661static match
1662match_type_spec (gfc_typespec * ts, int implicit_flag)
6de9cd9a
DN		 1663{
1664 char name[GFC_MAX_SYMBOL_LEN + 1];
1665 gfc_symbol *sym;
1666 match m;
0ff0dfbf 1667 int c;
6de9cd9a
DN		 1668
1669 gfc_clear_ts (ts);
1670
5f700e6d
AL		 1671 if (gfc_match (" byte") == MATCH_YES)
1672 {
1673 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1674 == FAILURE)
1675 return MATCH_ERROR;
1676
1677 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1678 {
1679 gfc_error ("BYTE type used at %C "
1680 "is not available on the target machine");
1681 return MATCH_ERROR;
1682 }
1683
1684 ts->type = BT_INTEGER;
1685 ts->kind = 1;
1686 return MATCH_YES;
1687 }
1688
6de9cd9a
DN		 1689 if (gfc_match (" integer") == MATCH_YES)
1690 {
1691 ts->type = BT_INTEGER;
9d64df18 1692 ts->kind = gfc_default_integer_kind;
6de9cd9a
DN		 1693 goto get_kind;
1694 }
1695
1696 if (gfc_match (" character") == MATCH_YES)
1697 {
1698 ts->type = BT_CHARACTER;
e5ddaa24
TS		 1699 if (implicit_flag == 0)
1700 return match_char_spec (ts);
1701 else
1702 return MATCH_YES;
6de9cd9a
DN		 1703 }
1704
1705 if (gfc_match (" real") == MATCH_YES)
1706 {
1707 ts->type = BT_REAL;
9d64df18 1708 ts->kind = gfc_default_real_kind;
6de9cd9a
DN		 1709 goto get_kind;
1710 }
1711
1712 if (gfc_match (" double precision") == MATCH_YES)
1713 {
1714 ts->type = BT_REAL;
9d64df18 1715 ts->kind = gfc_default_double_kind;
6de9cd9a
DN		 1716 return MATCH_YES;
1717 }
1718
1719 if (gfc_match (" complex") == MATCH_YES)
1720 {
1721 ts->type = BT_COMPLEX;
9d64df18 1722 ts->kind = gfc_default_complex_kind;
6de9cd9a
DN		 1723 goto get_kind;
1724 }
1725
1726 if (gfc_match (" double complex") == MATCH_YES)
1727 {
df8652dc
SK		 1728 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1729 "conform to the Fortran 95 standard") == FAILURE)
1730 return MATCH_ERROR;
1731
6de9cd9a 1732 ts->type = BT_COMPLEX;
9d64df18 1733 ts->kind = gfc_default_double_kind;
6de9cd9a
DN		 1734 return MATCH_YES;
1735 }
1736
1737 if (gfc_match (" logical") == MATCH_YES)
1738 {
1739 ts->type = BT_LOGICAL;
9d64df18 1740 ts->kind = gfc_default_logical_kind;
6de9cd9a
DN		 1741 goto get_kind;
1742 }
1743
1744 m = gfc_match (" type ( %n )", name);
1745 if (m != MATCH_YES)
1746 return m;
1747
1748 /* Search for the name but allow the components to be defined later. */
1749 if (gfc_get_ha_symbol (name, &sym))
1750 {
1751 gfc_error ("Type name '%s' at %C is ambiguous", name);
1752 return MATCH_ERROR;
1753 }
1754
1755 if (sym->attr.flavor != FL_DERIVED
231b2fcc 1756 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 1757 return MATCH_ERROR;
1758
1759 ts->type = BT_DERIVED;
1760 ts->kind = 0;
1761 ts->derived = sym;
1762
1763 return MATCH_YES;
1764
1765get_kind:
1766 /* For all types except double, derived and character, look for an
1767 optional kind specifier. MATCH_NO is actually OK at this point. */
e5ddaa24 1768 if (implicit_flag == 1)
6de9cd9a
DN		 1769 return MATCH_YES;
1770
0ff0dfbf
TS		 1771 if (gfc_current_form == FORM_FREE)
1772 {
1773 c = gfc_peek_char();
1774 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1775 && c != ':' && c != ',')
1776 return MATCH_NO;
1777 }
1778
6de9cd9a
DN		 1779 m = gfc_match_kind_spec (ts);
1780 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1781 m = gfc_match_old_kind_spec (ts);
1782
1783 if (m == MATCH_NO)
1784 m = MATCH_YES; /* No kind specifier found. */
1785
1786 return m;
1787}
1788
1789
e5ddaa24
TS		 1790/* Match an IMPLICIT NONE statement. Actually, this statement is
1791 already matched in parse.c, or we would not end up here in the
1792 first place. So the only thing we need to check, is if there is
1793 trailing garbage. If not, the match is successful. */
1794
1795match
1796gfc_match_implicit_none (void)
1797{
1798
1799 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1800}
1801
1802
1803/* Match the letter range(s) of an IMPLICIT statement. */
1804
1805static match
1107b970 1806match_implicit_range (void)
e5ddaa24
TS		 1807{
1808 int c, c1, c2, inner;
1809 locus cur_loc;
1810
1811 cur_loc = gfc_current_locus;
1812
1813 gfc_gobble_whitespace ();
1814 c = gfc_next_char ();
1815 if (c != '(')
1816 {
1817 gfc_error ("Missing character range in IMPLICIT at %C");
1818 goto bad;
1819 }
1820
1821 inner = 1;
1822 while (inner)
1823 {
1824 gfc_gobble_whitespace ();
1825 c1 = gfc_next_char ();
1826 if (!ISALPHA (c1))
1827 goto bad;
1828
1829 gfc_gobble_whitespace ();
1830 c = gfc_next_char ();
1831
1832 switch (c)
1833 {
1834 case ')':
1835 inner = 0; /* Fall through */
1836
1837 case ',':
1838 c2 = c1;
1839 break;
1840
1841 case '-':
1842 gfc_gobble_whitespace ();
1843 c2 = gfc_next_char ();
1844 if (!ISALPHA (c2))
1845 goto bad;
1846
1847 gfc_gobble_whitespace ();
1848 c = gfc_next_char ();
1849
1850 if ((c != ',') && (c != ')'))
1851 goto bad;
1852 if (c == ')')
1853 inner = 0;
1854
1855 break;
1856
1857 default:
1858 goto bad;
1859 }
1860
1861 if (c1 > c2)
1862 {
1863 gfc_error ("Letters must be in alphabetic order in "
1864 "IMPLICIT statement at %C");
1865 goto bad;
1866 }
1867
1868 /* See if we can add the newly matched range to the pending
1869 implicits from this IMPLICIT statement. We do not check for
1870 conflicts with whatever earlier IMPLICIT statements may have
1871 set. This is done when we've successfully finished matching
1872 the current one. */
1107b970 1873 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
e5ddaa24
TS		 1874 goto bad;
1875 }
1876
1877 return MATCH_YES;
1878
1879bad:
1880 gfc_syntax_error (ST_IMPLICIT);
1881
1882 gfc_current_locus = cur_loc;
1883 return MATCH_ERROR;
1884}
1885
1886
1887/* Match an IMPLICIT statement, storing the types for
1888 gfc_set_implicit() if the statement is accepted by the parser.
1889 There is a strange looking, but legal syntactic construction
1890 possible. It looks like:
1891
1892 IMPLICIT INTEGER (a-b) (c-d)
1893
1894 This is legal if "a-b" is a constant expression that happens to
1895 equal one of the legal kinds for integers. The real problem
1896 happens with an implicit specification that looks like:
1897
1898 IMPLICIT INTEGER (a-b)
1899
1900 In this case, a typespec matcher that is "greedy" (as most of the
1901 matchers are) gobbles the character range as a kindspec, leaving
1902 nothing left. We therefore have to go a bit more slowly in the
1903 matching process by inhibiting the kindspec checking during
1904 typespec matching and checking for a kind later. */
1905
1906match
1907gfc_match_implicit (void)
1908{
1909 gfc_typespec ts;
1910 locus cur_loc;
1911 int c;
1912 match m;
1913
1914 /* We don't allow empty implicit statements. */
1915 if (gfc_match_eos () == MATCH_YES)
1916 {
1917 gfc_error ("Empty IMPLICIT statement at %C");
1918 return MATCH_ERROR;
1919 }
1920
e5ddaa24
TS		 1921 do
1922 {
1107b970
PB		 1923 /* First cleanup. */
1924 gfc_clear_new_implicit ();
1925
e5ddaa24
TS		 1926 /* A basic type is mandatory here. */
1927 m = match_type_spec (&ts, 1);
1928 if (m == MATCH_ERROR)
1929 goto error;
1930 if (m == MATCH_NO)
1931 goto syntax;
1932
1933 cur_loc = gfc_current_locus;
1107b970 1934 m = match_implicit_range ();
e5ddaa24
TS		 1935
1936 if (m == MATCH_YES)
1937 {
1107b970 1938 /* We may have <TYPE> (<RANGE>). */
e5ddaa24
TS		 1939 gfc_gobble_whitespace ();
1940 c = gfc_next_char ();
1941 if ((c == '\n') || (c == ','))
1107b970
PB		 1942 {
1943 /* Check for CHARACTER with no length parameter. */
1944 if (ts.type == BT_CHARACTER && !ts.cl)
1945 {
9d64df18 1946 ts.kind = gfc_default_character_kind;
1107b970
PB		 1947 ts.cl = gfc_get_charlen ();
1948 ts.cl->next = gfc_current_ns->cl_list;
1949 gfc_current_ns->cl_list = ts.cl;
1950 ts.cl->length = gfc_int_expr (1);
1951 }
1952
1953 /* Record the Successful match. */
1954 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1955 return MATCH_ERROR;
1956 continue;
1957 }
e5ddaa24
TS		 1958
1959 gfc_current_locus = cur_loc;
1960 }
1961
1107b970
PB		 1962 /* Discard the (incorrectly) matched range. */
1963 gfc_clear_new_implicit ();
1964
1965 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1966 if (ts.type == BT_CHARACTER)
1967 m = match_char_spec (&ts);
1968 else
e5ddaa24 1969 {
1107b970 1970 m = gfc_match_kind_spec (&ts);
e5ddaa24 1971 if (m == MATCH_NO)
1107b970
PB		 1972 {
1973 m = gfc_match_old_kind_spec (&ts);
1974 if (m == MATCH_ERROR)
1975 goto error;
1976 if (m == MATCH_NO)
1977 goto syntax;
1978 }
e5ddaa24 1979 }
1107b970
PB		 1980 if (m == MATCH_ERROR)
1981 goto error;
e5ddaa24 1982
1107b970 1983 m = match_implicit_range ();
e5ddaa24
TS		 1984 if (m == MATCH_ERROR)
1985 goto error;
1986 if (m == MATCH_NO)
1987 goto syntax;
1988
1989 gfc_gobble_whitespace ();
1990 c = gfc_next_char ();
1991 if ((c != '\n') && (c != ','))
1992 goto syntax;
1993
1107b970
PB		 1994 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1995 return MATCH_ERROR;
e5ddaa24
TS		 1996 }
1997 while (c == ',');
1998
1107b970 1999 return MATCH_YES;
e5ddaa24
TS		 2000
2001syntax:
2002 gfc_syntax_error (ST_IMPLICIT);
2003
2004error:
2005 return MATCH_ERROR;
2006}
2007
2008
6de9cd9a
DN		 2009/* Matches an attribute specification including array specs. If
2010 successful, leaves the variables current_attr and current_as
2011 holding the specification. Also sets the colon_seen variable for
2012 later use by matchers associated with initializations.
2013
2014 This subroutine is a little tricky in the sense that we don't know
2015 if we really have an attr-spec until we hit the double colon.
2016 Until that time, we can only return MATCH_NO. This forces us to
2017 check for duplicate specification at this level. */
2018
2019static match
2020match_attr_spec (void)
2021{
2022
2023 /* Modifiers that can exist in a type statement. */
2024 typedef enum
2025 { GFC_DECL_BEGIN = 0,
2026 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2027 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2028 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
775e6c3a 2029 DECL_TARGET, DECL_VOLATILE, DECL_COLON, DECL_NONE,
6de9cd9a
DN		 2030 GFC_DECL_END /* Sentinel */
2031 }
2032 decl_types;
2033
2034/* GFC_DECL_END is the sentinel, index starts at 0. */
2035#define NUM_DECL GFC_DECL_END
2036
2037 static mstring decls[] = {
2038 minit (", allocatable", DECL_ALLOCATABLE),
2039 minit (", dimension", DECL_DIMENSION),
2040 minit (", external", DECL_EXTERNAL),
2041 minit (", intent ( in )", DECL_IN),
2042 minit (", intent ( out )", DECL_OUT),
2043 minit (", intent ( in out )", DECL_INOUT),
2044 minit (", intrinsic", DECL_INTRINSIC),
2045 minit (", optional", DECL_OPTIONAL),
2046 minit (", parameter", DECL_PARAMETER),
2047 minit (", pointer", DECL_POINTER),
2048 minit (", private", DECL_PRIVATE),
2049 minit (", public", DECL_PUBLIC),
2050 minit (", save", DECL_SAVE),
2051 minit (", target", DECL_TARGET),
775e6c3a 2052 minit (", volatile", DECL_VOLATILE),
6de9cd9a
DN		 2053 minit ("::", DECL_COLON),
2054 minit (NULL, DECL_NONE)
2055 };
2056
2057 locus start, seen_at[NUM_DECL];
2058 int seen[NUM_DECL];
2059 decl_types d;
2060 const char *attr;
2061 match m;
2062 try t;
2063
2064 gfc_clear_attr (&current_attr);
63645982 2065 start = gfc_current_locus;
6de9cd9a
DN		 2066
2067 current_as = NULL;
2068 colon_seen = 0;
2069
2070 /* See if we get all of the keywords up to the final double colon. */
2071 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2072 seen[d] = 0;
2073
2074 for (;;)
2075 {
2076 d = (decl_types) gfc_match_strings (decls);
2077 if (d == DECL_NONE || d == DECL_COLON)
2078 break;
25d8f0a2
TS		 2079
2080 if (gfc_current_state () == COMP_ENUM)
2081 {
2082 gfc_error ("Enumerator cannot have attributes %C");
2083 return MATCH_ERROR;
2084 }
6de9cd9a
DN		 2085
2086 seen[d]++;
63645982 2087 seen_at[d] = gfc_current_locus;
6de9cd9a
DN		 2088
2089 if (d == DECL_DIMENSION)
2090 {
2091 m = gfc_match_array_spec (&current_as);
2092
2093 if (m == MATCH_NO)
2094 {
2095 gfc_error ("Missing dimension specification at %C");
2096 m = MATCH_ERROR;
2097 }
2098
2099 if (m == MATCH_ERROR)
2100 goto cleanup;
2101 }
2102 }
2103
831d7813 2104 /* If we are parsing an enumeration and have ensured that no other
25d8f0a2
TS		 2105 attributes are present we can now set the parameter attribute. */
2106 if (gfc_current_state () == COMP_ENUM)
2107 {
2108 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
2109 if (t == FAILURE)
2110 {
2111 m = MATCH_ERROR;
2112 goto cleanup;
2113 }
2114 }
2115
6de9cd9a
DN		 2116 /* No double colon, so assume that we've been looking at something
2117 else the whole time. */
2118 if (d == DECL_NONE)
2119 {
2120 m = MATCH_NO;
2121 goto cleanup;
2122 }
2123
2124 /* Since we've seen a double colon, we have to be looking at an
2125 attr-spec. This means that we can now issue errors. */
2126 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2127 if (seen[d] > 1)
2128 {
2129 switch (d)
2130 {
2131 case DECL_ALLOCATABLE:
2132 attr = "ALLOCATABLE";
2133 break;
2134 case DECL_DIMENSION:
2135 attr = "DIMENSION";
2136 break;
2137 case DECL_EXTERNAL:
2138 attr = "EXTERNAL";
2139 break;
2140 case DECL_IN:
2141 attr = "INTENT (IN)";
2142 break;
2143 case DECL_OUT:
2144 attr = "INTENT (OUT)";
2145 break;
2146 case DECL_INOUT:
2147 attr = "INTENT (IN OUT)";
2148 break;
2149 case DECL_INTRINSIC:
2150 attr = "INTRINSIC";
2151 break;
2152 case DECL_OPTIONAL:
2153 attr = "OPTIONAL";
2154 break;
2155 case DECL_PARAMETER:
2156 attr = "PARAMETER";
2157 break;
2158 case DECL_POINTER:
2159 attr = "POINTER";
2160 break;
2161 case DECL_PRIVATE:
2162 attr = "PRIVATE";
2163 break;
2164 case DECL_PUBLIC:
2165 attr = "PUBLIC";
2166 break;
2167 case DECL_SAVE:
2168 attr = "SAVE";
2169 break;
2170 case DECL_TARGET:
2171 attr = "TARGET";
2172 break;
775e6c3a
TB		 2173 case DECL_VOLATILE:
2174 attr = "VOLATILE";
2175 break;
6de9cd9a
DN		 2176 default:
2177 attr = NULL; /* This shouldn't happen */
2178 }
2179
2180 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2181 m = MATCH_ERROR;
2182 goto cleanup;
2183 }
2184
2185 /* Now that we've dealt with duplicate attributes, add the attributes
2186 to the current attribute. */
2187 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2188 {
2189 if (seen[d] == 0)
2190 continue;
2191
2192 if (gfc_current_state () == COMP_DERIVED
2193 && d != DECL_DIMENSION && d != DECL_POINTER
2194 && d != DECL_COLON && d != DECL_NONE)
2195 {
5046aff5
PT		 2196 if (d == DECL_ALLOCATABLE)
2197 {
2198 if (gfc_notify_std (GFC_STD_F2003,
aa4183d8
TB		 2199 "Fortran 2003: ALLOCATABLE "
2200 "attribute at %C in a TYPE "
5046aff5
PT		 2201 "definition") == FAILURE)
2202 {
2203 m = MATCH_ERROR;
2204 goto cleanup;
2205 }
2206 }
2207 else
2208 {
2209 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2210 &seen_at[d]);
2211 m = MATCH_ERROR;
2212 goto cleanup;
2213 }
6de9cd9a
DN		 2214 }
2215
4213f93b
PT		 2216 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2217 && gfc_current_state () != COMP_MODULE)
2218 {
2219 if (d == DECL_PRIVATE)
2220 attr = "PRIVATE";
2221 else
2222 attr = "PUBLIC";
2223
2224 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2225 attr, &seen_at[d]);
2226 m = MATCH_ERROR;
2227 goto cleanup;
2228 }
2229
6de9cd9a
DN		 2230 switch (d)
2231 {
2232 case DECL_ALLOCATABLE:
2233 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2234 break;
2235
2236 case DECL_DIMENSION:
231b2fcc 2237 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
6de9cd9a
DN		 2238 break;
2239
2240 case DECL_EXTERNAL:
2241 t = gfc_add_external (&current_attr, &seen_at[d]);
2242 break;
2243
2244 case DECL_IN:
2245 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2246 break;
2247
2248 case DECL_OUT:
2249 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2250 break;
2251
2252 case DECL_INOUT:
2253 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2254 break;
2255
2256 case DECL_INTRINSIC:
2257 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2258 break;
2259
2260 case DECL_OPTIONAL:
2261 t = gfc_add_optional (&current_attr, &seen_at[d]);
2262 break;
2263
2264 case DECL_PARAMETER:
231b2fcc 2265 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
6de9cd9a
DN		 2266 break;
2267
2268 case DECL_POINTER:
2269 t = gfc_add_pointer (&current_attr, &seen_at[d]);
2270 break;
2271
2272 case DECL_PRIVATE:
231b2fcc
TS		 2273 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2274 &seen_at[d]);
6de9cd9a
DN		 2275 break;
2276
2277 case DECL_PUBLIC:
231b2fcc
TS		 2278 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2279 &seen_at[d]);
6de9cd9a
DN		 2280 break;
2281
2282 case DECL_SAVE:
231b2fcc 2283 t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
6de9cd9a
DN		 2284 break;
2285
2286 case DECL_TARGET:
2287 t = gfc_add_target (&current_attr, &seen_at[d]);
2288 break;
2289
775e6c3a
TB		 2290 case DECL_VOLATILE:
2291 if (gfc_notify_std (GFC_STD_F2003,
2292 "Fortran 2003: VOLATILE attribute at %C")
2293 == FAILURE)
2294 t = FAILURE;
2295 else
2296 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2297 break;
2298
6de9cd9a
DN		 2299 default:
2300 gfc_internal_error ("match_attr_spec(): Bad attribute");
2301 }
2302
2303 if (t == FAILURE)
2304 {
2305 m = MATCH_ERROR;
2306 goto cleanup;
2307 }
2308 }
2309
2310 colon_seen = 1;
2311 return MATCH_YES;
2312
2313cleanup:
63645982 2314 gfc_current_locus = start;
6de9cd9a
DN		 2315 gfc_free_array_spec (current_as);
2316 current_as = NULL;
2317 return m;
2318}
2319
2320
2321/* Match a data declaration statement. */
2322
2323match
2324gfc_match_data_decl (void)
2325{
2326 gfc_symbol *sym;
2327 match m;
949d5b72 2328 int elem;
6de9cd9a 2329
e5ddaa24 2330 m = match_type_spec (&current_ts, 0);
6de9cd9a
DN		 2331 if (m != MATCH_YES)
2332 return m;
2333
2334 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2335 {
2336 sym = gfc_use_derived (current_ts.derived);
2337
2338 if (sym == NULL)
2339 {
2340 m = MATCH_ERROR;
2341 goto cleanup;
2342 }
2343
2344 current_ts.derived = sym;
2345 }
2346
2347 m = match_attr_spec ();
2348 if (m == MATCH_ERROR)
2349 {
2350 m = MATCH_NO;
2351 goto cleanup;
2352 }
2353
2354 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2355 {
2356
2357 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2358 goto ok;
2359
976e21f6
PT		 2360 gfc_find_symbol (current_ts.derived->name,
2361 current_ts.derived->ns->parent, 1, &sym);
6de9cd9a 2362
976e21f6
PT		 2363 /* Any symbol that we find had better be a type definition
2364 which has its components defined. */
2365 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2366 && current_ts.derived->components != NULL)
6de9cd9a
DN		 2367 goto ok;
2368
976e21f6
PT		 2369 /* Now we have an error, which we signal, and then fix up
2370 because the knock-on is plain and simple confusing. */
2371 gfc_error_now ("Derived type at %C has not been previously defined "
2372 "and so cannot appear in a derived type definition.");
2373 current_attr.pointer = 1;
2374 goto ok;
6de9cd9a
DN		 2375 }
2376
2377ok:
2378 /* If we have an old-style character declaration, and no new-style
2379 attribute specifications, then there a comma is optional between
2380 the type specification and the variable list. */
2381 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2382 gfc_match_char (',');
2383
949d5b72
PT		 2384 /* Give the types/attributes to symbols that follow. Give the element
2385 a number so that repeat character length expressions can be copied. */
2386 elem = 1;
6de9cd9a
DN		 2387 for (;;)
2388 {
949d5b72 2389 m = variable_decl (elem++);
6de9cd9a
DN		 2390 if (m == MATCH_ERROR)
2391 goto cleanup;
2392 if (m == MATCH_NO)
2393 break;
2394
2395 if (gfc_match_eos () == MATCH_YES)
2396 goto cleanup;
2397 if (gfc_match_char (',') != MATCH_YES)
2398 break;
2399 }
2400
8f81c3c6
PT		 2401 if (gfc_error_flag_test () == 0)
2402 gfc_error ("Syntax error in data declaration at %C");
6de9cd9a
DN		 2403 m = MATCH_ERROR;
2404
a9f6f1f2
JD		 2405 gfc_free_data_all (gfc_current_ns);
2406
6de9cd9a
DN		 2407cleanup:
2408 gfc_free_array_spec (current_as);
2409 current_as = NULL;
2410 return m;
2411}
2412
2413
2414/* Match a prefix associated with a function or subroutine
2415 declaration. If the typespec pointer is nonnull, then a typespec
2416 can be matched. Note that if nothing matches, MATCH_YES is
2417 returned (the null string was matched). */
2418
2419static match
2420match_prefix (gfc_typespec * ts)
2421{
2422 int seen_type;
2423
2424 gfc_clear_attr (&current_attr);
2425 seen_type = 0;
2426
2427loop:
2428 if (!seen_type && ts != NULL
e5ddaa24 2429 && match_type_spec (ts, 0) == MATCH_YES
6de9cd9a
DN		 2430 && gfc_match_space () == MATCH_YES)
2431 {
2432
2433 seen_type = 1;
2434 goto loop;
2435 }
2436
2437 if (gfc_match ("elemental% ") == MATCH_YES)
2438 {
2439 if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
2440 return MATCH_ERROR;
2441
2442 goto loop;
2443 }
2444
2445 if (gfc_match ("pure% ") == MATCH_YES)
2446 {
2447 if (gfc_add_pure (&current_attr, NULL) == FAILURE)
2448 return MATCH_ERROR;
2449
2450 goto loop;
2451 }
2452
2453 if (gfc_match ("recursive% ") == MATCH_YES)
2454 {
2455 if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
2456 return MATCH_ERROR;
2457
2458 goto loop;
2459 }
2460
2461 /* At this point, the next item is not a prefix. */
2462 return MATCH_YES;
2463}
2464
2465
2466/* Copy attributes matched by match_prefix() to attributes on a symbol. */
2467
2468static try
2469copy_prefix (symbol_attribute * dest, locus * where)
2470{
2471
2472 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2473 return FAILURE;
2474
2475 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2476 return FAILURE;
2477
2478 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2479 return FAILURE;
2480
2481 return SUCCESS;
2482}
2483
2484
2485/* Match a formal argument list. */
2486
2487match
2488gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2489{
2490 gfc_formal_arglist *head, *tail, *p, *q;
2491 char name[GFC_MAX_SYMBOL_LEN + 1];
2492 gfc_symbol *sym;
2493 match m;
2494
2495 head = tail = NULL;
2496
2497 if (gfc_match_char ('(') != MATCH_YES)
2498 {
2499 if (null_flag)
2500 goto ok;
2501 return MATCH_NO;
2502 }
2503
2504 if (gfc_match_char (')') == MATCH_YES)
2505 goto ok;
2506
2507 for (;;)
2508 {
2509 if (gfc_match_char ('*') == MATCH_YES)
2510 sym = NULL;
2511 else
2512 {
2513 m = gfc_match_name (name);
2514 if (m != MATCH_YES)
2515 goto cleanup;
2516
2517 if (gfc_get_symbol (name, NULL, &sym))
2518 goto cleanup;
2519 }
2520
2521 p = gfc_get_formal_arglist ();
2522
2523 if (head == NULL)
2524 head = tail = p;
2525 else
2526 {
2527 tail->next = p;
2528 tail = p;
2529 }
2530
2531 tail->sym = sym;
2532
2533 /* We don't add the VARIABLE flavor because the name could be a
2534 dummy procedure. We don't apply these attributes to formal
2535 arguments of statement functions. */
2536 if (sym != NULL && !st_flag
231b2fcc 2537 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
6de9cd9a
DN		 2538 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2539 {
2540 m = MATCH_ERROR;
2541 goto cleanup;
2542 }
2543
2544 /* The name of a program unit can be in a different namespace,
2545 so check for it explicitly. After the statement is accepted,
2546 the name is checked for especially in gfc_get_symbol(). */
2547 if (gfc_new_block != NULL && sym != NULL
2548 && strcmp (sym->name, gfc_new_block->name) == 0)
2549 {
2550 gfc_error ("Name '%s' at %C is the name of the procedure",
2551 sym->name);
2552 m = MATCH_ERROR;
2553 goto cleanup;
2554 }
2555
2556 if (gfc_match_char (')') == MATCH_YES)
2557 goto ok;
2558
2559 m = gfc_match_char (',');
2560 if (m != MATCH_YES)
2561 {
2562 gfc_error ("Unexpected junk in formal argument list at %C");
2563 goto cleanup;
2564 }
2565 }
2566
2567ok:
2568 /* Check for duplicate symbols in the formal argument list. */
2569 if (head != NULL)
2570 {
2571 for (p = head; p->next; p = p->next)
2572 {
2573 if (p->sym == NULL)
2574 continue;
2575
2576 for (q = p->next; q; q = q->next)
2577 if (p->sym == q->sym)
2578 {
2579 gfc_error
2580 ("Duplicate symbol '%s' in formal argument list at %C",
2581 p->sym->name);
2582
2583 m = MATCH_ERROR;
2584 goto cleanup;
2585 }
2586 }
2587 }
2588
2589 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2590 FAILURE)
2591 {
2592 m = MATCH_ERROR;
2593 goto cleanup;
2594 }
2595
2596 return MATCH_YES;
2597
2598cleanup:
2599 gfc_free_formal_arglist (head);
2600 return m;
2601}
2602
2603
2604/* Match a RESULT specification following a function declaration or
2605 ENTRY statement. Also matches the end-of-statement. */
2606
2607static match
2608match_result (gfc_symbol * function, gfc_symbol ** result)
2609{
2610 char name[GFC_MAX_SYMBOL_LEN + 1];
2611 gfc_symbol *r;
2612 match m;
2613
2614 if (gfc_match (" result (") != MATCH_YES)
2615 return MATCH_NO;
2616
2617 m = gfc_match_name (name);
2618 if (m != MATCH_YES)
2619 return m;
2620
2621 if (gfc_match (" )%t") != MATCH_YES)
2622 {
2623 gfc_error ("Unexpected junk following RESULT variable at %C");
2624 return MATCH_ERROR;
2625 }
2626
2627 if (strcmp (function->name, name) == 0)
2628 {
2629 gfc_error
2630 ("RESULT variable at %C must be different than function name");
2631 return MATCH_ERROR;
2632 }
2633
2634 if (gfc_get_symbol (name, NULL, &r))
2635 return MATCH_ERROR;
2636
231b2fcc
TS		 2637 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2638 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
6de9cd9a
DN		 2639 return MATCH_ERROR;
2640
2641 *result = r;
2642
2643 return MATCH_YES;
2644}
2645
2646
2647/* Match a function declaration. */
2648
2649match
2650gfc_match_function_decl (void)
2651{
2652 char name[GFC_MAX_SYMBOL_LEN + 1];
2653 gfc_symbol *sym, *result;
2654 locus old_loc;
2655 match m;
2656
2657 if (gfc_current_state () != COMP_NONE
2658 && gfc_current_state () != COMP_INTERFACE
2659 && gfc_current_state () != COMP_CONTAINS)
2660 return MATCH_NO;
2661
2662 gfc_clear_ts (&current_ts);
2663
63645982 2664 old_loc = gfc_current_locus;
6de9cd9a
DN		 2665
2666 m = match_prefix (&current_ts);
2667 if (m != MATCH_YES)
2668 {
63645982 2669 gfc_current_locus = old_loc;
6de9cd9a
DN		 2670 return m;
2671 }
2672
2673 if (gfc_match ("function% %n", name) != MATCH_YES)
2674 {
63645982 2675 gfc_current_locus = old_loc;
6de9cd9a
DN		 2676 return MATCH_NO;
2677 }
2678
1a492601 2679 if (get_proc_name (name, &sym, false))
6de9cd9a
DN		 2680 return MATCH_ERROR;
2681 gfc_new_block = sym;
2682
2683 m = gfc_match_formal_arglist (sym, 0, 0);
2684 if (m == MATCH_NO)
2b9a33ae
TS		 2685 {
2686 gfc_error ("Expected formal argument list in function "
2687 "definition at %C");
2688 m = MATCH_ERROR;
2689 goto cleanup;
2690 }
6de9cd9a
DN		 2691 else if (m == MATCH_ERROR)
2692 goto cleanup;
2693
2694 result = NULL;
2695
2696 if (gfc_match_eos () != MATCH_YES)
2697 {
2698 /* See if a result variable is present. */
2699 m = match_result (sym, &result);
2700 if (m == MATCH_NO)
2701 gfc_error ("Unexpected junk after function declaration at %C");
2702
2703 if (m != MATCH_YES)
2704 {
2705 m = MATCH_ERROR;
2706 goto cleanup;
2707 }
2708 }
2709
2710 /* Make changes to the symbol. */
2711 m = MATCH_ERROR;
2712
231b2fcc 2713 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 2714 goto cleanup;
2715
2716 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2717 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2718 goto cleanup;
2719
982186b1
PT		 2720 if (current_ts.type != BT_UNKNOWN
2721 && sym->ts.type != BT_UNKNOWN
2722 && !sym->attr.implicit_type)
6de9cd9a
DN		 2723 {
2724 gfc_error ("Function '%s' at %C already has a type of %s", name,
2725 gfc_basic_typename (sym->ts.type));
2726 goto cleanup;
2727 }
2728
2729 if (result == NULL)
2730 {
2731 sym->ts = current_ts;
2732 sym->result = sym;
2733 }
2734 else
2735 {
2736 result->ts = current_ts;
2737 sym->result = result;
2738 }
2739
2740 return MATCH_YES;
2741
2742cleanup:
63645982 2743 gfc_current_locus = old_loc;
6de9cd9a
DN		 2744 return m;
2745}
2746
68ea355b
PT		 2747/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2748 name of the entry, rather than the gfc_current_block name, and to return false
2749 upon finding an existing global entry. */
2750
2751static bool
2752add_global_entry (const char * name, int sub)
2753{
2754 gfc_gsymbol *s;
2755
2756 s = gfc_get_gsymbol(name);
2757
2758 if (s->defined
2759 || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2760 global_used(s, NULL);
2761 else
2762 {
2763 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2764 s->where = gfc_current_locus;
2765 s->defined = 1;
2766 return true;
2767 }
2768 return false;
2769}
6de9cd9a
DN		 2770
2771/* Match an ENTRY statement. */
2772
2773match
2774gfc_match_entry (void)
2775{
3d79abbd
PB		 2776 gfc_symbol *proc;
2777 gfc_symbol *result;
2778 gfc_symbol *entry;
6de9cd9a
DN		 2779 char name[GFC_MAX_SYMBOL_LEN + 1];
2780 gfc_compile_state state;
2781 match m;
3d79abbd 2782 gfc_entry_list *el;
c96cfa49 2783 locus old_loc;
1a492601 2784 bool module_procedure;
6de9cd9a
DN		 2785
2786 m = gfc_match_name (name);
2787 if (m != MATCH_YES)
2788 return m;
2789
3d79abbd 2790 state = gfc_current_state ();
4c93c95a 2791 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
3d79abbd 2792 {
4c93c95a
FXC		 2793 switch (state)
2794 {
2795 case COMP_PROGRAM:
2796 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2797 break;
2798 case COMP_MODULE:
2799 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2800 break;
2801 case COMP_BLOCK_DATA:
2802 gfc_error
2803 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2804 break;
2805 case COMP_INTERFACE:
2806 gfc_error
2807 ("ENTRY statement at %C cannot appear within an INTERFACE");
2808 break;
2809 case COMP_DERIVED:
2810 gfc_error
2811 ("ENTRY statement at %C cannot appear "
2812 "within a DERIVED TYPE block");
2813 break;
2814 case COMP_IF:
2815 gfc_error
2816 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2817 break;
2818 case COMP_DO:
2819 gfc_error
2820 ("ENTRY statement at %C cannot appear within a DO block");
2821 break;
2822 case COMP_SELECT:
2823 gfc_error
2824 ("ENTRY statement at %C cannot appear within a SELECT block");
2825 break;
2826 case COMP_FORALL:
2827 gfc_error
2828 ("ENTRY statement at %C cannot appear within a FORALL block");
2829 break;
2830 case COMP_WHERE:
2831 gfc_error
2832 ("ENTRY statement at %C cannot appear within a WHERE block");
2833 break;
2834 case COMP_CONTAINS:
2835 gfc_error
2836 ("ENTRY statement at %C cannot appear "
2837 "within a contained subprogram");
2838 break;
2839 default:
2840 gfc_internal_error ("gfc_match_entry(): Bad state");
2841 }
3d79abbd
PB		 2842 return MATCH_ERROR;
2843 }
2844
1a492601
PT		 2845 module_procedure = gfc_current_ns->parent != NULL
2846 && gfc_current_ns->parent->proc_name
2847 && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
2848
3d79abbd
PB		 2849 if (gfc_current_ns->parent != NULL
2850 && gfc_current_ns->parent->proc_name
1a492601 2851 && !module_procedure)
3d79abbd
PB		 2852 {
2853 gfc_error("ENTRY statement at %C cannot appear in a "
2854 "contained procedure");
2855 return MATCH_ERROR;
2856 }
2857
1a492601
PT		 2858 /* Module function entries need special care in get_proc_name
2859 because previous references within the function will have
2860 created symbols attached to the current namespace. */
2861 if (get_proc_name (name, &entry,
2862 gfc_current_ns->parent != NULL
2863 && module_procedure
2864 && gfc_current_ns->proc_name->attr.function))
6de9cd9a
DN		 2865 return MATCH_ERROR;
2866
3d79abbd
PB		 2867 proc = gfc_current_block ();
2868
2869 if (state == COMP_SUBROUTINE)
6de9cd9a 2870 {
231b2fcc 2871 /* An entry in a subroutine. */
68ea355b
PT		 2872 if (!add_global_entry (name, 1))
2873 return MATCH_ERROR;
2874
6de9cd9a
DN		 2875 m = gfc_match_formal_arglist (entry, 0, 1);
2876 if (m != MATCH_YES)
2877 return MATCH_ERROR;
2878
231b2fcc
TS		 2879 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2880 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
6de9cd9a 2881 return MATCH_ERROR;
3d79abbd
PB		 2882 }
2883 else
2884 {
c96cfa49
TS		 2885 /* An entry in a function.
2886 We need to take special care because writing
2887 ENTRY f()
2888 as
2889 ENTRY f
2890 is allowed, whereas
2891 ENTRY f() RESULT (r)
2892 can't be written as
2893 ENTRY f RESULT (r). */
68ea355b
PT		 2894 if (!add_global_entry (name, 0))
2895 return MATCH_ERROR;
2896
c96cfa49
TS		 2897 old_loc = gfc_current_locus;
2898 if (gfc_match_eos () == MATCH_YES)
2899 {
2900 gfc_current_locus = old_loc;
2901 /* Match the empty argument list, and add the interface to
2902 the symbol. */
2903 m = gfc_match_formal_arglist (entry, 0, 1);
2904 }
2905 else
2906 m = gfc_match_formal_arglist (entry, 0, 0);
2907
6de9cd9a
DN		 2908 if (m != MATCH_YES)
2909 return MATCH_ERROR;
2910
6de9cd9a
DN		 2911 result = NULL;
2912
2913 if (gfc_match_eos () == MATCH_YES)
2914 {
231b2fcc
TS		 2915 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2916 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
6de9cd9a
DN		 2917 return MATCH_ERROR;
2918
d198b59a 2919 entry->result = entry;
6de9cd9a
DN		 2920 }
2921 else
2922 {
3d79abbd 2923 m = match_result (proc, &result);
6de9cd9a
DN		 2924 if (m == MATCH_NO)
2925 gfc_syntax_error (ST_ENTRY);
2926 if (m != MATCH_YES)
2927 return MATCH_ERROR;
2928
231b2fcc
TS		 2929 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2930 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2931 || gfc_add_function (&entry->attr, result->name,
2932 NULL) == FAILURE)
6de9cd9a 2933 return MATCH_ERROR;
d198b59a
JJ		 2934
2935 entry->result = result;
6de9cd9a
DN		 2936 }
2937
3d79abbd 2938 if (proc->attr.recursive && result == NULL)
6de9cd9a
DN		 2939 {
2940 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2941 return MATCH_ERROR;
2942 }
6de9cd9a
DN		 2943 }
2944
2945 if (gfc_match_eos () != MATCH_YES)
2946 {
2947 gfc_syntax_error (ST_ENTRY);
2948 return MATCH_ERROR;
2949 }
2950
3d79abbd
PB		 2951 entry->attr.recursive = proc->attr.recursive;
2952 entry->attr.elemental = proc->attr.elemental;
2953 entry->attr.pure = proc->attr.pure;
6de9cd9a 2954
3d79abbd
PB		 2955 el = gfc_get_entry_list ();
2956 el->sym = entry;
2957 el->next = gfc_current_ns->entries;
2958 gfc_current_ns->entries = el;
2959 if (el->next)
2960 el->id = el->next->id + 1;
2961 else
2962 el->id = 1;
6de9cd9a 2963
3d79abbd
PB		 2964 new_st.op = EXEC_ENTRY;
2965 new_st.ext.entry = el;
2966
2967 return MATCH_YES;
6de9cd9a
DN		 2968}
2969
2970
2971/* Match a subroutine statement, including optional prefixes. */
2972
2973match
2974gfc_match_subroutine (void)
2975{
2976 char name[GFC_MAX_SYMBOL_LEN + 1];
2977 gfc_symbol *sym;
2978 match m;
2979
2980 if (gfc_current_state () != COMP_NONE
2981 && gfc_current_state () != COMP_INTERFACE
2982 && gfc_current_state () != COMP_CONTAINS)
2983 return MATCH_NO;
2984
2985 m = match_prefix (NULL);
2986 if (m != MATCH_YES)
2987 return m;
2988
2989 m = gfc_match ("subroutine% %n", name);
2990 if (m != MATCH_YES)
2991 return m;
2992
1a492601 2993 if (get_proc_name (name, &sym, false))
6de9cd9a
DN		 2994 return MATCH_ERROR;
2995 gfc_new_block = sym;
2996
231b2fcc 2997 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 2998 return MATCH_ERROR;
2999
3000 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3001 return MATCH_ERROR;
3002
3003 if (gfc_match_eos () != MATCH_YES)
3004 {
3005 gfc_syntax_error (ST_SUBROUTINE);
3006 return MATCH_ERROR;
3007 }
3008
3009 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3010 return MATCH_ERROR;
3011
3012 return MATCH_YES;
3013}
3014
3015
1f2959f0 3016/* Return nonzero if we're currently compiling a contained procedure. */
ddc9ce91
TS		 3017
3018static int
3019contained_procedure (void)
3020{
3021 gfc_state_data *s;
3022
3023 for (s=gfc_state_stack; s; s=s->previous)
3024 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3025 && s->previous != NULL
3026 && s->previous->state == COMP_CONTAINS)
3027 return 1;
3028
3029 return 0;
3030}
3031
25d8f0a2
TS		 3032/* Set the kind of each enumerator. The kind is selected such that it is
3033 interoperable with the corresponding C enumeration type, making
3034 sure that -fshort-enums is honored. */
3035
3036static void
3037set_enum_kind(void)
3038{
3039 enumerator_history *current_history = NULL;
3040 int kind;
3041 int i;
3042
3043 if (max_enum == NULL || enum_history == NULL)
3044 return;
3045
3046 if (!gfc_option.fshort_enums)
3047 return;
3048
3049 i = 0;
3050 do
3051 {
3052 kind = gfc_integer_kinds[i++].kind;
3053 }
3054 while (kind < gfc_c_int_kind
3055 && gfc_check_integer_range (max_enum->initializer->value.integer,
3056 kind) != ARITH_OK);
3057
3058 current_history = enum_history;
3059 while (current_history != NULL)
3060 {
3061 current_history->sym->ts.kind = kind;
3062 current_history = current_history->next;
3063 }
3064}
3065
6de9cd9a
DN		 3066/* Match any of the various end-block statements. Returns the type of
3067 END to the caller. The END INTERFACE, END IF, END DO and END
3068 SELECT statements cannot be replaced by a single END statement. */
3069
3070match
3071gfc_match_end (gfc_statement * st)
3072{
3073 char name[GFC_MAX_SYMBOL_LEN + 1];
3074 gfc_compile_state state;
3075 locus old_loc;
3076 const char *block_name;
3077 const char *target;
ddc9ce91 3078 int eos_ok;
6de9cd9a
DN		 3079 match m;
3080
63645982 3081 old_loc = gfc_current_locus;
6de9cd9a
DN		 3082 if (gfc_match ("end") != MATCH_YES)
3083 return MATCH_NO;
3084
3085 state = gfc_current_state ();
3086 block_name =
3087 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
3088
3089 if (state == COMP_CONTAINS)
3090 {
3091 state = gfc_state_stack->previous->state;
3092 block_name = gfc_state_stack->previous->sym == NULL ? NULL
3093 : gfc_state_stack->previous->sym->name;
3094 }
3095
3096 switch (state)
3097 {
3098 case COMP_NONE:
3099 case COMP_PROGRAM:
3100 *st = ST_END_PROGRAM;
3101 target = " program";
ddc9ce91 3102 eos_ok = 1;
6de9cd9a
DN		 3103 break;
3104
3105 case COMP_SUBROUTINE:
3106 *st = ST_END_SUBROUTINE;
3107 target = " subroutine";
ddc9ce91 3108 eos_ok = !contained_procedure ();
6de9cd9a
DN		 3109 break;
3110
3111 case COMP_FUNCTION:
3112 *st = ST_END_FUNCTION;
3113 target = " function";
ddc9ce91 3114 eos_ok = !contained_procedure ();
6de9cd9a
DN		 3115 break;
3116
3117 case COMP_BLOCK_DATA:
3118 *st = ST_END_BLOCK_DATA;
3119 target = " block data";
ddc9ce91 3120 eos_ok = 1;
6de9cd9a
DN		 3121 break;
3122
3123 case COMP_MODULE:
3124 *st = ST_END_MODULE;
3125 target = " module";
ddc9ce91 3126 eos_ok = 1;
6de9cd9a
DN		 3127 break;
3128
3129 case COMP_INTERFACE:
3130 *st = ST_END_INTERFACE;
3131 target = " interface";
ddc9ce91 3132 eos_ok = 0;
6de9cd9a
DN		 3133 break;
3134
3135 case COMP_DERIVED:
3136 *st = ST_END_TYPE;
3137 target = " type";
ddc9ce91 3138 eos_ok = 0;
6de9cd9a
DN		 3139 break;
3140
3141 case COMP_IF:
3142 *st = ST_ENDIF;
3143 target = " if";
ddc9ce91 3144 eos_ok = 0;
6de9cd9a
DN		 3145 break;
3146
3147 case COMP_DO:
3148 *st = ST_ENDDO;
3149 target = " do";
ddc9ce91 3150 eos_ok = 0;
6de9cd9a
DN		 3151 break;
3152
3153 case COMP_SELECT:
3154 *st = ST_END_SELECT;
3155 target = " select";
ddc9ce91 3156 eos_ok = 0;
6de9cd9a
DN		 3157 break;
3158
3159 case COMP_FORALL:
3160 *st = ST_END_FORALL;
3161 target = " forall";
ddc9ce91 3162 eos_ok = 0;
6de9cd9a
DN		 3163 break;
3164
3165 case COMP_WHERE:
3166 *st = ST_END_WHERE;
3167 target = " where";
ddc9ce91 3168 eos_ok = 0;
6de9cd9a
DN		 3169 break;
3170
25d8f0a2
TS		 3171 case COMP_ENUM:
3172 *st = ST_END_ENUM;
3173 target = " enum";
3174 eos_ok = 0;
3175 last_initializer = NULL;
3176 set_enum_kind ();
3177 gfc_free_enum_history ();
3178 break;
3179
6de9cd9a
DN		 3180 default:
3181 gfc_error ("Unexpected END statement at %C");
3182 goto cleanup;
3183 }
3184
3185 if (gfc_match_eos () == MATCH_YES)
3186 {
ddc9ce91 3187 if (!eos_ok)
6de9cd9a 3188 {
ddc9ce91 3189 /* We would have required END [something] */
59ce85b5
TS		 3190 gfc_error ("%s statement expected at %L",
3191 gfc_ascii_statement (*st), &old_loc);
6de9cd9a
DN		 3192 goto cleanup;
3193 }
3194
3195 return MATCH_YES;
3196 }
3197
3198 /* Verify that we've got the sort of end-block that we're expecting. */
3199 if (gfc_match (target) != MATCH_YES)
3200 {
3201 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3202 goto cleanup;
3203 }
3204
3205 /* If we're at the end, make sure a block name wasn't required. */
3206 if (gfc_match_eos () == MATCH_YES)
3207 {
3208
3209 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3210 return MATCH_YES;
3211
3212 if (gfc_current_block () == NULL)
3213 return MATCH_YES;
3214
3215 gfc_error ("Expected block name of '%s' in %s statement at %C",
3216 block_name, gfc_ascii_statement (*st));
3217
3218 return MATCH_ERROR;
3219 }
3220
3221 /* END INTERFACE has a special handler for its several possible endings. */
3222 if (*st == ST_END_INTERFACE)
3223 return gfc_match_end_interface ();
3224
3225 /* We haven't hit the end of statement, so what is left must be an end-name. */
3226 m = gfc_match_space ();
3227 if (m == MATCH_YES)
3228 m = gfc_match_name (name);
3229
3230 if (m == MATCH_NO)
3231 gfc_error ("Expected terminating name at %C");
3232 if (m != MATCH_YES)
3233 goto cleanup;
3234
3235 if (block_name == NULL)
3236 goto syntax;
3237
3238 if (strcmp (name, block_name) != 0)
3239 {
3240 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3241 gfc_ascii_statement (*st));
3242 goto cleanup;
3243 }
3244
3245 if (gfc_match_eos () == MATCH_YES)
3246 return MATCH_YES;
3247
3248syntax:
3249 gfc_syntax_error (*st);
3250
3251cleanup:
63645982 3252 gfc_current_locus = old_loc;
6de9cd9a
DN		 3253 return MATCH_ERROR;
3254}
3255
3256
3257
3258/***************** Attribute declaration statements ****************/
3259
3260/* Set the attribute of a single variable. */
3261
3262static match
3263attr_decl1 (void)
3264{
3265 char name[GFC_MAX_SYMBOL_LEN + 1];
3266 gfc_array_spec *as;
3267 gfc_symbol *sym;
3268 locus var_locus;
3269 match m;
3270
3271 as = NULL;
3272
3273 m = gfc_match_name (name);
3274 if (m != MATCH_YES)
3275 goto cleanup;
3276
3277 if (find_special (name, &sym))
3278 return MATCH_ERROR;
3279
63645982 3280 var_locus = gfc_current_locus;
6de9cd9a
DN		 3281
3282 /* Deal with possible array specification for certain attributes. */
3283 if (current_attr.dimension
3284 || current_attr.allocatable
3285 || current_attr.pointer
3286 || current_attr.target)
3287 {
3288 m = gfc_match_array_spec (&as);
3289 if (m == MATCH_ERROR)
3290 goto cleanup;
3291
3292 if (current_attr.dimension && m == MATCH_NO)
3293 {
3294 gfc_error
3295 ("Missing array specification at %L in DIMENSION statement",
3296 &var_locus);
3297 m = MATCH_ERROR;
3298 goto cleanup;
3299 }
3300
3301 if ((current_attr.allocatable || current_attr.pointer)
3302 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3303 {
3304 gfc_error ("Array specification must be deferred at %L",
3305 &var_locus);
3306 m = MATCH_ERROR;
3307 goto cleanup;
3308 }
3309 }
3310
3311 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3312 if (current_attr.dimension == 0
3313 && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3314 {
3315 m = MATCH_ERROR;
3316 goto cleanup;
3317 }
3318
3319 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3320 {
3321 m = MATCH_ERROR;
3322 goto cleanup;
3323 }
83d890b9
AL		 3324
3325 if (sym->attr.cray_pointee && sym->as != NULL)
3326 {
3327 /* Fix the array spec. */
3328 m = gfc_mod_pointee_as (sym->as);
3329 if (m == MATCH_ERROR)
3330 goto cleanup;
3331 }
6de9cd9a 3332
7114edca 3333 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
1902704e
PT		 3334 {
3335 m = MATCH_ERROR;
3336 goto cleanup;
3337 }
3338
6de9cd9a
DN		 3339 if ((current_attr.external || current_attr.intrinsic)
3340 && sym->attr.flavor != FL_PROCEDURE
231b2fcc 3341 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3342 {
3343 m = MATCH_ERROR;
3344 goto cleanup;
3345 }
3346
3347 return MATCH_YES;
3348
3349cleanup:
3350 gfc_free_array_spec (as);
3351 return m;
3352}
3353
3354
3355/* Generic attribute declaration subroutine. Used for attributes that
3356 just have a list of names. */
3357
3358static match
3359attr_decl (void)
3360{
3361 match m;
3362
3363 /* Gobble the optional double colon, by simply ignoring the result
3364 of gfc_match(). */
3365 gfc_match (" ::");
3366
3367 for (;;)
3368 {
3369 m = attr_decl1 ();
3370 if (m != MATCH_YES)
3371 break;
3372
3373 if (gfc_match_eos () == MATCH_YES)
3374 {
3375 m = MATCH_YES;
3376 break;
3377 }
3378
3379 if (gfc_match_char (',') != MATCH_YES)
3380 {
3381 gfc_error ("Unexpected character in variable list at %C");
3382 m = MATCH_ERROR;
3383 break;
3384 }
3385 }
3386
3387 return m;
3388}
3389
3390
83d890b9
AL		 3391/* This routine matches Cray Pointer declarations of the form:
3392 pointer ( <pointer>, <pointee> )
3393 or
3394 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3395 The pointer, if already declared, should be an integer. Otherwise, we
3396 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3397 be either a scalar, or an array declaration. No space is allocated for
3398 the pointee. For the statement
3399 pointer (ipt, ar(10))
3400 any subsequent uses of ar will be translated (in C-notation) as
3401 ar(i) => ((<type> *) ipt)(i)
b122dc6a 3402 After gimplification, pointee variable will disappear in the code. */
83d890b9
AL		 3403
3404static match
3405cray_pointer_decl (void)
3406{
3407 match m;
3408 gfc_array_spec *as;
3409 gfc_symbol *cptr; /* Pointer symbol. */
3410 gfc_symbol *cpte; /* Pointee symbol. */
3411 locus var_locus;
3412 bool done = false;
3413
3414 while (!done)
3415 {
3416 if (gfc_match_char ('(') != MATCH_YES)
3417 {
3418 gfc_error ("Expected '(' at %C");
3419 return MATCH_ERROR;
3420 }
3421
3422 /* Match pointer. */
3423 var_locus = gfc_current_locus;
3424 gfc_clear_attr (&current_attr);
3425 gfc_add_cray_pointer (&current_attr, &var_locus);
3426 current_ts.type = BT_INTEGER;
3427 current_ts.kind = gfc_index_integer_kind;
3428
3429 m = gfc_match_symbol (&cptr, 0);
3430 if (m != MATCH_YES)
3431 {
3432 gfc_error ("Expected variable name at %C");
3433 return m;
3434 }
3435
3436 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3437 return MATCH_ERROR;
3438
3439 gfc_set_sym_referenced (cptr);
3440
3441 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3442 {
3443 cptr->ts.type = BT_INTEGER;
3444 cptr->ts.kind = gfc_index_integer_kind;
3445 }
3446 else if (cptr->ts.type != BT_INTEGER)
3447 {
3448 gfc_error ("Cray pointer at %C must be an integer.");
3449 return MATCH_ERROR;
3450 }
3451 else if (cptr->ts.kind < gfc_index_integer_kind)
3452 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3453 " memory addresses require %d bytes.",
3454 cptr->ts.kind,
3455 gfc_index_integer_kind);
3456
3457 if (gfc_match_char (',') != MATCH_YES)
3458 {
3459 gfc_error ("Expected \",\" at %C");
3460 return MATCH_ERROR;
3461 }
3462
3463 /* Match Pointee. */
3464 var_locus = gfc_current_locus;
3465 gfc_clear_attr (&current_attr);
3466 gfc_add_cray_pointee (&current_attr, &var_locus);
3467 current_ts.type = BT_UNKNOWN;
3468 current_ts.kind = 0;
3469
3470 m = gfc_match_symbol (&cpte, 0);
3471 if (m != MATCH_YES)
3472 {
3473 gfc_error ("Expected variable name at %C");
3474 return m;
3475 }
3476
3477 /* Check for an optional array spec. */
3478 m = gfc_match_array_spec (&as);
3479 if (m == MATCH_ERROR)
3480 {
3481 gfc_free_array_spec (as);
3482 return m;
3483 }
3484 else if (m == MATCH_NO)
3485 {
3486 gfc_free_array_spec (as);
3487 as = NULL;
3488 }
3489
3490 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3491 return MATCH_ERROR;
3492
3493 gfc_set_sym_referenced (cpte);
3494
3495 if (cpte->as == NULL)
3496 {
3497 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3498 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3499 }
3500 else if (as != NULL)
3501 {
3502 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3503 gfc_free_array_spec (as);
3504 return MATCH_ERROR;
3505 }
3506
3507 as = NULL;
3508
3509 if (cpte->as != NULL)
3510 {
3511 /* Fix array spec. */
3512 m = gfc_mod_pointee_as (cpte->as);
3513 if (m == MATCH_ERROR)
3514 return m;
3515 }
3516
3517 /* Point the Pointee at the Pointer. */
b122dc6a 3518 cpte->cp_pointer = cptr;
83d890b9
AL		 3519
3520 if (gfc_match_char (')') != MATCH_YES)
3521 {
3522 gfc_error ("Expected \")\" at %C");
3523 return MATCH_ERROR;
3524 }
3525 m = gfc_match_char (',');
3526 if (m != MATCH_YES)
3527 done = true; /* Stop searching for more declarations. */
3528
3529 }
3530
3531 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3532 || gfc_match_eos () != MATCH_YES)
3533 {
3534 gfc_error ("Expected \",\" or end of statement at %C");
3535 return MATCH_ERROR;
3536 }
3537 return MATCH_YES;
3538}
3539
3540
6de9cd9a
DN		 3541match
3542gfc_match_external (void)
3543{
3544
3545 gfc_clear_attr (&current_attr);
1902704e 3546 current_attr.external = 1;
6de9cd9a
DN		 3547
3548 return attr_decl ();
3549}
3550
3551
3552
3553match
3554gfc_match_intent (void)
3555{
3556 sym_intent intent;
3557
3558 intent = match_intent_spec ();
3559 if (intent == INTENT_UNKNOWN)
3560 return MATCH_ERROR;
3561
3562 gfc_clear_attr (&current_attr);
1902704e 3563 current_attr.intent = intent;
6de9cd9a
DN		 3564
3565 return attr_decl ();
3566}
3567
3568
3569match
3570gfc_match_intrinsic (void)
3571{
3572
3573 gfc_clear_attr (&current_attr);
1902704e 3574 current_attr.intrinsic = 1;
6de9cd9a
DN		 3575
3576 return attr_decl ();
3577}
3578
3579
3580match
3581gfc_match_optional (void)
3582{
3583
3584 gfc_clear_attr (&current_attr);
1902704e 3585 current_attr.optional = 1;
6de9cd9a
DN		 3586
3587 return attr_decl ();
3588}
3589
3590
3591match
3592gfc_match_pointer (void)
3593{
83d890b9
AL		 3594 gfc_gobble_whitespace ();
3595 if (gfc_peek_char () == '(')
3596 {
3597 if (!gfc_option.flag_cray_pointer)
3598 {
3599 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3600 " flag.");
3601 return MATCH_ERROR;
3602 }
3603 return cray_pointer_decl ();
3604 }
3605 else
3606 {
3607 gfc_clear_attr (&current_attr);
1902704e 3608 current_attr.pointer = 1;
83d890b9
AL		 3609
3610 return attr_decl ();
3611 }
6de9cd9a
DN		 3612}
3613
3614
3615match
3616gfc_match_allocatable (void)
3617{
3618
3619 gfc_clear_attr (&current_attr);
1902704e 3620 current_attr.allocatable = 1;
6de9cd9a
DN		 3621
3622 return attr_decl ();
3623}
3624
3625
3626match
3627gfc_match_dimension (void)
3628{
3629
3630 gfc_clear_attr (&current_attr);
1902704e 3631 current_attr.dimension = 1;
6de9cd9a
DN		 3632
3633 return attr_decl ();
3634}
3635
3636
3637match
3638gfc_match_target (void)
3639{
3640
3641 gfc_clear_attr (&current_attr);
1902704e 3642 current_attr.target = 1;
6de9cd9a
DN		 3643
3644 return attr_decl ();
3645}
3646
3647
3648/* Match the list of entities being specified in a PUBLIC or PRIVATE
3649 statement. */
3650
3651static match
3652access_attr_decl (gfc_statement st)
3653{
3654 char name[GFC_MAX_SYMBOL_LEN + 1];
3655 interface_type type;
3656 gfc_user_op *uop;
3657 gfc_symbol *sym;
3658 gfc_intrinsic_op operator;
3659 match m;
3660
3661 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3662 goto done;
3663
3664 for (;;)
3665 {
3666 m = gfc_match_generic_spec (&type, name, &operator);
3667 if (m == MATCH_NO)
3668 goto syntax;
3669 if (m == MATCH_ERROR)
3670 return MATCH_ERROR;
3671
3672 switch (type)
3673 {
3674 case INTERFACE_NAMELESS:
3675 goto syntax;
3676
3677 case INTERFACE_GENERIC:
3678 if (gfc_get_symbol (name, NULL, &sym))
3679 goto done;
3680
3681 if (gfc_add_access (&sym->attr,
3682 (st ==
3683 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
231b2fcc 3684 sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3685 return MATCH_ERROR;
3686
3687 break;
3688
3689 case INTERFACE_INTRINSIC_OP:
3690 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3691 {
3692 gfc_current_ns->operator_access[operator] =
3693 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3694 }
3695 else
3696 {
3697 gfc_error ("Access specification of the %s operator at %C has "
3698 "already been specified", gfc_op2string (operator));
3699 goto done;
3700 }
3701
3702 break;
3703
3704 case INTERFACE_USER_OP:
3705 uop = gfc_get_uop (name);
3706
3707 if (uop->access == ACCESS_UNKNOWN)
3708 {
3709 uop->access =
3710 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3711 }
3712 else
3713 {
3714 gfc_error
3715 ("Access specification of the .%s. operator at %C has "
3716 "already been specified", sym->name);
3717 goto done;
3718 }
3719
3720 break;
3721 }
3722
3723 if (gfc_match_char (',') == MATCH_NO)
3724 break;
3725 }
3726
3727 if (gfc_match_eos () != MATCH_YES)
3728 goto syntax;
3729 return MATCH_YES;
3730
3731syntax:
3732 gfc_syntax_error (st);
3733
3734done:
3735 return MATCH_ERROR;
3736}
3737
3738
3739/* The PRIVATE statement is a bit weird in that it can be a attribute
3740 declaration, but also works as a standlone statement inside of a
3741 type declaration or a module. */
3742
3743match
3744gfc_match_private (gfc_statement * st)
3745{
3746
3747 if (gfc_match ("private") != MATCH_YES)
3748 return MATCH_NO;
3749
3750 if (gfc_current_state () == COMP_DERIVED)
3751 {
3752 if (gfc_match_eos () == MATCH_YES)
3753 {
3754 *st = ST_PRIVATE;
3755 return MATCH_YES;
3756 }
3757
3758 gfc_syntax_error (ST_PRIVATE);
3759 return MATCH_ERROR;
3760 }
3761
3762 if (gfc_match_eos () == MATCH_YES)
3763 {
3764 *st = ST_PRIVATE;
3765 return MATCH_YES;
3766 }
3767
3768 *st = ST_ATTR_DECL;
3769 return access_attr_decl (ST_PRIVATE);
3770}
3771
3772
3773match
3774gfc_match_public (gfc_statement * st)
3775{
3776
3777 if (gfc_match ("public") != MATCH_YES)
3778 return MATCH_NO;
3779
3780 if (gfc_match_eos () == MATCH_YES)
3781 {
3782 *st = ST_PUBLIC;
3783 return MATCH_YES;
3784 }
3785
3786 *st = ST_ATTR_DECL;
3787 return access_attr_decl (ST_PUBLIC);
3788}
3789
3790
3791/* Workhorse for gfc_match_parameter. */
3792
3793static match
3794do_parm (void)
3795{
3796 gfc_symbol *sym;
3797 gfc_expr *init;
3798 match m;
3799
3800 m = gfc_match_symbol (&sym, 0);
3801 if (m == MATCH_NO)
3802 gfc_error ("Expected variable name at %C in PARAMETER statement");
3803
3804 if (m != MATCH_YES)
3805 return m;
3806
3807 if (gfc_match_char ('=') == MATCH_NO)
3808 {
3809 gfc_error ("Expected = sign in PARAMETER statement at %C");
3810 return MATCH_ERROR;
3811 }
3812
3813 m = gfc_match_init_expr (&init);
3814 if (m == MATCH_NO)
3815 gfc_error ("Expected expression at %C in PARAMETER statement");
3816 if (m != MATCH_YES)
3817 return m;
3818
3819 if (sym->ts.type == BT_UNKNOWN
3820 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3821 {
3822 m = MATCH_ERROR;
3823 goto cleanup;
3824 }
3825
3826 if (gfc_check_assign_symbol (sym, init) == FAILURE
231b2fcc 3827 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3828 {
3829 m = MATCH_ERROR;
3830 goto cleanup;
3831 }
3832
7e2eba4b
DE		 3833 if (sym->ts.type == BT_CHARACTER
3834 && sym->ts.cl != NULL
3835 && sym->ts.cl->length != NULL
3836 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3837 && init->expr_type == EXPR_CONSTANT
3838 && init->ts.type == BT_CHARACTER
3839 && init->ts.kind == 1)
3840 gfc_set_constant_character_len (
3841 mpz_get_si (sym->ts.cl->length->value.integer), init);
3842
6de9cd9a
DN		 3843 sym->value = init;
3844 return MATCH_YES;
3845
3846cleanup:
3847 gfc_free_expr (init);
3848 return m;
3849}
3850
3851
3852/* Match a parameter statement, with the weird syntax that these have. */
3853
3854match
3855gfc_match_parameter (void)
3856{
3857 match m;
3858
3859 if (gfc_match_char ('(') == MATCH_NO)
3860 return MATCH_NO;
3861
3862 for (;;)
3863 {
3864 m = do_parm ();
3865 if (m != MATCH_YES)
3866 break;
3867
3868 if (gfc_match (" )%t") == MATCH_YES)
3869 break;
3870
3871 if (gfc_match_char (',') != MATCH_YES)
3872 {
3873 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3874 m = MATCH_ERROR;
3875 break;
3876 }
3877 }
3878
3879 return m;
3880}
3881
3882
3883/* Save statements have a special syntax. */
3884
3885match
3886gfc_match_save (void)
3887{
9056bd70
TS		 3888 char n[GFC_MAX_SYMBOL_LEN+1];
3889 gfc_common_head *c;
6de9cd9a
DN		 3890 gfc_symbol *sym;
3891 match m;
3892
3893 if (gfc_match_eos () == MATCH_YES)
3894 {
3895 if (gfc_current_ns->seen_save)
3896 {
09e87839
AL		 3897 if (gfc_notify_std (GFC_STD_LEGACY,
3898 "Blanket SAVE statement at %C follows previous "
3899 "SAVE statement")
3900 == FAILURE)
3901 return MATCH_ERROR;
6de9cd9a
DN		 3902 }
3903
3904 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3905 return MATCH_YES;
3906 }
3907
3908 if (gfc_current_ns->save_all)
3909 {
09e87839
AL		 3910 if (gfc_notify_std (GFC_STD_LEGACY,
3911 "SAVE statement at %C follows blanket SAVE statement")
3912 == FAILURE)
3913 return MATCH_ERROR;
6de9cd9a
DN		 3914 }
3915
3916 gfc_match (" ::");
3917
3918 for (;;)
3919 {
3920 m = gfc_match_symbol (&sym, 0);
3921 switch (m)
3922 {
3923 case MATCH_YES:
231b2fcc
TS		 3924 if (gfc_add_save (&sym->attr, sym->name,
3925 &gfc_current_locus) == FAILURE)
6de9cd9a
DN		 3926 return MATCH_ERROR;
3927 goto next_item;
3928
3929 case MATCH_NO:
3930 break;
3931
3932 case MATCH_ERROR:
3933 return MATCH_ERROR;
3934 }
3935
9056bd70 3936 m = gfc_match (" / %n /", &n);
6de9cd9a
DN		 3937 if (m == MATCH_ERROR)
3938 return MATCH_ERROR;
3939 if (m == MATCH_NO)
3940 goto syntax;
3941
53814b8f 3942 c = gfc_get_common (n, 0);
9056bd70
TS		 3943 c->saved = 1;
3944
6de9cd9a
DN		 3945 gfc_current_ns->seen_save = 1;
3946
3947 next_item:
3948 if (gfc_match_eos () == MATCH_YES)
3949 break;
3950 if (gfc_match_char (',') != MATCH_YES)
3951 goto syntax;
3952 }
3953
3954 return MATCH_YES;
3955
3956syntax:
3957 gfc_error ("Syntax error in SAVE statement at %C");
3958 return MATCH_ERROR;
3959}
3960
3961
775e6c3a
TB		 3962match
3963gfc_match_volatile (void)
3964{
3965 gfc_symbol *sym;
3966 match m;
3967
3968 if (gfc_notify_std (GFC_STD_F2003,
3969 "Fortran 2003: VOLATILE statement at %C")
3970 == FAILURE)
3971 return MATCH_ERROR;
3972
3973 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3974 {
3975 return MATCH_ERROR;
3976 }
3977
3978 if (gfc_match_eos () == MATCH_YES)
3979 goto syntax;
3980
3981 for(;;)
3982 {
3983 m = gfc_match_symbol (&sym, 0);
3984 switch (m)
3985 {
3986 case MATCH_YES:
3987 if (gfc_add_volatile (&sym->attr, sym->name,
3988 &gfc_current_locus) == FAILURE)
3989 return MATCH_ERROR;
3990 goto next_item;
3991
3992 case MATCH_NO:
3993 break;
3994
3995 case MATCH_ERROR:
3996 return MATCH_ERROR;
3997 }
3998
3999 next_item:
4000 if (gfc_match_eos () == MATCH_YES)
4001 break;
4002 if (gfc_match_char (',') != MATCH_YES)
4003 goto syntax;
4004 }
4005
4006 return MATCH_YES;
4007
4008syntax:
4009 gfc_error ("Syntax error in VOLATILE statement at %C");
4010 return MATCH_ERROR;
4011}
4012
4013
4014
6de9cd9a
DN		 4015/* Match a module procedure statement. Note that we have to modify
4016 symbols in the parent's namespace because the current one was there
49de9e73 4017 to receive symbols that are in an interface's formal argument list. */
6de9cd9a
DN		 4018
4019match
4020gfc_match_modproc (void)
4021{
4022 char name[GFC_MAX_SYMBOL_LEN + 1];
4023 gfc_symbol *sym;
4024 match m;
4025
4026 if (gfc_state_stack->state != COMP_INTERFACE
4027 || gfc_state_stack->previous == NULL
4028 || current_interface.type == INTERFACE_NAMELESS)
4029 {
4030 gfc_error
4031 ("MODULE PROCEDURE at %C must be in a generic module interface");
4032 return MATCH_ERROR;
4033 }
4034
4035 for (;;)
4036 {
4037 m = gfc_match_name (name);
4038 if (m == MATCH_NO)
4039 goto syntax;
4040 if (m != MATCH_YES)
4041 return MATCH_ERROR;
4042
4043 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4044 return MATCH_ERROR;
4045
4046 if (sym->attr.proc != PROC_MODULE
231b2fcc
TS		 4047 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4048 sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4049 return MATCH_ERROR;
4050
4051 if (gfc_add_interface (sym) == FAILURE)
4052 return MATCH_ERROR;
4053
4054 if (gfc_match_eos () == MATCH_YES)
4055 break;
4056 if (gfc_match_char (',') != MATCH_YES)
4057 goto syntax;
4058 }
4059
4060 return MATCH_YES;
4061
4062syntax:
4063 gfc_syntax_error (ST_MODULE_PROC);
4064 return MATCH_ERROR;
4065}
4066
4067
4068/* Match the beginning of a derived type declaration. If a type name
4069 was the result of a function, then it is possible to have a symbol
4070 already to be known as a derived type yet have no components. */
4071
4072match
4073gfc_match_derived_decl (void)
4074{
4075 char name[GFC_MAX_SYMBOL_LEN + 1];
4076 symbol_attribute attr;
4077 gfc_symbol *sym;
4078 match m;
4079
4080 if (gfc_current_state () == COMP_DERIVED)
4081 return MATCH_NO;
4082
4083 gfc_clear_attr (&attr);
4084
4085loop:
4086 if (gfc_match (" , private") == MATCH_YES)
4087 {
4088 if (gfc_find_state (COMP_MODULE) == FAILURE)
4089 {
4090 gfc_error
4091 ("Derived type at %C can only be PRIVATE within a MODULE");
4092 return MATCH_ERROR;
4093 }
4094
231b2fcc 4095 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
6de9cd9a
DN		 4096 return MATCH_ERROR;
4097 goto loop;
4098 }
4099
4100 if (gfc_match (" , public") == MATCH_YES)
4101 {
4102 if (gfc_find_state (COMP_MODULE) == FAILURE)
4103 {
4104 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4105 return MATCH_ERROR;
4106 }
4107
231b2fcc 4108 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
6de9cd9a
DN		 4109 return MATCH_ERROR;
4110 goto loop;
4111 }
4112
4113 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4114 {
4115 gfc_error ("Expected :: in TYPE definition at %C");
4116 return MATCH_ERROR;
4117 }
4118
4119 m = gfc_match (" %n%t", name);
4120 if (m != MATCH_YES)
4121 return m;
4122
4123 /* Make sure the name isn't the name of an intrinsic type. The
4124 'double precision' type doesn't get past the name matcher. */
4125 if (strcmp (name, "integer") == 0
4126 || strcmp (name, "real") == 0
4127 || strcmp (name, "character") == 0
4128 || strcmp (name, "logical") == 0
4129 || strcmp (name, "complex") == 0)
4130 {
4131 gfc_error
4132 ("Type name '%s' at %C cannot be the same as an intrinsic type",
4133 name);
4134 return MATCH_ERROR;
4135 }
4136
4137 if (gfc_get_symbol (name, NULL, &sym))
4138 return MATCH_ERROR;
4139
4140 if (sym->ts.type != BT_UNKNOWN)
4141 {
4142 gfc_error ("Derived type name '%s' at %C already has a basic type "
4143 "of %s", sym->name, gfc_typename (&sym->ts));
4144 return MATCH_ERROR;
4145 }
4146
4147 /* The symbol may already have the derived attribute without the
4148 components. The ways this can happen is via a function
4149 definition, an INTRINSIC statement or a subtype in another
4150 derived type that is a pointer. The first part of the AND clause
f7b529fa 4151 is true if a the symbol is not the return value of a function. */
6de9cd9a 4152 if (sym->attr.flavor != FL_DERIVED
231b2fcc 4153 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4154 return MATCH_ERROR;
4155
4156 if (sym->components != NULL)
4157 {
4158 gfc_error
4159 ("Derived type definition of '%s' at %C has already been defined",
4160 sym->name);
4161 return MATCH_ERROR;
4162 }
4163
4164 if (attr.access != ACCESS_UNKNOWN
231b2fcc 4165 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4166 return MATCH_ERROR;
4167
4168 gfc_new_block = sym;
4169
4170 return MATCH_YES;
4171}
83d890b9
AL		 4172
4173
4174/* Cray Pointees can be declared as:
4175 pointer (ipt, a (n,m,...,*))
4176 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4177 cheat and set a constant bound of 1 for the last dimension, if this
4178 is the case. Since there is no bounds-checking for Cray Pointees,
4179 this will be okay. */
4180
4181try
4182gfc_mod_pointee_as (gfc_array_spec *as)
4183{
4184 as->cray_pointee = true; /* This will be useful to know later. */
4185 if (as->type == AS_ASSUMED_SIZE)
4186 {
4187 as->type = AS_EXPLICIT;
4188 as->upper[as->rank - 1] = gfc_int_expr (1);
4189 as->cp_was_assumed = true;
4190 }
4191 else if (as->type == AS_ASSUMED_SHAPE)
4192 {
4193 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4194 return MATCH_ERROR;
4195 }
4196 return MATCH_YES;
4197}
25d8f0a2
TS		 4198
4199
4200/* Match the enum definition statement, here we are trying to match
4201 the first line of enum definition statement.
4202 Returns MATCH_YES if match is found. */
4203
4204match
4205gfc_match_enum (void)
4206{
4207 match m;
4208
4209 m = gfc_match_eos ();
4210 if (m != MATCH_YES)
4211 return m;
4212
4213 if (gfc_notify_std (GFC_STD_F2003,
aa4183d8 4214 "Fortran 2003: ENUM AND ENUMERATOR at %C")
25d8f0a2
TS		 4215 == FAILURE)
4216 return MATCH_ERROR;
4217
4218 return MATCH_YES;
4219}
4220
4221
4222/* Match the enumerator definition statement. */
4223
4224match
4225gfc_match_enumerator_def (void)
4226{
4227 match m;
4228 int elem;
4229
4230 gfc_clear_ts (&current_ts);
4231
4232 m = gfc_match (" enumerator");
4233 if (m != MATCH_YES)
4234 return m;
4235
4236 if (gfc_current_state () != COMP_ENUM)
4237 {
4238 gfc_error ("ENUM definition statement expected before %C");
4239 gfc_free_enum_history ();
4240 return MATCH_ERROR;
4241 }
4242
4243 (&current_ts)->type = BT_INTEGER;
4244 (&current_ts)->kind = gfc_c_int_kind;
4245
4246 m = match_attr_spec ();
4247 if (m == MATCH_ERROR)
4248 {
4249 m = MATCH_NO;
4250 goto cleanup;
4251 }
4252
4253 elem = 1;
4254 for (;;)
4255 {
4256 m = variable_decl (elem++);
4257 if (m == MATCH_ERROR)
4258 goto cleanup;
4259 if (m == MATCH_NO)
4260 break;
4261
4262 if (gfc_match_eos () == MATCH_YES)
4263 goto cleanup;
4264 if (gfc_match_char (',') != MATCH_YES)
4265 break;
4266 }
4267
4268 if (gfc_current_state () == COMP_ENUM)
4269 {
4270 gfc_free_enum_history ();
4271 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4272 m = MATCH_ERROR;
4273 }
4274
4275cleanup:
4276 gfc_free_array_spec (current_as);
4277 current_as = NULL;
4278 return m;
4279
4280}
4281
GNU Compiler Collection
This page took 1.100911 seconds and 5 git commands to generate.