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