]> 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
[multiple changes]
[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
294fbfc8 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);
636dff67 627 if (i == 0)
9e35b386
EE		 628 goto end;
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
831d7813 815/* Function to create and update the enumerator history
25d8f0a2
TS		 816 using the information passed as arguments.
817 Pointer "max_enum" is also updated, to point to
818 enum history node containing largest initializer.
819
820 SYM points to the symbol node of enumerator.
821 INIT points to its enumerator value. */
822
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
845 if (mpz_cmp (max_enum->initializer->value.integer,
846 new_enum_history->initializer->value.integer) < 0)
636dff67 847 max_enum = new_enum_history;
25d8f0a2
TS		 848 }
849}
850
851
852/* Function to free enum kind history. */
853
854void
636dff67 855gfc_free_enum_history (void)
25d8f0a2
TS		 856{
857 enumerator_history *current = enum_history;
858 enumerator_history *next;
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.");
1218
1219 /* Fix the array spec. */
1220 m = gfc_mod_pointee_as (sym->as);
1221 if (m == MATCH_ERROR)
1222 goto cleanup;
1223 }
1224 }
1225 goto cleanup;
1226 }
1227 else
1228 {
1229 gfc_free_array_spec (cp_as);
1230 }
1231 }
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;
1297
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
DN		 1517{
1518 int i, kind, seen_length;
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
1649 {
1650 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1651 cl->length = len;
1652 else
1653 {
1654 gfc_free_expr (len);
1655 cl->length = gfc_int_expr (0);
1656 }
1657 }
1658
1659 ts->cl = cl;
1660 ts->kind = kind;
1661
1662 return MATCH_YES;
1663}
1664
1665
1666/* Matches a type specification. If successful, sets the ts structure
1667 to the matched specification. This is necessary for FUNCTION and
1668 IMPLICIT statements.
1669
e5ddaa24
TS		 1670 If implicit_flag is nonzero, then we don't check for the optional
1671 kind specification. Not doing so is needed for matching an IMPLICIT
6de9cd9a
DN		 1672 statement correctly. */
1673
e5ddaa24 1674static match
636dff67 1675match_type_spec (gfc_typespec *ts, int implicit_flag)
6de9cd9a
DN		 1676{
1677 char name[GFC_MAX_SYMBOL_LEN + 1];
1678 gfc_symbol *sym;
1679 match m;
0ff0dfbf 1680 int c;
6de9cd9a
DN		 1681
1682 gfc_clear_ts (ts);
1683
5f700e6d
AL		 1684 if (gfc_match (" byte") == MATCH_YES)
1685 {
1686 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1687 == FAILURE)
1688 return MATCH_ERROR;
1689
1690 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1691 {
1692 gfc_error ("BYTE type used at %C "
1693 "is not available on the target machine");
1694 return MATCH_ERROR;
1695 }
1696
1697 ts->type = BT_INTEGER;
1698 ts->kind = 1;
1699 return MATCH_YES;
1700 }
1701
6de9cd9a
DN		 1702 if (gfc_match (" integer") == MATCH_YES)
1703 {
1704 ts->type = BT_INTEGER;
9d64df18 1705 ts->kind = gfc_default_integer_kind;
6de9cd9a
DN		 1706 goto get_kind;
1707 }
1708
1709 if (gfc_match (" character") == MATCH_YES)
1710 {
1711 ts->type = BT_CHARACTER;
e5ddaa24
TS		 1712 if (implicit_flag == 0)
1713 return match_char_spec (ts);
1714 else
1715 return MATCH_YES;
6de9cd9a
DN		 1716 }
1717
1718 if (gfc_match (" real") == MATCH_YES)
1719 {
1720 ts->type = BT_REAL;
9d64df18 1721 ts->kind = gfc_default_real_kind;
6de9cd9a
DN		 1722 goto get_kind;
1723 }
1724
1725 if (gfc_match (" double precision") == MATCH_YES)
1726 {
1727 ts->type = BT_REAL;
9d64df18 1728 ts->kind = gfc_default_double_kind;
6de9cd9a
DN		 1729 return MATCH_YES;
1730 }
1731
1732 if (gfc_match (" complex") == MATCH_YES)
1733 {
1734 ts->type = BT_COMPLEX;
9d64df18 1735 ts->kind = gfc_default_complex_kind;
6de9cd9a
DN		 1736 goto get_kind;
1737 }
1738
1739 if (gfc_match (" double complex") == MATCH_YES)
1740 {
df8652dc
SK		 1741 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1742 "conform to the Fortran 95 standard") == FAILURE)
1743 return MATCH_ERROR;
1744
6de9cd9a 1745 ts->type = BT_COMPLEX;
9d64df18 1746 ts->kind = gfc_default_double_kind;
6de9cd9a
DN		 1747 return MATCH_YES;
1748 }
1749
1750 if (gfc_match (" logical") == MATCH_YES)
1751 {
1752 ts->type = BT_LOGICAL;
9d64df18 1753 ts->kind = gfc_default_logical_kind;
6de9cd9a
DN		 1754 goto get_kind;
1755 }
1756
1757 m = gfc_match (" type ( %n )", name);
1758 if (m != MATCH_YES)
1759 return m;
1760
1761 /* Search for the name but allow the components to be defined later. */
1762 if (gfc_get_ha_symbol (name, &sym))
1763 {
1764 gfc_error ("Type name '%s' at %C is ambiguous", name);
1765 return MATCH_ERROR;
1766 }
1767
1768 if (sym->attr.flavor != FL_DERIVED
231b2fcc 1769 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 1770 return MATCH_ERROR;
1771
1772 ts->type = BT_DERIVED;
1773 ts->kind = 0;
1774 ts->derived = sym;
1775
1776 return MATCH_YES;
1777
1778get_kind:
1779 /* For all types except double, derived and character, look for an
1780 optional kind specifier. MATCH_NO is actually OK at this point. */
e5ddaa24 1781 if (implicit_flag == 1)
6de9cd9a
DN		 1782 return MATCH_YES;
1783
0ff0dfbf
TS		 1784 if (gfc_current_form == FORM_FREE)
1785 {
1786 c = gfc_peek_char();
1787 if (!gfc_is_whitespace(c) && c != '*' && c != '('
636dff67 1788 && c != ':' && c != ',')
0ff0dfbf
TS		 1789 return MATCH_NO;
1790 }
1791
6de9cd9a
DN		 1792 m = gfc_match_kind_spec (ts);
1793 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1794 m = gfc_match_old_kind_spec (ts);
1795
1796 if (m == MATCH_NO)
1797 m = MATCH_YES; /* No kind specifier found. */
1798
1799 return m;
1800}
1801
1802
e5ddaa24
TS		 1803/* Match an IMPLICIT NONE statement. Actually, this statement is
1804 already matched in parse.c, or we would not end up here in the
1805 first place. So the only thing we need to check, is if there is
1806 trailing garbage. If not, the match is successful. */
1807
1808match
1809gfc_match_implicit_none (void)
1810{
e5ddaa24
TS		 1811 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1812}
1813
1814
1815/* Match the letter range(s) of an IMPLICIT statement. */
1816
1817static match
1107b970 1818match_implicit_range (void)
e5ddaa24
TS		 1819{
1820 int c, c1, c2, inner;
1821 locus cur_loc;
1822
1823 cur_loc = gfc_current_locus;
1824
1825 gfc_gobble_whitespace ();
1826 c = gfc_next_char ();
1827 if (c != '(')
1828 {
1829 gfc_error ("Missing character range in IMPLICIT at %C");
1830 goto bad;
1831 }
1832
1833 inner = 1;
1834 while (inner)
1835 {
1836 gfc_gobble_whitespace ();
1837 c1 = gfc_next_char ();
1838 if (!ISALPHA (c1))
1839 goto bad;
1840
1841 gfc_gobble_whitespace ();
1842 c = gfc_next_char ();
1843
1844 switch (c)
1845 {
1846 case ')':
1847 inner = 0; /* Fall through */
1848
1849 case ',':
1850 c2 = c1;
1851 break;
1852
1853 case '-':
1854 gfc_gobble_whitespace ();
1855 c2 = gfc_next_char ();
1856 if (!ISALPHA (c2))
1857 goto bad;
1858
1859 gfc_gobble_whitespace ();
1860 c = gfc_next_char ();
1861
1862 if ((c != ',') && (c != ')'))
1863 goto bad;
1864 if (c == ')')
1865 inner = 0;
1866
1867 break;
1868
1869 default:
1870 goto bad;
1871 }
1872
1873 if (c1 > c2)
1874 {
1875 gfc_error ("Letters must be in alphabetic order in "
1876 "IMPLICIT statement at %C");
1877 goto bad;
1878 }
1879
1880 /* See if we can add the newly matched range to the pending
636dff67
SK		 1881 implicits from this IMPLICIT statement. We do not check for
1882 conflicts with whatever earlier IMPLICIT statements may have
1883 set. This is done when we've successfully finished matching
1884 the current one. */
1107b970 1885 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
e5ddaa24
TS		 1886 goto bad;
1887 }
1888
1889 return MATCH_YES;
1890
1891bad:
1892 gfc_syntax_error (ST_IMPLICIT);
1893
1894 gfc_current_locus = cur_loc;
1895 return MATCH_ERROR;
1896}
1897
1898
1899/* Match an IMPLICIT statement, storing the types for
1900 gfc_set_implicit() if the statement is accepted by the parser.
1901 There is a strange looking, but legal syntactic construction
1902 possible. It looks like:
1903
1904 IMPLICIT INTEGER (a-b) (c-d)
1905
1906 This is legal if "a-b" is a constant expression that happens to
1907 equal one of the legal kinds for integers. The real problem
1908 happens with an implicit specification that looks like:
1909
1910 IMPLICIT INTEGER (a-b)
1911
1912 In this case, a typespec matcher that is "greedy" (as most of the
1913 matchers are) gobbles the character range as a kindspec, leaving
1914 nothing left. We therefore have to go a bit more slowly in the
1915 matching process by inhibiting the kindspec checking during
1916 typespec matching and checking for a kind later. */
1917
1918match
1919gfc_match_implicit (void)
1920{
1921 gfc_typespec ts;
1922 locus cur_loc;
1923 int c;
1924 match m;
1925
1926 /* We don't allow empty implicit statements. */
1927 if (gfc_match_eos () == MATCH_YES)
1928 {
1929 gfc_error ("Empty IMPLICIT statement at %C");
1930 return MATCH_ERROR;
1931 }
1932
e5ddaa24
TS		 1933 do
1934 {
1107b970
PB		 1935 /* First cleanup. */
1936 gfc_clear_new_implicit ();
1937
e5ddaa24
TS		 1938 /* A basic type is mandatory here. */
1939 m = match_type_spec (&ts, 1);
1940 if (m == MATCH_ERROR)
1941 goto error;
1942 if (m == MATCH_NO)
1943 goto syntax;
1944
1945 cur_loc = gfc_current_locus;
1107b970 1946 m = match_implicit_range ();
e5ddaa24
TS		 1947
1948 if (m == MATCH_YES)
1949 {
1107b970 1950 /* We may have <TYPE> (<RANGE>). */
e5ddaa24
TS		 1951 gfc_gobble_whitespace ();
1952 c = gfc_next_char ();
1953 if ((c == '\n') || (c == ','))
1107b970
PB		 1954 {
1955 /* Check for CHARACTER with no length parameter. */
1956 if (ts.type == BT_CHARACTER && !ts.cl)
1957 {
9d64df18 1958 ts.kind = gfc_default_character_kind;
1107b970
PB		 1959 ts.cl = gfc_get_charlen ();
1960 ts.cl->next = gfc_current_ns->cl_list;
1961 gfc_current_ns->cl_list = ts.cl;
1962 ts.cl->length = gfc_int_expr (1);
1963 }
1964
1965 /* Record the Successful match. */
1966 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1967 return MATCH_ERROR;
1968 continue;
1969 }
e5ddaa24
TS		 1970
1971 gfc_current_locus = cur_loc;
1972 }
1973
1107b970
PB		 1974 /* Discard the (incorrectly) matched range. */
1975 gfc_clear_new_implicit ();
1976
1977 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1978 if (ts.type == BT_CHARACTER)
1979 m = match_char_spec (&ts);
1980 else
e5ddaa24 1981 {
1107b970 1982 m = gfc_match_kind_spec (&ts);
e5ddaa24 1983 if (m == MATCH_NO)
1107b970
PB		 1984 {
1985 m = gfc_match_old_kind_spec (&ts);
1986 if (m == MATCH_ERROR)
1987 goto error;
1988 if (m == MATCH_NO)
1989 goto syntax;
1990 }
e5ddaa24 1991 }
1107b970
PB		 1992 if (m == MATCH_ERROR)
1993 goto error;
e5ddaa24 1994
1107b970 1995 m = match_implicit_range ();
e5ddaa24
TS		 1996 if (m == MATCH_ERROR)
1997 goto error;
1998 if (m == MATCH_NO)
1999 goto syntax;
2000
2001 gfc_gobble_whitespace ();
2002 c = gfc_next_char ();
2003 if ((c != '\n') && (c != ','))
2004 goto syntax;
2005
1107b970
PB		 2006 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2007 return MATCH_ERROR;
e5ddaa24
TS		 2008 }
2009 while (c == ',');
2010
1107b970 2011 return MATCH_YES;
e5ddaa24
TS		 2012
2013syntax:
2014 gfc_syntax_error (ST_IMPLICIT);
2015
2016error:
2017 return MATCH_ERROR;
2018}
2019
8998be20
TB		 2020match
2021gfc_match_import (void)
2022{
2023 char name[GFC_MAX_SYMBOL_LEN + 1];
2024 match m;
2025 gfc_symbol *sym;
2026 gfc_symtree *st;
2027
2028 if (gfc_current_ns->proc_name == NULL ||
2029 gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2030 {
2031 gfc_error ("IMPORT statement at %C only permitted in "
2032 "an INTERFACE body");
2033 return MATCH_ERROR;
2034 }
2035
636dff67 2036 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
8998be20
TB		 2037 == FAILURE)
2038 return MATCH_ERROR;
2039
2040 if (gfc_match_eos () == MATCH_YES)
2041 {
2042 /* All host variables should be imported. */
2043 gfc_current_ns->has_import_set = 1;
2044 return MATCH_YES;
2045 }
2046
2047 if (gfc_match (" ::") == MATCH_YES)
2048 {
2049 if (gfc_match_eos () == MATCH_YES)
636dff67
SK		 2050 {
2051 gfc_error ("Expecting list of named entities at %C");
2052 return MATCH_ERROR;
2053 }
8998be20
TB		 2054 }
2055
2056 for(;;)
2057 {
2058 m = gfc_match (" %n", name);
2059 switch (m)
2060 {
2061 case MATCH_YES:
36d3fb4c
PT		 2062 if (gfc_current_ns->parent != NULL
2063 && gfc_find_symbol (name, gfc_current_ns->parent,
2064 1, &sym))
2065 {
2066 gfc_error ("Type name '%s' at %C is ambiguous", name);
2067 return MATCH_ERROR;
2068 }
2069 else if (gfc_current_ns->proc_name->ns->parent != NULL
2070 && gfc_find_symbol (name,
2071 gfc_current_ns->proc_name->ns->parent,
2072 1, &sym))
636dff67
SK		 2073 {
2074 gfc_error ("Type name '%s' at %C is ambiguous", name);
2075 return MATCH_ERROR;
2076 }
2077
2078 if (sym == NULL)
2079 {
2080 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2081 "at %C - does not exist.", name);
2082 return MATCH_ERROR;
2083 }
2084
2085 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2086 {
2087 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2088 "at %C.", name);
2089 goto next_item;
2090 }
2091
2092 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2093 st->n.sym = sym;
2094 sym->refs++;
2095 sym->ns = gfc_current_ns;
8998be20
TB		 2096
2097 goto next_item;
2098
2099 case MATCH_NO:
2100 break;
2101
2102 case MATCH_ERROR:
2103 return MATCH_ERROR;
2104 }
2105
2106 next_item:
2107 if (gfc_match_eos () == MATCH_YES)
2108 break;
2109 if (gfc_match_char (',') != MATCH_YES)
2110 goto syntax;
2111 }
2112
2113 return MATCH_YES;
2114
2115syntax:
2116 gfc_error ("Syntax error in IMPORT statement at %C");
2117 return MATCH_ERROR;
2118}
e5ddaa24 2119
6de9cd9a
DN		 2120/* Matches an attribute specification including array specs. If
2121 successful, leaves the variables current_attr and current_as
2122 holding the specification. Also sets the colon_seen variable for
2123 later use by matchers associated with initializations.
2124
2125 This subroutine is a little tricky in the sense that we don't know
2126 if we really have an attr-spec until we hit the double colon.
2127 Until that time, we can only return MATCH_NO. This forces us to
2128 check for duplicate specification at this level. */
2129
2130static match
2131match_attr_spec (void)
2132{
6de9cd9a
DN		 2133 /* Modifiers that can exist in a type statement. */
2134 typedef enum
2135 { GFC_DECL_BEGIN = 0,
2136 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2137 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
ee7e677f
TB		 2138 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2139 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2140 DECL_COLON, DECL_NONE,
6de9cd9a
DN		 2141 GFC_DECL_END /* Sentinel */
2142 }
2143 decl_types;
2144
2145/* GFC_DECL_END is the sentinel, index starts at 0. */
2146#define NUM_DECL GFC_DECL_END
2147
2148 static mstring decls[] = {
2149 minit (", allocatable", DECL_ALLOCATABLE),
2150 minit (", dimension", DECL_DIMENSION),
2151 minit (", external", DECL_EXTERNAL),
2152 minit (", intent ( in )", DECL_IN),
2153 minit (", intent ( out )", DECL_OUT),
2154 minit (", intent ( in out )", DECL_INOUT),
2155 minit (", intrinsic", DECL_INTRINSIC),
2156 minit (", optional", DECL_OPTIONAL),
2157 minit (", parameter", DECL_PARAMETER),
2158 minit (", pointer", DECL_POINTER),
ee7e677f 2159 minit (", protected", DECL_PROTECTED),
6de9cd9a
DN		 2160 minit (", private", DECL_PRIVATE),
2161 minit (", public", DECL_PUBLIC),
2162 minit (", save", DECL_SAVE),
2163 minit (", target", DECL_TARGET),
06469efd 2164 minit (", value", DECL_VALUE),
775e6c3a 2165 minit (", volatile", DECL_VOLATILE),
6de9cd9a
DN		 2166 minit ("::", DECL_COLON),
2167 minit (NULL, DECL_NONE)
2168 };
2169
2170 locus start, seen_at[NUM_DECL];
2171 int seen[NUM_DECL];
2172 decl_types d;
2173 const char *attr;
2174 match m;
2175 try t;
2176
2177 gfc_clear_attr (&current_attr);
63645982 2178 start = gfc_current_locus;
6de9cd9a
DN		 2179
2180 current_as = NULL;
2181 colon_seen = 0;
2182
2183 /* See if we get all of the keywords up to the final double colon. */
2184 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2185 seen[d] = 0;
2186
2187 for (;;)
2188 {
2189 d = (decl_types) gfc_match_strings (decls);
2190 if (d == DECL_NONE || d == DECL_COLON)
2191 break;
25d8f0a2 2192
6de9cd9a 2193 seen[d]++;
63645982 2194 seen_at[d] = gfc_current_locus;
6de9cd9a
DN		 2195
2196 if (d == DECL_DIMENSION)
2197 {
2198 m = gfc_match_array_spec (&current_as);
2199
2200 if (m == MATCH_NO)
2201 {
2202 gfc_error ("Missing dimension specification at %C");
2203 m = MATCH_ERROR;
2204 }
2205
2206 if (m == MATCH_ERROR)
2207 goto cleanup;
2208 }
2209 }
2210
2211 /* No double colon, so assume that we've been looking at something
2212 else the whole time. */
2213 if (d == DECL_NONE)
2214 {
2215 m = MATCH_NO;
2216 goto cleanup;
2217 }
2218
2219 /* Since we've seen a double colon, we have to be looking at an
2220 attr-spec. This means that we can now issue errors. */
2221 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2222 if (seen[d] > 1)
2223 {
2224 switch (d)
2225 {
2226 case DECL_ALLOCATABLE:
2227 attr = "ALLOCATABLE";
2228 break;
2229 case DECL_DIMENSION:
2230 attr = "DIMENSION";
2231 break;
2232 case DECL_EXTERNAL:
2233 attr = "EXTERNAL";
2234 break;
2235 case DECL_IN:
2236 attr = "INTENT (IN)";
2237 break;
2238 case DECL_OUT:
2239 attr = "INTENT (OUT)";
2240 break;
2241 case DECL_INOUT:
2242 attr = "INTENT (IN OUT)";
2243 break;
2244 case DECL_INTRINSIC:
2245 attr = "INTRINSIC";
2246 break;
2247 case DECL_OPTIONAL:
2248 attr = "OPTIONAL";
2249 break;
2250 case DECL_PARAMETER:
2251 attr = "PARAMETER";
2252 break;
2253 case DECL_POINTER:
2254 attr = "POINTER";
2255 break;
ee7e677f
TB		 2256 case DECL_PROTECTED:
2257 attr = "PROTECTED";
2258 break;
6de9cd9a
DN		 2259 case DECL_PRIVATE:
2260 attr = "PRIVATE";
2261 break;
2262 case DECL_PUBLIC:
2263 attr = "PUBLIC";
2264 break;
2265 case DECL_SAVE:
2266 attr = "SAVE";
2267 break;
2268 case DECL_TARGET:
2269 attr = "TARGET";
2270 break;
06469efd
PT		 2271 case DECL_VALUE:
2272 attr = "VALUE";
2273 break;
775e6c3a
TB		 2274 case DECL_VOLATILE:
2275 attr = "VOLATILE";
2276 break;
6de9cd9a
DN		 2277 default:
2278 attr = NULL; /* This shouldn't happen */
2279 }
2280
2281 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2282 m = MATCH_ERROR;
2283 goto cleanup;
2284 }
2285
2286 /* Now that we've dealt with duplicate attributes, add the attributes
2287 to the current attribute. */
2288 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2289 {
2290 if (seen[d] == 0)
2291 continue;
2292
2293 if (gfc_current_state () == COMP_DERIVED
2294 && d != DECL_DIMENSION && d != DECL_POINTER
2295 && d != DECL_COLON && d != DECL_NONE)
2296 {
5046aff5
PT		 2297 if (d == DECL_ALLOCATABLE)
2298 {
636dff67
SK		 2299 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2300 "attribute at %C in a TYPE definition")
2301 == FAILURE)
5046aff5
PT		 2302 {
2303 m = MATCH_ERROR;
2304 goto cleanup;
2305 }
636dff67
SK		 2306 }
2307 else
5046aff5
PT		 2308 {
2309 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2310 &seen_at[d]);
2311 m = MATCH_ERROR;
2312 goto cleanup;
2313 }
6de9cd9a
DN		 2314 }
2315
4213f93b 2316 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
636dff67 2317 && gfc_current_state () != COMP_MODULE)
4213f93b
PT		 2318 {
2319 if (d == DECL_PRIVATE)
2320 attr = "PRIVATE";
2321 else
2322 attr = "PUBLIC";
2323
2324 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2325 attr, &seen_at[d]);
2326 m = MATCH_ERROR;
2327 goto cleanup;
2328 }
2329
6de9cd9a
DN		 2330 switch (d)
2331 {
2332 case DECL_ALLOCATABLE:
2333 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2334 break;
2335
2336 case DECL_DIMENSION:
231b2fcc 2337 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
6de9cd9a
DN		 2338 break;
2339
2340 case DECL_EXTERNAL:
2341 t = gfc_add_external (&current_attr, &seen_at[d]);
2342 break;
2343
2344 case DECL_IN:
2345 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2346 break;
2347
2348 case DECL_OUT:
2349 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2350 break;
2351
2352 case DECL_INOUT:
2353 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2354 break;
2355
2356 case DECL_INTRINSIC:
2357 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2358 break;
2359
2360 case DECL_OPTIONAL:
2361 t = gfc_add_optional (&current_attr, &seen_at[d]);
2362 break;
2363
2364 case DECL_PARAMETER:
231b2fcc 2365 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
6de9cd9a
DN		 2366 break;
2367
2368 case DECL_POINTER:
2369 t = gfc_add_pointer (&current_attr, &seen_at[d]);
2370 break;
2371
ee7e677f
TB		 2372 case DECL_PROTECTED:
2373 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2374 {
2375 gfc_error ("PROTECTED at %C only allowed in specification "
2376 "part of a module");
2377 t = FAILURE;
2378 break;
2379 }
2380
636dff67
SK		 2381 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2382 "attribute at %C")
ee7e677f
TB		 2383 == FAILURE)
2384 t = FAILURE;
2385 else
2386 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
2387 break;
2388
6de9cd9a 2389 case DECL_PRIVATE:
231b2fcc
TS		 2390 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2391 &seen_at[d]);
6de9cd9a
DN		 2392 break;
2393
2394 case DECL_PUBLIC:
231b2fcc
TS		 2395 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2396 &seen_at[d]);
6de9cd9a
DN		 2397 break;
2398
2399 case DECL_SAVE:
231b2fcc 2400 t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
6de9cd9a
DN		 2401 break;
2402
2403 case DECL_TARGET:
2404 t = gfc_add_target (&current_attr, &seen_at[d]);
2405 break;
2406
06469efd 2407 case DECL_VALUE:
636dff67
SK		 2408 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2409 "at %C")
06469efd
PT		 2410 == FAILURE)
2411 t = FAILURE;
2412 else
2413 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
2414 break;
2415
775e6c3a
TB		 2416 case DECL_VOLATILE:
2417 if (gfc_notify_std (GFC_STD_F2003,
636dff67 2418 "Fortran 2003: VOLATILE attribute at %C")
775e6c3a
TB		 2419 == FAILURE)
2420 t = FAILURE;
2421 else
2422 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2423 break;
2424
6de9cd9a
DN		 2425 default:
2426 gfc_internal_error ("match_attr_spec(): Bad attribute");
2427 }
2428
2429 if (t == FAILURE)
2430 {
2431 m = MATCH_ERROR;
2432 goto cleanup;
2433 }
2434 }
2435
2436 colon_seen = 1;
2437 return MATCH_YES;
2438
2439cleanup:
63645982 2440 gfc_current_locus = start;
6de9cd9a
DN		 2441 gfc_free_array_spec (current_as);
2442 current_as = NULL;
2443 return m;
2444}
2445
2446
2447/* Match a data declaration statement. */
2448
2449match
2450gfc_match_data_decl (void)
2451{
2452 gfc_symbol *sym;
2453 match m;
949d5b72 2454 int elem;
6de9cd9a 2455
e5ddaa24 2456 m = match_type_spec (&current_ts, 0);
6de9cd9a
DN		 2457 if (m != MATCH_YES)
2458 return m;
2459
2460 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2461 {
2462 sym = gfc_use_derived (current_ts.derived);
2463
2464 if (sym == NULL)
2465 {
2466 m = MATCH_ERROR;
2467 goto cleanup;
2468 }
2469
2470 current_ts.derived = sym;
2471 }
2472
2473 m = match_attr_spec ();
2474 if (m == MATCH_ERROR)
2475 {
2476 m = MATCH_NO;
2477 goto cleanup;
2478 }
2479
2480 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2481 {
2482
2483 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2484 goto ok;
2485
976e21f6 2486 gfc_find_symbol (current_ts.derived->name,
636dff67 2487 current_ts.derived->ns->parent, 1, &sym);
6de9cd9a 2488
976e21f6 2489 /* Any symbol that we find had better be a type definition
636dff67 2490 which has its components defined. */
976e21f6 2491 if (sym != NULL && sym->attr.flavor == FL_DERIVED
636dff67 2492 && current_ts.derived->components != NULL)
6de9cd9a
DN		 2493 goto ok;
2494
976e21f6
PT		 2495 /* Now we have an error, which we signal, and then fix up
2496 because the knock-on is plain and simple confusing. */
2497 gfc_error_now ("Derived type at %C has not been previously defined "
636dff67 2498 "and so cannot appear in a derived type definition");
976e21f6
PT		 2499 current_attr.pointer = 1;
2500 goto ok;
6de9cd9a
DN		 2501 }
2502
2503ok:
2504 /* If we have an old-style character declaration, and no new-style
2505 attribute specifications, then there a comma is optional between
2506 the type specification and the variable list. */
2507 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2508 gfc_match_char (',');
2509
949d5b72
PT		 2510 /* Give the types/attributes to symbols that follow. Give the element
2511 a number so that repeat character length expressions can be copied. */
2512 elem = 1;
6de9cd9a
DN		 2513 for (;;)
2514 {
949d5b72 2515 m = variable_decl (elem++);
6de9cd9a
DN		 2516 if (m == MATCH_ERROR)
2517 goto cleanup;
2518 if (m == MATCH_NO)
2519 break;
2520
2521 if (gfc_match_eos () == MATCH_YES)
2522 goto cleanup;
2523 if (gfc_match_char (',') != MATCH_YES)
2524 break;
2525 }
2526
8f81c3c6
PT		 2527 if (gfc_error_flag_test () == 0)
2528 gfc_error ("Syntax error in data declaration at %C");
6de9cd9a
DN		 2529 m = MATCH_ERROR;
2530
a9f6f1f2
JD		 2531 gfc_free_data_all (gfc_current_ns);
2532
6de9cd9a
DN		 2533cleanup:
2534 gfc_free_array_spec (current_as);
2535 current_as = NULL;
2536 return m;
2537}
2538
2539
2540/* Match a prefix associated with a function or subroutine
2541 declaration. If the typespec pointer is nonnull, then a typespec
2542 can be matched. Note that if nothing matches, MATCH_YES is
2543 returned (the null string was matched). */
2544
2545static match
636dff67 2546match_prefix (gfc_typespec *ts)
6de9cd9a
DN		 2547{
2548 int seen_type;
2549
2550 gfc_clear_attr (&current_attr);
2551 seen_type = 0;
2552
2553loop:
2554 if (!seen_type && ts != NULL
e5ddaa24 2555 && match_type_spec (ts, 0) == MATCH_YES
6de9cd9a
DN		 2556 && gfc_match_space () == MATCH_YES)
2557 {
2558
2559 seen_type = 1;
2560 goto loop;
2561 }
2562
2563 if (gfc_match ("elemental% ") == MATCH_YES)
2564 {
2565 if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
2566 return MATCH_ERROR;
2567
2568 goto loop;
2569 }
2570
2571 if (gfc_match ("pure% ") == MATCH_YES)
2572 {
2573 if (gfc_add_pure (&current_attr, NULL) == FAILURE)
2574 return MATCH_ERROR;
2575
2576 goto loop;
2577 }
2578
2579 if (gfc_match ("recursive% ") == MATCH_YES)
2580 {
2581 if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
2582 return MATCH_ERROR;
2583
2584 goto loop;
2585 }
2586
2587 /* At this point, the next item is not a prefix. */
2588 return MATCH_YES;
2589}
2590
2591
2592/* Copy attributes matched by match_prefix() to attributes on a symbol. */
2593
2594static try
636dff67 2595copy_prefix (symbol_attribute *dest, locus *where)
6de9cd9a 2596{
6de9cd9a
DN		 2597 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2598 return FAILURE;
2599
2600 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2601 return FAILURE;
2602
2603 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2604 return FAILURE;
2605
2606 return SUCCESS;
2607}
2608
2609
2610/* Match a formal argument list. */
2611
2612match
636dff67 2613gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
6de9cd9a
DN		 2614{
2615 gfc_formal_arglist *head, *tail, *p, *q;
2616 char name[GFC_MAX_SYMBOL_LEN + 1];
2617 gfc_symbol *sym;
2618 match m;
2619
2620 head = tail = NULL;
2621
2622 if (gfc_match_char ('(') != MATCH_YES)
2623 {
2624 if (null_flag)
2625 goto ok;
2626 return MATCH_NO;
2627 }
2628
2629 if (gfc_match_char (')') == MATCH_YES)
2630 goto ok;
2631
2632 for (;;)
2633 {
2634 if (gfc_match_char ('*') == MATCH_YES)
2635 sym = NULL;
2636 else
2637 {
2638 m = gfc_match_name (name);
2639 if (m != MATCH_YES)
2640 goto cleanup;
2641
2642 if (gfc_get_symbol (name, NULL, &sym))
2643 goto cleanup;
2644 }
2645
2646 p = gfc_get_formal_arglist ();
2647
2648 if (head == NULL)
2649 head = tail = p;
2650 else
2651 {
2652 tail->next = p;
2653 tail = p;
2654 }
2655
2656 tail->sym = sym;
2657
2658 /* We don't add the VARIABLE flavor because the name could be a
636dff67
SK		 2659 dummy procedure. We don't apply these attributes to formal
2660 arguments of statement functions. */
6de9cd9a 2661 if (sym != NULL && !st_flag
231b2fcc 2662 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
6de9cd9a
DN		 2663 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2664 {
2665 m = MATCH_ERROR;
2666 goto cleanup;
2667 }
2668
2669 /* The name of a program unit can be in a different namespace,
636dff67
SK		 2670 so check for it explicitly. After the statement is accepted,
2671 the name is checked for especially in gfc_get_symbol(). */
6de9cd9a
DN		 2672 if (gfc_new_block != NULL && sym != NULL
2673 && strcmp (sym->name, gfc_new_block->name) == 0)
2674 {
2675 gfc_error ("Name '%s' at %C is the name of the procedure",
2676 sym->name);
2677 m = MATCH_ERROR;
2678 goto cleanup;
2679 }
2680
2681 if (gfc_match_char (')') == MATCH_YES)
2682 goto ok;
2683
2684 m = gfc_match_char (',');
2685 if (m != MATCH_YES)
2686 {
2687 gfc_error ("Unexpected junk in formal argument list at %C");
2688 goto cleanup;
2689 }
2690 }
2691
2692ok:
2693 /* Check for duplicate symbols in the formal argument list. */
2694 if (head != NULL)
2695 {
2696 for (p = head; p->next; p = p->next)
2697 {
2698 if (p->sym == NULL)
2699 continue;
2700
2701 for (q = p->next; q; q = q->next)
2702 if (p->sym == q->sym)
2703 {
636dff67
SK		 2704 gfc_error ("Duplicate symbol '%s' in formal argument list "
2705 "at %C", p->sym->name);
6de9cd9a
DN		 2706
2707 m = MATCH_ERROR;
2708 goto cleanup;
2709 }
2710 }
2711 }
2712
2713 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2714 FAILURE)
2715 {
2716 m = MATCH_ERROR;
2717 goto cleanup;
2718 }
2719
2720 return MATCH_YES;
2721
2722cleanup:
2723 gfc_free_formal_arglist (head);
2724 return m;
2725}
2726
2727
2728/* Match a RESULT specification following a function declaration or
2729 ENTRY statement. Also matches the end-of-statement. */
2730
2731static match
636dff67 2732match_result (gfc_symbol * function, gfc_symbol **result)
6de9cd9a
DN		 2733{
2734 char name[GFC_MAX_SYMBOL_LEN + 1];
2735 gfc_symbol *r;
2736 match m;
2737
2738 if (gfc_match (" result (") != MATCH_YES)
2739 return MATCH_NO;
2740
2741 m = gfc_match_name (name);
2742 if (m != MATCH_YES)
2743 return m;
2744
2745 if (gfc_match (" )%t") != MATCH_YES)
2746 {
2747 gfc_error ("Unexpected junk following RESULT variable at %C");
2748 return MATCH_ERROR;
2749 }
2750
2751 if (strcmp (function->name, name) == 0)
2752 {
636dff67 2753 gfc_error ("RESULT variable at %C must be different than function name");
6de9cd9a
DN		 2754 return MATCH_ERROR;
2755 }
2756
2757 if (gfc_get_symbol (name, NULL, &r))
2758 return MATCH_ERROR;
2759
231b2fcc
TS		 2760 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2761 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
6de9cd9a
DN		 2762 return MATCH_ERROR;
2763
2764 *result = r;
2765
2766 return MATCH_YES;
2767}
2768
2769
2770/* Match a function declaration. */
2771
2772match
2773gfc_match_function_decl (void)
2774{
2775 char name[GFC_MAX_SYMBOL_LEN + 1];
2776 gfc_symbol *sym, *result;
2777 locus old_loc;
2778 match m;
2779
2780 if (gfc_current_state () != COMP_NONE
2781 && gfc_current_state () != COMP_INTERFACE
2782 && gfc_current_state () != COMP_CONTAINS)
2783 return MATCH_NO;
2784
2785 gfc_clear_ts (&current_ts);
2786
63645982 2787 old_loc = gfc_current_locus;
6de9cd9a
DN		 2788
2789 m = match_prefix (&current_ts);
2790 if (m != MATCH_YES)
2791 {
63645982 2792 gfc_current_locus = old_loc;
6de9cd9a
DN		 2793 return m;
2794 }
2795
2796 if (gfc_match ("function% %n", name) != MATCH_YES)
2797 {
63645982 2798 gfc_current_locus = old_loc;
6de9cd9a
DN		 2799 return MATCH_NO;
2800 }
2801
1a492601 2802 if (get_proc_name (name, &sym, false))
6de9cd9a
DN		 2803 return MATCH_ERROR;
2804 gfc_new_block = sym;
2805
2806 m = gfc_match_formal_arglist (sym, 0, 0);
2807 if (m == MATCH_NO)
2b9a33ae
TS		 2808 {
2809 gfc_error ("Expected formal argument list in function "
636dff67 2810 "definition at %C");
2b9a33ae
TS		 2811 m = MATCH_ERROR;
2812 goto cleanup;
2813 }
6de9cd9a
DN		 2814 else if (m == MATCH_ERROR)
2815 goto cleanup;
2816
2817 result = NULL;
2818
2819 if (gfc_match_eos () != MATCH_YES)
2820 {
2821 /* See if a result variable is present. */
2822 m = match_result (sym, &result);
2823 if (m == MATCH_NO)
2824 gfc_error ("Unexpected junk after function declaration at %C");
2825
2826 if (m != MATCH_YES)
2827 {
2828 m = MATCH_ERROR;
2829 goto cleanup;
2830 }
2831 }
2832
2833 /* Make changes to the symbol. */
2834 m = MATCH_ERROR;
2835
231b2fcc 2836 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 2837 goto cleanup;
2838
2839 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2840 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2841 goto cleanup;
2842
636dff67
SK		 2843 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
2844 && !sym->attr.implicit_type)
6de9cd9a
DN		 2845 {
2846 gfc_error ("Function '%s' at %C already has a type of %s", name,
2847 gfc_basic_typename (sym->ts.type));
2848 goto cleanup;
2849 }
2850
2851 if (result == NULL)
2852 {
2853 sym->ts = current_ts;
2854 sym->result = sym;
2855 }
2856 else
2857 {
2858 result->ts = current_ts;
2859 sym->result = result;
2860 }
2861
2862 return MATCH_YES;
2863
2864cleanup:
63645982 2865 gfc_current_locus = old_loc;
6de9cd9a
DN		 2866 return m;
2867}
2868
636dff67
SK		 2869
2870/* This is mostly a copy of parse.c(add_global_procedure) but modified to
2871 pass the name of the entry, rather than the gfc_current_block name, and
2872 to return false upon finding an existing global entry. */
68ea355b
PT		 2873
2874static bool
636dff67 2875add_global_entry (const char *name, int sub)
68ea355b
PT		 2876{
2877 gfc_gsymbol *s;
2878
2879 s = gfc_get_gsymbol(name);
2880
2881 if (s->defined
636dff67
SK		 2882 || (s->type != GSYM_UNKNOWN
2883 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
68ea355b
PT		 2884 global_used(s, NULL);
2885 else
2886 {
2887 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2888 s->where = gfc_current_locus;
2889 s->defined = 1;
2890 return true;
2891 }
2892 return false;
2893}
6de9cd9a 2894
636dff67 2895
6de9cd9a
DN		 2896/* Match an ENTRY statement. */
2897
2898match
2899gfc_match_entry (void)
2900{
3d79abbd
PB		 2901 gfc_symbol *proc;
2902 gfc_symbol *result;
2903 gfc_symbol *entry;
6de9cd9a
DN		 2904 char name[GFC_MAX_SYMBOL_LEN + 1];
2905 gfc_compile_state state;
2906 match m;
3d79abbd 2907 gfc_entry_list *el;
c96cfa49 2908 locus old_loc;
1a492601 2909 bool module_procedure;
6de9cd9a
DN		 2910
2911 m = gfc_match_name (name);
2912 if (m != MATCH_YES)
2913 return m;
2914
3d79abbd 2915 state = gfc_current_state ();
4c93c95a 2916 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
3d79abbd 2917 {
4c93c95a
FXC		 2918 switch (state)
2919 {
2920 case COMP_PROGRAM:
2921 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2922 break;
2923 case COMP_MODULE:
2924 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2925 break;
2926 case COMP_BLOCK_DATA:
636dff67
SK		 2927 gfc_error ("ENTRY statement at %C cannot appear within "
2928 "a BLOCK DATA");
4c93c95a
FXC		 2929 break;
2930 case COMP_INTERFACE:
636dff67
SK		 2931 gfc_error ("ENTRY statement at %C cannot appear within "
2932 "an INTERFACE");
4c93c95a
FXC		 2933 break;
2934 case COMP_DERIVED:
636dff67
SK		 2935 gfc_error ("ENTRY statement at %C cannot appear within "
2936 "a DERIVED TYPE block");
4c93c95a
FXC		 2937 break;
2938 case COMP_IF:
636dff67
SK		 2939 gfc_error ("ENTRY statement at %C cannot appear within "
2940 "an IF-THEN block");
4c93c95a
FXC		 2941 break;
2942 case COMP_DO:
636dff67
SK		 2943 gfc_error ("ENTRY statement at %C cannot appear within "
2944 "a DO block");
4c93c95a
FXC		 2945 break;
2946 case COMP_SELECT:
636dff67
SK		 2947 gfc_error ("ENTRY statement at %C cannot appear within "
2948 "a SELECT block");
4c93c95a
FXC		 2949 break;
2950 case COMP_FORALL:
636dff67
SK		 2951 gfc_error ("ENTRY statement at %C cannot appear within "
2952 "a FORALL block");
4c93c95a
FXC		 2953 break;
2954 case COMP_WHERE:
636dff67
SK		 2955 gfc_error ("ENTRY statement at %C cannot appear within "
2956 "a WHERE block");
4c93c95a
FXC		 2957 break;
2958 case COMP_CONTAINS:
636dff67
SK		 2959 gfc_error ("ENTRY statement at %C cannot appear within "
2960 "a contained subprogram");
4c93c95a
FXC		 2961 break;
2962 default:
2963 gfc_internal_error ("gfc_match_entry(): Bad state");
2964 }
3d79abbd
PB		 2965 return MATCH_ERROR;
2966 }
2967
1a492601 2968 module_procedure = gfc_current_ns->parent != NULL
636dff67
SK		 2969 && gfc_current_ns->parent->proc_name
2970 && gfc_current_ns->parent->proc_name->attr.flavor
2971 == FL_MODULE;
1a492601 2972
3d79abbd
PB		 2973 if (gfc_current_ns->parent != NULL
2974 && gfc_current_ns->parent->proc_name
1a492601 2975 && !module_procedure)
3d79abbd
PB		 2976 {
2977 gfc_error("ENTRY statement at %C cannot appear in a "
2978 "contained procedure");
2979 return MATCH_ERROR;
2980 }
2981
1a492601
PT		 2982 /* Module function entries need special care in get_proc_name
2983 because previous references within the function will have
2984 created symbols attached to the current namespace. */
2985 if (get_proc_name (name, &entry,
2986 gfc_current_ns->parent != NULL
2987 && module_procedure
2988 && gfc_current_ns->proc_name->attr.function))
6de9cd9a
DN		 2989 return MATCH_ERROR;
2990
3d79abbd
PB		 2991 proc = gfc_current_block ();
2992
2993 if (state == COMP_SUBROUTINE)
6de9cd9a 2994 {
231b2fcc 2995 /* An entry in a subroutine. */
68ea355b
PT		 2996 if (!add_global_entry (name, 1))
2997 return MATCH_ERROR;
2998
6de9cd9a
DN		 2999 m = gfc_match_formal_arglist (entry, 0, 1);
3000 if (m != MATCH_YES)
3001 return MATCH_ERROR;
3002
231b2fcc
TS		 3003 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3004 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
6de9cd9a 3005 return MATCH_ERROR;
3d79abbd
PB		 3006 }
3007 else
3008 {
c96cfa49 3009 /* An entry in a function.
636dff67
SK		 3010 We need to take special care because writing
3011 ENTRY f()
3012 as
3013 ENTRY f
3014 is allowed, whereas
3015 ENTRY f() RESULT (r)
3016 can't be written as
3017 ENTRY f RESULT (r). */
68ea355b
PT		 3018 if (!add_global_entry (name, 0))
3019 return MATCH_ERROR;
3020
c96cfa49
TS		 3021 old_loc = gfc_current_locus;
3022 if (gfc_match_eos () == MATCH_YES)
3023 {
3024 gfc_current_locus = old_loc;
3025 /* Match the empty argument list, and add the interface to
3026 the symbol. */
3027 m = gfc_match_formal_arglist (entry, 0, 1);
3028 }
3029 else
3030 m = gfc_match_formal_arglist (entry, 0, 0);
3031
6de9cd9a
DN		 3032 if (m != MATCH_YES)
3033 return MATCH_ERROR;
3034
6de9cd9a
DN		 3035 result = NULL;
3036
3037 if (gfc_match_eos () == MATCH_YES)
3038 {
231b2fcc
TS		 3039 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3040 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
6de9cd9a
DN		 3041 return MATCH_ERROR;
3042
d198b59a 3043 entry->result = entry;
6de9cd9a
DN		 3044 }
3045 else
3046 {
3d79abbd 3047 m = match_result (proc, &result);
6de9cd9a
DN		 3048 if (m == MATCH_NO)
3049 gfc_syntax_error (ST_ENTRY);
3050 if (m != MATCH_YES)
3051 return MATCH_ERROR;
3052
231b2fcc
TS		 3053 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3054 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
636dff67
SK		 3055 || gfc_add_function (&entry->attr, result->name, NULL)
3056 == FAILURE)
6de9cd9a 3057 return MATCH_ERROR;
d198b59a
JJ		 3058
3059 entry->result = result;
6de9cd9a 3060 }
6de9cd9a
DN		 3061 }
3062
3063 if (gfc_match_eos () != MATCH_YES)
3064 {
3065 gfc_syntax_error (ST_ENTRY);
3066 return MATCH_ERROR;
3067 }
3068
3d79abbd
PB		 3069 entry->attr.recursive = proc->attr.recursive;
3070 entry->attr.elemental = proc->attr.elemental;
3071 entry->attr.pure = proc->attr.pure;
6de9cd9a 3072
3d79abbd
PB		 3073 el = gfc_get_entry_list ();
3074 el->sym = entry;
3075 el->next = gfc_current_ns->entries;
3076 gfc_current_ns->entries = el;
3077 if (el->next)
3078 el->id = el->next->id + 1;
3079 else
3080 el->id = 1;
6de9cd9a 3081
3d79abbd
PB		 3082 new_st.op = EXEC_ENTRY;
3083 new_st.ext.entry = el;
3084
3085 return MATCH_YES;
6de9cd9a
DN		 3086}
3087
3088
3089/* Match a subroutine statement, including optional prefixes. */
3090
3091match
3092gfc_match_subroutine (void)
3093{
3094 char name[GFC_MAX_SYMBOL_LEN + 1];
3095 gfc_symbol *sym;
3096 match m;
3097
3098 if (gfc_current_state () != COMP_NONE
3099 && gfc_current_state () != COMP_INTERFACE
3100 && gfc_current_state () != COMP_CONTAINS)
3101 return MATCH_NO;
3102
3103 m = match_prefix (NULL);
3104 if (m != MATCH_YES)
3105 return m;
3106
3107 m = gfc_match ("subroutine% %n", name);
3108 if (m != MATCH_YES)
3109 return m;
3110
1a492601 3111 if (get_proc_name (name, &sym, false))
6de9cd9a
DN		 3112 return MATCH_ERROR;
3113 gfc_new_block = sym;
3114
231b2fcc 3115 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3116 return MATCH_ERROR;
3117
3118 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3119 return MATCH_ERROR;
3120
3121 if (gfc_match_eos () != MATCH_YES)
3122 {
3123 gfc_syntax_error (ST_SUBROUTINE);
3124 return MATCH_ERROR;
3125 }
3126
3127 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3128 return MATCH_ERROR;
3129
3130 return MATCH_YES;
3131}
3132
3133
1f2959f0 3134/* Return nonzero if we're currently compiling a contained procedure. */
ddc9ce91
TS		 3135
3136static int
3137contained_procedure (void)
3138{
3139 gfc_state_data *s;
3140
3141 for (s=gfc_state_stack; s; s=s->previous)
3142 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
636dff67 3143 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
ddc9ce91
TS		 3144 return 1;
3145
3146 return 0;
3147}
3148
25d8f0a2
TS		 3149/* Set the kind of each enumerator. The kind is selected such that it is
3150 interoperable with the corresponding C enumeration type, making
3151 sure that -fshort-enums is honored. */
3152
3153static void
3154set_enum_kind(void)
3155{
3156 enumerator_history *current_history = NULL;
3157 int kind;
3158 int i;
3159
3160 if (max_enum == NULL || enum_history == NULL)
3161 return;
3162
3163 if (!gfc_option.fshort_enums)
3164 return;
3165
3166 i = 0;
3167 do
3168 {
3169 kind = gfc_integer_kinds[i++].kind;
3170 }
3171 while (kind < gfc_c_int_kind
3172 && gfc_check_integer_range (max_enum->initializer->value.integer,
3173 kind) != ARITH_OK);
3174
3175 current_history = enum_history;
3176 while (current_history != NULL)
3177 {
3178 current_history->sym->ts.kind = kind;
3179 current_history = current_history->next;
3180 }
3181}
3182
636dff67 3183
6de9cd9a
DN		 3184/* Match any of the various end-block statements. Returns the type of
3185 END to the caller. The END INTERFACE, END IF, END DO and END
3186 SELECT statements cannot be replaced by a single END statement. */
3187
3188match
636dff67 3189gfc_match_end (gfc_statement *st)
6de9cd9a
DN		 3190{
3191 char name[GFC_MAX_SYMBOL_LEN + 1];
3192 gfc_compile_state state;
3193 locus old_loc;
3194 const char *block_name;
3195 const char *target;
ddc9ce91 3196 int eos_ok;
6de9cd9a
DN		 3197 match m;
3198
63645982 3199 old_loc = gfc_current_locus;
6de9cd9a
DN		 3200 if (gfc_match ("end") != MATCH_YES)
3201 return MATCH_NO;
3202
3203 state = gfc_current_state ();
636dff67
SK		 3204 block_name = gfc_current_block () == NULL
3205 ? NULL : gfc_current_block ()->name;
6de9cd9a
DN		 3206
3207 if (state == COMP_CONTAINS)
3208 {
3209 state = gfc_state_stack->previous->state;
636dff67
SK		 3210 block_name = gfc_state_stack->previous->sym == NULL
3211 ? NULL : gfc_state_stack->previous->sym->name;
6de9cd9a
DN		 3212 }
3213
3214 switch (state)
3215 {
3216 case COMP_NONE:
3217 case COMP_PROGRAM:
3218 *st = ST_END_PROGRAM;
3219 target = " program";
ddc9ce91 3220 eos_ok = 1;
6de9cd9a
DN		 3221 break;
3222
3223 case COMP_SUBROUTINE:
3224 *st = ST_END_SUBROUTINE;
3225 target = " subroutine";
ddc9ce91 3226 eos_ok = !contained_procedure ();
6de9cd9a
DN		 3227 break;
3228
3229 case COMP_FUNCTION:
3230 *st = ST_END_FUNCTION;
3231 target = " function";
ddc9ce91 3232 eos_ok = !contained_procedure ();
6de9cd9a
DN		 3233 break;
3234
3235 case COMP_BLOCK_DATA:
3236 *st = ST_END_BLOCK_DATA;
3237 target = " block data";
ddc9ce91 3238 eos_ok = 1;
6de9cd9a
DN		 3239 break;
3240
3241 case COMP_MODULE:
3242 *st = ST_END_MODULE;
3243 target = " module";
ddc9ce91 3244 eos_ok = 1;
6de9cd9a
DN		 3245 break;
3246
3247 case COMP_INTERFACE:
3248 *st = ST_END_INTERFACE;
3249 target = " interface";
ddc9ce91 3250 eos_ok = 0;
6de9cd9a
DN		 3251 break;
3252
3253 case COMP_DERIVED:
3254 *st = ST_END_TYPE;
3255 target = " type";
ddc9ce91 3256 eos_ok = 0;
6de9cd9a
DN		 3257 break;
3258
3259 case COMP_IF:
3260 *st = ST_ENDIF;
3261 target = " if";
ddc9ce91 3262 eos_ok = 0;
6de9cd9a
DN		 3263 break;
3264
3265 case COMP_DO:
3266 *st = ST_ENDDO;
3267 target = " do";
ddc9ce91 3268 eos_ok = 0;
6de9cd9a
DN		 3269 break;
3270
3271 case COMP_SELECT:
3272 *st = ST_END_SELECT;
3273 target = " select";
ddc9ce91 3274 eos_ok = 0;
6de9cd9a
DN		 3275 break;
3276
3277 case COMP_FORALL:
3278 *st = ST_END_FORALL;
3279 target = " forall";
ddc9ce91 3280 eos_ok = 0;
6de9cd9a
DN		 3281 break;
3282
3283 case COMP_WHERE:
3284 *st = ST_END_WHERE;
3285 target = " where";
ddc9ce91 3286 eos_ok = 0;
6de9cd9a
DN		 3287 break;
3288
25d8f0a2
TS		 3289 case COMP_ENUM:
3290 *st = ST_END_ENUM;
3291 target = " enum";
3292 eos_ok = 0;
3293 last_initializer = NULL;
3294 set_enum_kind ();
3295 gfc_free_enum_history ();
3296 break;
3297
6de9cd9a
DN		 3298 default:
3299 gfc_error ("Unexpected END statement at %C");
3300 goto cleanup;
3301 }
3302
3303 if (gfc_match_eos () == MATCH_YES)
3304 {
ddc9ce91 3305 if (!eos_ok)
6de9cd9a 3306 {
ddc9ce91 3307 /* We would have required END [something] */
59ce85b5
TS		 3308 gfc_error ("%s statement expected at %L",
3309 gfc_ascii_statement (*st), &old_loc);
6de9cd9a
DN		 3310 goto cleanup;
3311 }
3312
3313 return MATCH_YES;
3314 }
3315
3316 /* Verify that we've got the sort of end-block that we're expecting. */
3317 if (gfc_match (target) != MATCH_YES)
3318 {
3319 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3320 goto cleanup;
3321 }
3322
3323 /* If we're at the end, make sure a block name wasn't required. */
3324 if (gfc_match_eos () == MATCH_YES)
3325 {
3326
3327 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3328 return MATCH_YES;
3329
3330 if (gfc_current_block () == NULL)
3331 return MATCH_YES;
3332
3333 gfc_error ("Expected block name of '%s' in %s statement at %C",
3334 block_name, gfc_ascii_statement (*st));
3335
3336 return MATCH_ERROR;
3337 }
3338
3339 /* END INTERFACE has a special handler for its several possible endings. */
3340 if (*st == ST_END_INTERFACE)
3341 return gfc_match_end_interface ();
3342
3343 /* We haven't hit the end of statement, so what is left must be an end-name. */
3344 m = gfc_match_space ();
3345 if (m == MATCH_YES)
3346 m = gfc_match_name (name);
3347
3348 if (m == MATCH_NO)
3349 gfc_error ("Expected terminating name at %C");
3350 if (m != MATCH_YES)
3351 goto cleanup;
3352
3353 if (block_name == NULL)
3354 goto syntax;
3355
3356 if (strcmp (name, block_name) != 0)
3357 {
3358 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3359 gfc_ascii_statement (*st));
3360 goto cleanup;
3361 }
3362
3363 if (gfc_match_eos () == MATCH_YES)
3364 return MATCH_YES;
3365
3366syntax:
3367 gfc_syntax_error (*st);
3368
3369cleanup:
63645982 3370 gfc_current_locus = old_loc;
6de9cd9a
DN		 3371 return MATCH_ERROR;
3372}
3373
3374
3375
3376/***************** Attribute declaration statements ****************/
3377
3378/* Set the attribute of a single variable. */
3379
3380static match
3381attr_decl1 (void)
3382{
3383 char name[GFC_MAX_SYMBOL_LEN + 1];
3384 gfc_array_spec *as;
3385 gfc_symbol *sym;
3386 locus var_locus;
3387 match m;
3388
3389 as = NULL;
3390
3391 m = gfc_match_name (name);
3392 if (m != MATCH_YES)
3393 goto cleanup;
3394
3395 if (find_special (name, &sym))
3396 return MATCH_ERROR;
3397
63645982 3398 var_locus = gfc_current_locus;
6de9cd9a
DN		 3399
3400 /* Deal with possible array specification for certain attributes. */
3401 if (current_attr.dimension
3402 || current_attr.allocatable
3403 || current_attr.pointer
3404 || current_attr.target)
3405 {
3406 m = gfc_match_array_spec (&as);
3407 if (m == MATCH_ERROR)
3408 goto cleanup;
3409
3410 if (current_attr.dimension && m == MATCH_NO)
3411 {
636dff67
SK		 3412 gfc_error ("Missing array specification at %L in DIMENSION "
3413 "statement", &var_locus);
6de9cd9a
DN		 3414 m = MATCH_ERROR;
3415 goto cleanup;
3416 }
3417
3418 if ((current_attr.allocatable || current_attr.pointer)
3419 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3420 {
636dff67 3421 gfc_error ("Array specification must be deferred at %L", &var_locus);
6de9cd9a
DN		 3422 m = MATCH_ERROR;
3423 goto cleanup;
3424 }
3425 }
3426
636dff67
SK		 3427 /* Update symbol table. DIMENSION attribute is set
3428 in gfc_set_array_spec(). */
6de9cd9a
DN		 3429 if (current_attr.dimension == 0
3430 && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3431 {
3432 m = MATCH_ERROR;
3433 goto cleanup;
3434 }
3435
3436 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3437 {
3438 m = MATCH_ERROR;
3439 goto cleanup;
3440 }
83d890b9
AL		 3441
3442 if (sym->attr.cray_pointee && sym->as != NULL)
3443 {
3444 /* Fix the array spec. */
3445 m = gfc_mod_pointee_as (sym->as);
3446 if (m == MATCH_ERROR)
3447 goto cleanup;
3448 }
6de9cd9a 3449
7114edca 3450 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
1902704e
PT		 3451 {
3452 m = MATCH_ERROR;
3453 goto cleanup;
3454 }
3455
6de9cd9a
DN		 3456 if ((current_attr.external || current_attr.intrinsic)
3457 && sym->attr.flavor != FL_PROCEDURE
231b2fcc 3458 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3459 {
3460 m = MATCH_ERROR;
3461 goto cleanup;
3462 }
3463
3464 return MATCH_YES;
3465
3466cleanup:
3467 gfc_free_array_spec (as);
3468 return m;
3469}
3470
3471
3472/* Generic attribute declaration subroutine. Used for attributes that
3473 just have a list of names. */
3474
3475static match
3476attr_decl (void)
3477{
3478 match m;
3479
3480 /* Gobble the optional double colon, by simply ignoring the result
3481 of gfc_match(). */
3482 gfc_match (" ::");
3483
3484 for (;;)
3485 {
3486 m = attr_decl1 ();
3487 if (m != MATCH_YES)
3488 break;
3489
3490 if (gfc_match_eos () == MATCH_YES)
3491 {
3492 m = MATCH_YES;
3493 break;
3494 }
3495
3496 if (gfc_match_char (',') != MATCH_YES)
3497 {
3498 gfc_error ("Unexpected character in variable list at %C");
3499 m = MATCH_ERROR;
3500 break;
3501 }
3502 }
3503
3504 return m;
3505}
3506
3507
83d890b9
AL		 3508/* This routine matches Cray Pointer declarations of the form:
3509 pointer ( <pointer>, <pointee> )
3510 or
3511 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3512 The pointer, if already declared, should be an integer. Otherwise, we
3513 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3514 be either a scalar, or an array declaration. No space is allocated for
3515 the pointee. For the statement
3516 pointer (ipt, ar(10))
3517 any subsequent uses of ar will be translated (in C-notation) as
3518 ar(i) => ((<type> *) ipt)(i)
b122dc6a 3519 After gimplification, pointee variable will disappear in the code. */
83d890b9
AL		 3520
3521static match
3522cray_pointer_decl (void)
3523{
3524 match m;
3525 gfc_array_spec *as;
3526 gfc_symbol *cptr; /* Pointer symbol. */
3527 gfc_symbol *cpte; /* Pointee symbol. */
3528 locus var_locus;
3529 bool done = false;
3530
3531 while (!done)
3532 {
3533 if (gfc_match_char ('(') != MATCH_YES)
3534 {
3535 gfc_error ("Expected '(' at %C");
3536 return MATCH_ERROR;
3537 }
3538
3539 /* Match pointer. */
3540 var_locus = gfc_current_locus;
3541 gfc_clear_attr (&current_attr);
3542 gfc_add_cray_pointer (&current_attr, &var_locus);
3543 current_ts.type = BT_INTEGER;
3544 current_ts.kind = gfc_index_integer_kind;
3545
3546 m = gfc_match_symbol (&cptr, 0);
3547 if (m != MATCH_YES)
3548 {
3549 gfc_error ("Expected variable name at %C");
3550 return m;
3551 }
3552
3553 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3554 return MATCH_ERROR;
3555
3556 gfc_set_sym_referenced (cptr);
3557
3558 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3559 {
3560 cptr->ts.type = BT_INTEGER;
3561 cptr->ts.kind = gfc_index_integer_kind;
3562 }
3563 else if (cptr->ts.type != BT_INTEGER)
3564 {
e25a0da3 3565 gfc_error ("Cray pointer at %C must be an integer");
83d890b9
AL		 3566 return MATCH_ERROR;
3567 }
3568 else if (cptr->ts.kind < gfc_index_integer_kind)
3569 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
e25a0da3 3570 " memory addresses require %d bytes",
636dff67 3571 cptr->ts.kind, gfc_index_integer_kind);
83d890b9
AL		 3572
3573 if (gfc_match_char (',') != MATCH_YES)
3574 {
3575 gfc_error ("Expected \",\" at %C");
3576 return MATCH_ERROR;
3577 }
3578
3579 /* Match Pointee. */
3580 var_locus = gfc_current_locus;
3581 gfc_clear_attr (&current_attr);
3582 gfc_add_cray_pointee (&current_attr, &var_locus);
3583 current_ts.type = BT_UNKNOWN;
3584 current_ts.kind = 0;
3585
3586 m = gfc_match_symbol (&cpte, 0);
3587 if (m != MATCH_YES)
3588 {
3589 gfc_error ("Expected variable name at %C");
3590 return m;
3591 }
3592
3593 /* Check for an optional array spec. */
3594 m = gfc_match_array_spec (&as);
3595 if (m == MATCH_ERROR)
3596 {
3597 gfc_free_array_spec (as);
3598 return m;
3599 }
3600 else if (m == MATCH_NO)
3601 {
3602 gfc_free_array_spec (as);
3603 as = NULL;
3604 }
3605
3606 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3607 return MATCH_ERROR;
3608
3609 gfc_set_sym_referenced (cpte);
3610
3611 if (cpte->as == NULL)
3612 {
3613 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3614 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3615 }
3616 else if (as != NULL)
3617 {
e25a0da3 3618 gfc_error ("Duplicate array spec for Cray pointee at %C");
83d890b9
AL		 3619 gfc_free_array_spec (as);
3620 return MATCH_ERROR;
3621 }
3622
3623 as = NULL;
3624
3625 if (cpte->as != NULL)
3626 {
3627 /* Fix array spec. */
3628 m = gfc_mod_pointee_as (cpte->as);
3629 if (m == MATCH_ERROR)
3630 return m;
3631 }
3632
3633 /* Point the Pointee at the Pointer. */
b122dc6a 3634 cpte->cp_pointer = cptr;
83d890b9
AL		 3635
3636 if (gfc_match_char (')') != MATCH_YES)
3637 {
3638 gfc_error ("Expected \")\" at %C");
3639 return MATCH_ERROR;
3640 }
3641 m = gfc_match_char (',');
3642 if (m != MATCH_YES)
3643 done = true; /* Stop searching for more declarations. */
3644
3645 }
3646
3647 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3648 || gfc_match_eos () != MATCH_YES)
3649 {
3650 gfc_error ("Expected \",\" or end of statement at %C");
3651 return MATCH_ERROR;
3652 }
3653 return MATCH_YES;
3654}
3655
3656
6de9cd9a
DN		 3657match
3658gfc_match_external (void)
3659{
3660
3661 gfc_clear_attr (&current_attr);
1902704e 3662 current_attr.external = 1;
6de9cd9a
DN		 3663
3664 return attr_decl ();
3665}
3666
3667
6de9cd9a
DN		 3668match
3669gfc_match_intent (void)
3670{
3671 sym_intent intent;
3672
3673 intent = match_intent_spec ();
3674 if (intent == INTENT_UNKNOWN)
3675 return MATCH_ERROR;
3676
3677 gfc_clear_attr (&current_attr);
1902704e 3678 current_attr.intent = intent;
6de9cd9a
DN		 3679
3680 return attr_decl ();
3681}
3682
3683
3684match
3685gfc_match_intrinsic (void)
3686{
3687
3688 gfc_clear_attr (&current_attr);
1902704e 3689 current_attr.intrinsic = 1;
6de9cd9a
DN		 3690
3691 return attr_decl ();
3692}
3693
3694
3695match
3696gfc_match_optional (void)
3697{
3698
3699 gfc_clear_attr (&current_attr);
1902704e 3700 current_attr.optional = 1;
6de9cd9a
DN		 3701
3702 return attr_decl ();
3703}
3704
3705
3706match
3707gfc_match_pointer (void)
3708{
83d890b9
AL		 3709 gfc_gobble_whitespace ();
3710 if (gfc_peek_char () == '(')
3711 {
3712 if (!gfc_option.flag_cray_pointer)
3713 {
636dff67
SK		 3714 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3715 "flag");
83d890b9
AL		 3716 return MATCH_ERROR;
3717 }
3718 return cray_pointer_decl ();
3719 }
3720 else
3721 {
3722 gfc_clear_attr (&current_attr);
1902704e 3723 current_attr.pointer = 1;
83d890b9
AL		 3724
3725 return attr_decl ();
3726 }
6de9cd9a
DN		 3727}
3728
3729
3730match
3731gfc_match_allocatable (void)
3732{
6de9cd9a 3733 gfc_clear_attr (&current_attr);
1902704e 3734 current_attr.allocatable = 1;
6de9cd9a
DN		 3735
3736 return attr_decl ();
3737}
3738
3739
3740match
3741gfc_match_dimension (void)
3742{
6de9cd9a 3743 gfc_clear_attr (&current_attr);
1902704e 3744 current_attr.dimension = 1;
6de9cd9a
DN		 3745
3746 return attr_decl ();
3747}
3748
3749
3750match
3751gfc_match_target (void)
3752{
6de9cd9a 3753 gfc_clear_attr (&current_attr);
1902704e 3754 current_attr.target = 1;
6de9cd9a
DN		 3755
3756 return attr_decl ();
3757}
3758
3759
3760/* Match the list of entities being specified in a PUBLIC or PRIVATE
3761 statement. */
3762
3763static match
3764access_attr_decl (gfc_statement st)
3765{
3766 char name[GFC_MAX_SYMBOL_LEN + 1];
3767 interface_type type;
3768 gfc_user_op *uop;
3769 gfc_symbol *sym;
3770 gfc_intrinsic_op operator;
3771 match m;
3772
3773 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3774 goto done;
3775
3776 for (;;)
3777 {
3778 m = gfc_match_generic_spec (&type, name, &operator);
3779 if (m == MATCH_NO)
3780 goto syntax;
3781 if (m == MATCH_ERROR)
3782 return MATCH_ERROR;
3783
3784 switch (type)
3785 {
3786 case INTERFACE_NAMELESS:
3787 goto syntax;
3788
3789 case INTERFACE_GENERIC:
3790 if (gfc_get_symbol (name, NULL, &sym))
3791 goto done;
3792
636dff67
SK		 3793 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
3794 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
231b2fcc 3795 sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3796 return MATCH_ERROR;
3797
3798 break;
3799
3800 case INTERFACE_INTRINSIC_OP:
3801 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3802 {
3803 gfc_current_ns->operator_access[operator] =
3804 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3805 }
3806 else
3807 {
3808 gfc_error ("Access specification of the %s operator at %C has "
3809 "already been specified", gfc_op2string (operator));
3810 goto done;
3811 }
3812
3813 break;
3814
3815 case INTERFACE_USER_OP:
3816 uop = gfc_get_uop (name);
3817
3818 if (uop->access == ACCESS_UNKNOWN)
3819 {
636dff67
SK		 3820 uop->access = (st == ST_PUBLIC)
3821 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
6de9cd9a
DN		 3822 }
3823 else
3824 {
636dff67
SK		 3825 gfc_error ("Access specification of the .%s. operator at %C "
3826 "has already been specified", sym->name);
6de9cd9a
DN		 3827 goto done;
3828 }
3829
3830 break;
3831 }
3832
3833 if (gfc_match_char (',') == MATCH_NO)
3834 break;
3835 }
3836
3837 if (gfc_match_eos () != MATCH_YES)
3838 goto syntax;
3839 return MATCH_YES;
3840
3841syntax:
3842 gfc_syntax_error (st);
3843
3844done:
3845 return MATCH_ERROR;
3846}
3847
3848
ee7e677f
TB		 3849match
3850gfc_match_protected (void)
3851{
3852 gfc_symbol *sym;
3853 match m;
3854
3855 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3856 {
3857 gfc_error ("PROTECTED at %C only allowed in specification "
3858 "part of a module");
3859 return MATCH_ERROR;
3860
3861 }
3862
636dff67 3863 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
ee7e677f
TB		 3864 == FAILURE)
3865 return MATCH_ERROR;
3866
3867 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3868 {
3869 return MATCH_ERROR;
3870 }
3871
3872 if (gfc_match_eos () == MATCH_YES)
3873 goto syntax;
3874
3875 for(;;)
3876 {
3877 m = gfc_match_symbol (&sym, 0);
3878 switch (m)
3879 {
3880 case MATCH_YES:
636dff67
SK		 3881 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
3882 == FAILURE)
ee7e677f
TB		 3883 return MATCH_ERROR;
3884 goto next_item;
3885
3886 case MATCH_NO:
3887 break;
3888
3889 case MATCH_ERROR:
3890 return MATCH_ERROR;
3891 }
3892
3893 next_item:
3894 if (gfc_match_eos () == MATCH_YES)
3895 break;
3896 if (gfc_match_char (',') != MATCH_YES)
3897 goto syntax;
3898 }
3899
3900 return MATCH_YES;
3901
3902syntax:
3903 gfc_error ("Syntax error in PROTECTED statement at %C");
3904 return MATCH_ERROR;
3905}
3906
3907
6de9cd9a
DN		 3908/* The PRIVATE statement is a bit weird in that it can be a attribute
3909 declaration, but also works as a standlone statement inside of a
3910 type declaration or a module. */
3911
3912match
636dff67 3913gfc_match_private (gfc_statement *st)
6de9cd9a
DN		 3914{
3915
3916 if (gfc_match ("private") != MATCH_YES)
3917 return MATCH_NO;
3918
3919 if (gfc_current_state () == COMP_DERIVED)
3920 {
3921 if (gfc_match_eos () == MATCH_YES)
3922 {
3923 *st = ST_PRIVATE;
3924 return MATCH_YES;
3925 }
3926
3927 gfc_syntax_error (ST_PRIVATE);
3928 return MATCH_ERROR;
3929 }
3930
3931 if (gfc_match_eos () == MATCH_YES)
3932 {
3933 *st = ST_PRIVATE;
3934 return MATCH_YES;
3935 }
3936
3937 *st = ST_ATTR_DECL;
3938 return access_attr_decl (ST_PRIVATE);
3939}
3940
3941
3942match
636dff67 3943gfc_match_public (gfc_statement *st)
6de9cd9a
DN		 3944{
3945
3946 if (gfc_match ("public") != MATCH_YES)
3947 return MATCH_NO;
3948
3949 if (gfc_match_eos () == MATCH_YES)
3950 {
3951 *st = ST_PUBLIC;
3952 return MATCH_YES;
3953 }
3954
3955 *st = ST_ATTR_DECL;
3956 return access_attr_decl (ST_PUBLIC);
3957}
3958
3959
3960/* Workhorse for gfc_match_parameter. */
3961
3962static match
3963do_parm (void)
3964{
3965 gfc_symbol *sym;
3966 gfc_expr *init;
3967 match m;
3968
3969 m = gfc_match_symbol (&sym, 0);
3970 if (m == MATCH_NO)
3971 gfc_error ("Expected variable name at %C in PARAMETER statement");
3972
3973 if (m != MATCH_YES)
3974 return m;
3975
3976 if (gfc_match_char ('=') == MATCH_NO)
3977 {
3978 gfc_error ("Expected = sign in PARAMETER statement at %C");
3979 return MATCH_ERROR;
3980 }
3981
3982 m = gfc_match_init_expr (&init);
3983 if (m == MATCH_NO)
3984 gfc_error ("Expected expression at %C in PARAMETER statement");
3985 if (m != MATCH_YES)
3986 return m;
3987
3988 if (sym->ts.type == BT_UNKNOWN
3989 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3990 {
3991 m = MATCH_ERROR;
3992 goto cleanup;
3993 }
3994
3995 if (gfc_check_assign_symbol (sym, init) == FAILURE
231b2fcc 3996 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 3997 {
3998 m = MATCH_ERROR;
3999 goto cleanup;
4000 }
4001
7e2eba4b
DE		 4002 if (sym->ts.type == BT_CHARACTER
4003 && sym->ts.cl != NULL
4004 && sym->ts.cl->length != NULL
4005 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
4006 && init->expr_type == EXPR_CONSTANT
4007 && init->ts.type == BT_CHARACTER
4008 && init->ts.kind == 1)
4009 gfc_set_constant_character_len (
2220652d 4010 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
7e2eba4b 4011
6de9cd9a
DN		 4012 sym->value = init;
4013 return MATCH_YES;
4014
4015cleanup:
4016 gfc_free_expr (init);
4017 return m;
4018}
4019
4020
4021/* Match a parameter statement, with the weird syntax that these have. */
4022
4023match
4024gfc_match_parameter (void)
4025{
4026 match m;
4027
4028 if (gfc_match_char ('(') == MATCH_NO)
4029 return MATCH_NO;
4030
4031 for (;;)
4032 {
4033 m = do_parm ();
4034 if (m != MATCH_YES)
4035 break;
4036
4037 if (gfc_match (" )%t") == MATCH_YES)
4038 break;
4039
4040 if (gfc_match_char (',') != MATCH_YES)
4041 {
4042 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4043 m = MATCH_ERROR;
4044 break;
4045 }
4046 }
4047
4048 return m;
4049}
4050
4051
4052/* Save statements have a special syntax. */
4053
4054match
4055gfc_match_save (void)
4056{
9056bd70
TS		 4057 char n[GFC_MAX_SYMBOL_LEN+1];
4058 gfc_common_head *c;
6de9cd9a
DN		 4059 gfc_symbol *sym;
4060 match m;
4061
4062 if (gfc_match_eos () == MATCH_YES)
4063 {
4064 if (gfc_current_ns->seen_save)
4065 {
636dff67
SK		 4066 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
4067 "follows previous SAVE statement")
09e87839
AL		 4068 == FAILURE)
4069 return MATCH_ERROR;
6de9cd9a
DN		 4070 }
4071
4072 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4073 return MATCH_YES;
4074 }
4075
4076 if (gfc_current_ns->save_all)
4077 {
636dff67
SK		 4078 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
4079 "blanket SAVE statement")
09e87839
AL		 4080 == FAILURE)
4081 return MATCH_ERROR;
6de9cd9a
DN		 4082 }
4083
4084 gfc_match (" ::");
4085
4086 for (;;)
4087 {
4088 m = gfc_match_symbol (&sym, 0);
4089 switch (m)
4090 {
4091 case MATCH_YES:
636dff67
SK		 4092 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
4093 == FAILURE)
6de9cd9a
DN		 4094 return MATCH_ERROR;
4095 goto next_item;
4096
4097 case MATCH_NO:
4098 break;
4099
4100 case MATCH_ERROR:
4101 return MATCH_ERROR;
4102 }
4103
9056bd70 4104 m = gfc_match (" / %n /", &n);
6de9cd9a
DN		 4105 if (m == MATCH_ERROR)
4106 return MATCH_ERROR;
4107 if (m == MATCH_NO)
4108 goto syntax;
4109
53814b8f 4110 c = gfc_get_common (n, 0);
9056bd70
TS		 4111 c->saved = 1;
4112
6de9cd9a
DN		 4113 gfc_current_ns->seen_save = 1;
4114
4115 next_item:
4116 if (gfc_match_eos () == MATCH_YES)
4117 break;
4118 if (gfc_match_char (',') != MATCH_YES)
4119 goto syntax;
4120 }
4121
4122 return MATCH_YES;
4123
4124syntax:
4125 gfc_error ("Syntax error in SAVE statement at %C");
4126 return MATCH_ERROR;
4127}
4128
4129
06469efd
PT		 4130match
4131gfc_match_value (void)
4132{
4133 gfc_symbol *sym;
4134 match m;
4135
636dff67 4136 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
06469efd
PT		 4137 == FAILURE)
4138 return MATCH_ERROR;
4139
4140 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4141 {
4142 return MATCH_ERROR;
4143 }
4144
4145 if (gfc_match_eos () == MATCH_YES)
4146 goto syntax;
4147
4148 for(;;)
4149 {
4150 m = gfc_match_symbol (&sym, 0);
4151 switch (m)
4152 {
4153 case MATCH_YES:
636dff67
SK		 4154 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
4155 == FAILURE)
06469efd
PT		 4156 return MATCH_ERROR;
4157 goto next_item;
4158
4159 case MATCH_NO:
4160 break;
4161
4162 case MATCH_ERROR:
4163 return MATCH_ERROR;
4164 }
4165
4166 next_item:
4167 if (gfc_match_eos () == MATCH_YES)
4168 break;
4169 if (gfc_match_char (',') != MATCH_YES)
4170 goto syntax;
4171 }
4172
4173 return MATCH_YES;
4174
4175syntax:
4176 gfc_error ("Syntax error in VALUE statement at %C");
4177 return MATCH_ERROR;
4178}
4179
775e6c3a
TB		 4180match
4181gfc_match_volatile (void)
4182{
4183 gfc_symbol *sym;
4184 match m;
4185
636dff67 4186 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
775e6c3a
TB		 4187 == FAILURE)
4188 return MATCH_ERROR;
4189
4190 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4191 {
4192 return MATCH_ERROR;
4193 }
4194
4195 if (gfc_match_eos () == MATCH_YES)
4196 goto syntax;
4197
4198 for(;;)
4199 {
9bce3c1c
TB		 4200 /* VOLATILE is special because it can be added to host-associated
4201 symbols locally. */
4202 m = gfc_match_symbol (&sym, 1);
775e6c3a
TB		 4203 switch (m)
4204 {
4205 case MATCH_YES:
636dff67
SK		 4206 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
4207 == FAILURE)
775e6c3a
TB		 4208 return MATCH_ERROR;
4209 goto next_item;
4210
4211 case MATCH_NO:
4212 break;
4213
4214 case MATCH_ERROR:
4215 return MATCH_ERROR;
4216 }
4217
4218 next_item:
4219 if (gfc_match_eos () == MATCH_YES)
4220 break;
4221 if (gfc_match_char (',') != MATCH_YES)
4222 goto syntax;
4223 }
4224
4225 return MATCH_YES;
4226
4227syntax:
4228 gfc_error ("Syntax error in VOLATILE statement at %C");
4229 return MATCH_ERROR;
4230}
4231
4232
4233
6de9cd9a
DN		 4234/* Match a module procedure statement. Note that we have to modify
4235 symbols in the parent's namespace because the current one was there
49de9e73 4236 to receive symbols that are in an interface's formal argument list. */
6de9cd9a
DN		 4237
4238match
4239gfc_match_modproc (void)
4240{
4241 char name[GFC_MAX_SYMBOL_LEN + 1];
4242 gfc_symbol *sym;
4243 match m;
4244
4245 if (gfc_state_stack->state != COMP_INTERFACE
4246 || gfc_state_stack->previous == NULL
4247 || current_interface.type == INTERFACE_NAMELESS)
4248 {
636dff67
SK		 4249 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4250 "interface");
6de9cd9a
DN		 4251 return MATCH_ERROR;
4252 }
4253
4254 for (;;)
4255 {
4256 m = gfc_match_name (name);
4257 if (m == MATCH_NO)
4258 goto syntax;
4259 if (m != MATCH_YES)
4260 return MATCH_ERROR;
4261
4262 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4263 return MATCH_ERROR;
4264
4265 if (sym->attr.proc != PROC_MODULE
231b2fcc
TS		 4266 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4267 sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4268 return MATCH_ERROR;
4269
4270 if (gfc_add_interface (sym) == FAILURE)
4271 return MATCH_ERROR;
4272
71f77fd7
PT		 4273 sym->attr.mod_proc = 1;
4274
6de9cd9a
DN		 4275 if (gfc_match_eos () == MATCH_YES)
4276 break;
4277 if (gfc_match_char (',') != MATCH_YES)
4278 goto syntax;
4279 }
4280
4281 return MATCH_YES;
4282
4283syntax:
4284 gfc_syntax_error (ST_MODULE_PROC);
4285 return MATCH_ERROR;
4286}
4287
4288
4289/* Match the beginning of a derived type declaration. If a type name
4290 was the result of a function, then it is possible to have a symbol
4291 already to be known as a derived type yet have no components. */
4292
4293match
4294gfc_match_derived_decl (void)
4295{
4296 char name[GFC_MAX_SYMBOL_LEN + 1];
4297 symbol_attribute attr;
4298 gfc_symbol *sym;
4299 match m;
4300
4301 if (gfc_current_state () == COMP_DERIVED)
4302 return MATCH_NO;
4303
4304 gfc_clear_attr (&attr);
4305
4306loop:
4307 if (gfc_match (" , private") == MATCH_YES)
4308 {
4309 if (gfc_find_state (COMP_MODULE) == FAILURE)
4310 {
636dff67 4311 gfc_error ("Derived type at %C can only be PRIVATE within a MODULE");
6de9cd9a
DN		 4312 return MATCH_ERROR;
4313 }
4314
231b2fcc 4315 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
6de9cd9a
DN		 4316 return MATCH_ERROR;
4317 goto loop;
4318 }
4319
4320 if (gfc_match (" , public") == MATCH_YES)
4321 {
4322 if (gfc_find_state (COMP_MODULE) == FAILURE)
4323 {
4324 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4325 return MATCH_ERROR;
4326 }
4327
231b2fcc 4328 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
6de9cd9a
DN		 4329 return MATCH_ERROR;
4330 goto loop;
4331 }
4332
4333 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4334 {
4335 gfc_error ("Expected :: in TYPE definition at %C");
4336 return MATCH_ERROR;
4337 }
4338
4339 m = gfc_match (" %n%t", name);
4340 if (m != MATCH_YES)
4341 return m;
4342
4343 /* Make sure the name isn't the name of an intrinsic type. The
4344 'double precision' type doesn't get past the name matcher. */
4345 if (strcmp (name, "integer") == 0
4346 || strcmp (name, "real") == 0
4347 || strcmp (name, "character") == 0
4348 || strcmp (name, "logical") == 0
4349 || strcmp (name, "complex") == 0)
4350 {
636dff67
SK		 4351 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4352 "type", name);
6de9cd9a
DN		 4353 return MATCH_ERROR;
4354 }
4355
4356 if (gfc_get_symbol (name, NULL, &sym))
4357 return MATCH_ERROR;
4358
4359 if (sym->ts.type != BT_UNKNOWN)
4360 {
4361 gfc_error ("Derived type name '%s' at %C already has a basic type "
4362 "of %s", sym->name, gfc_typename (&sym->ts));
4363 return MATCH_ERROR;
4364 }
4365
4366 /* The symbol may already have the derived attribute without the
4367 components. The ways this can happen is via a function
4368 definition, an INTRINSIC statement or a subtype in another
4369 derived type that is a pointer. The first part of the AND clause
f7b529fa 4370 is true if a the symbol is not the return value of a function. */
6de9cd9a 4371 if (sym->attr.flavor != FL_DERIVED
231b2fcc 4372 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4373 return MATCH_ERROR;
4374
4375 if (sym->components != NULL)
4376 {
636dff67
SK		 4377 gfc_error ("Derived type definition of '%s' at %C has already been "
4378 "defined", sym->name);
6de9cd9a
DN		 4379 return MATCH_ERROR;
4380 }
4381
4382 if (attr.access != ACCESS_UNKNOWN
231b2fcc 4383 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
6de9cd9a
DN		 4384 return MATCH_ERROR;
4385
4386 gfc_new_block = sym;
4387
4388 return MATCH_YES;
4389}
83d890b9
AL		 4390
4391
4392/* Cray Pointees can be declared as:
4393 pointer (ipt, a (n,m,...,*))
4394 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4395 cheat and set a constant bound of 1 for the last dimension, if this
4396 is the case. Since there is no bounds-checking for Cray Pointees,
4397 this will be okay. */
4398
4399try
4400gfc_mod_pointee_as (gfc_array_spec *as)
4401{
4402 as->cray_pointee = true; /* This will be useful to know later. */
4403 if (as->type == AS_ASSUMED_SIZE)
4404 {
4405 as->type = AS_EXPLICIT;
4406 as->upper[as->rank - 1] = gfc_int_expr (1);
4407 as->cp_was_assumed = true;
4408 }
4409 else if (as->type == AS_ASSUMED_SHAPE)
4410 {
4411 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4412 return MATCH_ERROR;
4413 }
4414 return MATCH_YES;
4415}
25d8f0a2
TS		 4416
4417
4418/* Match the enum definition statement, here we are trying to match
4419 the first line of enum definition statement.
4420 Returns MATCH_YES if match is found. */
4421
4422match
4423gfc_match_enum (void)
4424{
4425 match m;
4426
4427 m = gfc_match_eos ();
4428 if (m != MATCH_YES)
4429 return m;
4430
6133c68a 4431 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
25d8f0a2
TS		 4432 == FAILURE)
4433 return MATCH_ERROR;
4434
4435 return MATCH_YES;
4436}
4437
4438
6133c68a
TS		 4439/* Match a variable name with an optional initializer. When this
4440 subroutine is called, a variable is expected to be parsed next.
4441 Depending on what is happening at the moment, updates either the
4442 symbol table or the current interface. */
4443
4444static match
4445enumerator_decl (void)
4446{
4447 char name[GFC_MAX_SYMBOL_LEN + 1];
4448 gfc_expr *initializer;
4449 gfc_array_spec *as = NULL;
4450 gfc_symbol *sym;
4451 locus var_locus;
4452 match m;
4453 try t;
4454 locus old_locus;
4455
4456 initializer = NULL;
4457 old_locus = gfc_current_locus;
4458
4459 /* When we get here, we've just matched a list of attributes and
4460 maybe a type and a double colon. The next thing we expect to see
4461 is the name of the symbol. */
4462 m = gfc_match_name (name);
4463 if (m != MATCH_YES)
4464 goto cleanup;
4465
4466 var_locus = gfc_current_locus;
4467
4468 /* OK, we've successfully matched the declaration. Now put the
4469 symbol in the current namespace. If we fail to create the symbol,
4470 bail out. */
4471 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
4472 {
4473 m = MATCH_ERROR;
4474 goto cleanup;
4475 }
4476
4477 /* The double colon must be present in order to have initializers.
4478 Otherwise the statement is ambiguous with an assignment statement. */
4479 if (colon_seen)
4480 {
4481 if (gfc_match_char ('=') == MATCH_YES)
4482 {
4483 m = gfc_match_init_expr (&initializer);
4484 if (m == MATCH_NO)
4485 {
4486 gfc_error ("Expected an initialization expression at %C");
4487 m = MATCH_ERROR;
4488 }
4489
4490 if (m != MATCH_YES)
4491 goto cleanup;
4492 }
4493 }
4494
4495 /* If we do not have an initializer, the initialization value of the
4496 previous enumerator (stored in last_initializer) is incremented
4497 by 1 and is used to initialize the current enumerator. */
4498 if (initializer == NULL)
4499 initializer = gfc_enum_initializer (last_initializer, old_locus);
4500
4501 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
4502 {
4503 gfc_error("ENUMERATOR %L not initialized with integer expression",
4504 &var_locus);
4505 m = MATCH_ERROR;
4506 gfc_free_enum_history ();
4507 goto cleanup;
4508 }
4509
4510 /* Store this current initializer, for the next enumerator variable
4511 to be parsed. add_init_expr_to_sym() zeros initializer, so we
4512 use last_initializer below. */
4513 last_initializer = initializer;
4514 t = add_init_expr_to_sym (name, &initializer, &var_locus);
4515
4516 /* Maintain enumerator history. */
4517 gfc_find_symbol (name, NULL, 0, &sym);
4518 create_enum_history (sym, last_initializer);
4519
4520 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
4521
4522cleanup:
4523 /* Free stuff up and return. */
4524 gfc_free_expr (initializer);
4525
4526 return m;
4527}
4528
4529
25d8f0a2
TS		 4530/* Match the enumerator definition statement. */
4531
4532match
4533gfc_match_enumerator_def (void)
4534{
4535 match m;
6133c68a 4536 try t;
25d8f0a2
TS		 4537
4538 gfc_clear_ts (&current_ts);
4539
4540 m = gfc_match (" enumerator");
4541 if (m != MATCH_YES)
4542 return m;
6133c68a
TS		 4543
4544 m = gfc_match (" :: ");
4545 if (m == MATCH_ERROR)
4546 return m;
4547
4548 colon_seen = (m == MATCH_YES);
25d8f0a2
TS		 4549
4550 if (gfc_current_state () != COMP_ENUM)
4551 {
4552 gfc_error ("ENUM definition statement expected before %C");
4553 gfc_free_enum_history ();
4554 return MATCH_ERROR;
4555 }
4556
4557 (&current_ts)->type = BT_INTEGER;
4558 (&current_ts)->kind = gfc_c_int_kind;
4559
6133c68a
TS		 4560 gfc_clear_attr (&current_attr);
4561 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
4562 if (t == FAILURE)
25d8f0a2 4563 {
6133c68a 4564 m = MATCH_ERROR;
25d8f0a2
TS		 4565 goto cleanup;
4566 }
4567
25d8f0a2
TS		 4568 for (;;)
4569 {
6133c68a 4570 m = enumerator_decl ();
25d8f0a2
TS		 4571 if (m == MATCH_ERROR)
4572 goto cleanup;
4573 if (m == MATCH_NO)
4574 break;
4575
4576 if (gfc_match_eos () == MATCH_YES)
4577 goto cleanup;
4578 if (gfc_match_char (',') != MATCH_YES)
4579 break;
4580 }
4581
4582 if (gfc_current_state () == COMP_ENUM)
4583 {
4584 gfc_free_enum_history ();
4585 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4586 m = MATCH_ERROR;
4587 }
4588
4589cleanup:
4590 gfc_free_array_spec (current_as);
4591 current_as = NULL;
4592 return m;
4593
4594}
4595
GNU Compiler Collection
This page took 1.402162 seconds and 5 git commands to generate.