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