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