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