]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/decl.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge tree-ssa-20020619-branch into mainline.
[thirdparty/gcc.git] / gcc / fortran / decl.c
CommitLineData
4ee9c684 1/* Declaration statement matcher
2 Copyright (C) 2002 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5This file is part of GNU G95.
6
7GNU G95 is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU G95 is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU G95; see the file COPYING. If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330,
20Boston, MA 02111-1307, USA. */
21
22
23#include "config.h"
24#include "gfortran.h"
25#include "match.h"
26#include "parse.h"
27#include <string.h>
28
29
30/* This flag is set if a an old-style length selector is matched
31 during a type-declaration statement. */
32
33static int old_char_selector;
34
35/* When variables aquire types and attributes from a declaration
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
46/* gfc_new_block points to the symbol of a newly matched block. */
47
48gfc_symbol *gfc_new_block;
49
50
51/* Match an intent specification. Since this can only happen after an
52 INTENT word, a legal intent-spec must follow. */
53
54static sym_intent
55match_intent_spec (void)
56{
57
58 if (gfc_match (" ( in out )") == MATCH_YES)
59 return INTENT_INOUT;
60 if (gfc_match (" ( in )") == MATCH_YES)
61 return INTENT_IN;
62 if (gfc_match (" ( out )") == MATCH_YES)
63 return INTENT_OUT;
64
65 gfc_error ("Bad INTENT specification at %C");
66 return INTENT_UNKNOWN;
67}
68
69
70/* Matches a character length specification, which is either a
71 specification expression or a '*'. */
72
73static match
74char_len_param_value (gfc_expr ** expr)
75{
76
77 if (gfc_match_char ('*') == MATCH_YES)
78 {
79 *expr = NULL;
80 return MATCH_YES;
81 }
82
83 return gfc_match_expr (expr);
84}
85
86
87/* A character length is a '*' followed by a literal integer or a
88 char_len_param_value in parenthesis. */
89
90static match
91match_char_length (gfc_expr ** expr)
92{
93 int length;
94 match m;
95
96 m = gfc_match_char ('*');
97 if (m != MATCH_YES)
98 return m;
99
100 m = gfc_match_small_literal_int (&length);
101 if (m == MATCH_ERROR)
102 return m;
103
104 if (m == MATCH_YES)
105 {
106 *expr = gfc_int_expr (length);
107 return m;
108 }
109
110 if (gfc_match_char ('(') == MATCH_NO)
111 goto syntax;
112
113 m = char_len_param_value (expr);
114 if (m == MATCH_ERROR)
115 return m;
116 if (m == MATCH_NO)
117 goto syntax;
118
119 if (gfc_match_char (')') == MATCH_NO)
120 {
121 gfc_free_expr (*expr);
122 *expr = NULL;
123 goto syntax;
124 }
125
126 return MATCH_YES;
127
128syntax:
129 gfc_error ("Syntax error in character length specification at %C");
130 return MATCH_ERROR;
131}
132
133
134/* Special subroutine for finding a symbol. If we're compiling a
135 function or subroutine and the parent compilation unit is an
136 interface, then check to see if the name we've been given is the
137 name of the interface (located in another namespace). If so,
138 return that symbol. If not, use gfc_get_symbol(). */
139
140static int
141find_special (const char *name, gfc_symbol ** result)
142{
143 gfc_state_data *s;
144
145 if (gfc_current_state () != COMP_SUBROUTINE
146 && gfc_current_state () != COMP_FUNCTION)
147 goto normal;
148
149 s = gfc_state_stack->previous;
150 if (s == NULL)
151 goto normal;
152
153 if (s->state != COMP_INTERFACE)
154 goto normal;
155 if (s->sym == NULL)
156 goto normal; /* Nameless interface */
157
158 if (strcmp (name, s->sym->name) == 0)
159 {
160 *result = s->sym;
161 return 0;
162 }
163
164normal:
165 return gfc_get_symbol (name, NULL, result);
166}
167
168
169/* Special subroutine for getting a symbol node associated with a
170 procedure name, used in SUBROUTINE and FUNCTION statements. The
171 symbol is created in the parent using with symtree node in the
172 child unit pointing to the symbol. If the current namespace has no
173 parent, then the symbol is just created in the current unit. */
174
175static int
176get_proc_name (const char *name, gfc_symbol ** result)
177{
178 gfc_symtree *st;
179 gfc_symbol *sym;
180 int rc;
181
182 if (gfc_current_ns->parent == NULL)
183 return gfc_get_symbol (name, NULL, result);
184
185 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
186 if (*result == NULL)
187 return rc;
188
189 /* Deal with ENTRY problem */
190
191 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
192
193 sym = *result;
194 st->n.sym = sym;
195 sym->refs++;
196
197 /* See if the procedure should be a module procedure */
198
199 if (sym->ns->proc_name != NULL
200 && sym->ns->proc_name->attr.flavor == FL_MODULE
201 && sym->attr.proc != PROC_MODULE
202 && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
203 rc = 2;
204
205 return rc;
206}
207
208
209/* Function called by variable_decl() that adds a name to the symbol
210 table. */
211
212static try
213build_sym (const char *name, gfc_charlen * cl,
214 gfc_array_spec ** as, locus * var_locus)
215{
216 symbol_attribute attr;
217 gfc_symbol *sym;
218
219 if (find_special (name, &sym))
220 return FAILURE;
221
222 /* Start updating the symbol table. Add basic type attribute
223 if present. */
224 if (current_ts.type != BT_UNKNOWN
225 &&(sym->attr.implicit_type == 0
226 || !gfc_compare_types (&sym->ts, &current_ts))
227 && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
228 return FAILURE;
229
230 if (sym->ts.type == BT_CHARACTER)
231 sym->ts.cl = cl;
232
233 /* Add dimension attribute if present. */
234 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
235 return FAILURE;
236 *as = NULL;
237
238 /* Add attribute to symbol. The copy is so that we can reset the
239 dimension attribute. */
240 attr = current_attr;
241 attr.dimension = 0;
242
243 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
244 return FAILURE;
245
246 return SUCCESS;
247}
248
249
250/* Function called by variable_decl() that adds an initialization
251 expression to a symbol. */
252
253static try
254add_init_expr_to_sym (const char *name, gfc_expr ** initp,
255 locus * var_locus)
256{
257 symbol_attribute attr;
258 gfc_symbol *sym;
259 gfc_expr *init;
260
261 init = *initp;
262 if (find_special (name, &sym))
263 return FAILURE;
264
265 attr = sym->attr;
266
267 /* If this symbol is confirming an implicit parameter type,
268 then an initialization expression is not allowed. */
269 if (attr.flavor == FL_PARAMETER
270 && sym->value != NULL
271 && *initp != NULL)
272 {
273 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
274 sym->name);
275 return FAILURE;
276 }
277
278 if (init == NULL)
279 {
280 /* An initializer is required for PARAMETER declarations. */
281 if (attr.flavor == FL_PARAMETER)
282 {
283 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
284 return FAILURE;
285 }
286 }
287 else
288 {
289 /* If a variable appears in a DATA block, it cannot have an
290 initializer. */
291 if (sym->attr.data)
292 {
293 gfc_error
294 ("Variable '%s' at %C with an initializer already appears "
295 "in a DATA statement", sym->name);
296 return FAILURE;
297 }
298
299 /* Checking a derived type parameter has to be put off until later. */
300 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
301 && gfc_check_assign_symbol (sym, init) == FAILURE)
302 return FAILURE;
303
304 /* Add initializer. Make sure we keep the ranks sane. */
305 if (sym->attr.dimension && init->rank == 0)
306 init->rank = sym->as->rank;
307
308 sym->value = init;
309 *initp = NULL;
310 }
311
312 return SUCCESS;
313}
314
315
316/* Function called by variable_decl() that adds a name to a structure
317 being built. */
318
319static try
320build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
321 gfc_array_spec ** as)
322{
323 gfc_component *c;
324
325 /* If the current symbol is of the same derived type that we're
326 constructing, it must have the pointer attribute. */
327 if (current_ts.type == BT_DERIVED
328 && current_ts.derived == gfc_current_block ()
329 && current_attr.pointer == 0)
330 {
331 gfc_error ("Component at %C must have the POINTER attribute");
332 return FAILURE;
333 }
334
335 if (gfc_current_block ()->attr.pointer
336 && (*as)->rank != 0)
337 {
338 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
339 {
340 gfc_error ("Array component of structure at %C must have explicit "
341 "or deferred shape");
342 return FAILURE;
343 }
344 }
345
346 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
347 return FAILURE;
348
349 c->ts = current_ts;
350 c->ts.cl = cl;
351 gfc_set_component_attr (c, &current_attr);
352
353 c->initializer = *init;
354 *init = NULL;
355
356 c->as = *as;
357 if (c->as != NULL)
358 c->dimension = 1;
359 *as = NULL;
360
361 /* Check array components. */
362 if (!c->dimension)
363 return SUCCESS;
364
365 if (c->pointer)
366 {
367 if (c->as->type != AS_DEFERRED)
368 {
369 gfc_error ("Pointer array component of structure at %C "
370 "must have a deferred shape");
371 return FAILURE;
372 }
373 }
374 else
375 {
376 if (c->as->type != AS_EXPLICIT)
377 {
378 gfc_error
379 ("Array component of structure at %C must have an explicit "
380 "shape");
381 return FAILURE;
382 }
383 }
384
385 return SUCCESS;
386}
387
388
389/* Match a 'NULL()', and possibly take care of some side effects. */
390
391match
392gfc_match_null (gfc_expr ** result)
393{
394 gfc_symbol *sym;
395 gfc_expr *e;
396 match m;
397
398 m = gfc_match (" null ( )");
399 if (m != MATCH_YES)
400 return m;
401
402 /* The NULL symbol now has to be/become an intrinsic function. */
403 if (gfc_get_symbol ("null", NULL, &sym))
404 {
405 gfc_error ("NULL() initialization at %C is ambiguous");
406 return MATCH_ERROR;
407 }
408
409 gfc_intrinsic_symbol (sym);
410
411 if (sym->attr.proc != PROC_INTRINSIC
412 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
413 || gfc_add_function (&sym->attr, NULL) == FAILURE))
414 return MATCH_ERROR;
415
416 e = gfc_get_expr ();
417 e->where = *gfc_current_locus ();
418 e->expr_type = EXPR_NULL;
419 e->ts.type = BT_UNKNOWN;
420
421 *result = e;
422
423 return MATCH_YES;
424}
425
426
427/* Get an expression for a default initializer. */
428static gfc_expr *
429default_initializer (void)
430{
431 gfc_constructor *tail;
432 gfc_expr *init;
433 gfc_component *c;
434
435 init = NULL;
436
437 /* First see if we have a default initializer. */
438 for (c = current_ts.derived->components; c; c = c->next)
439 {
440 if (c->initializer && init == NULL)
441 init = gfc_get_expr ();
442 }
443
444 if (init == NULL)
445 return NULL;
446
447 init->expr_type = EXPR_STRUCTURE;
448 init->ts = current_ts;
449 init->where = current_ts.derived->declared_at;
450 tail = NULL;
451 for (c = current_ts.derived->components; c; c = c->next)
452 {
453 if (tail == NULL)
454 init->value.constructor = tail = gfc_get_constructor ();
455 else
456 {
457 tail->next = gfc_get_constructor ();
458 tail = tail->next;
459 }
460
461 if (c->initializer)
462 tail->expr = gfc_copy_expr (c->initializer);
463 }
464 return init;
465}
466
467
468/* Match a variable name with an optional initializer. When this
469 subroutine is called, a variable is expected to be parsed next.
470 Depending on what is happening at the moment, updates either the
471 symbol table or the current interface. */
472
473static match
474variable_decl (void)
475{
476 char name[GFC_MAX_SYMBOL_LEN + 1];
477 gfc_expr *initializer, *char_len;
478 gfc_array_spec *as;
479 gfc_charlen *cl;
480 locus var_locus;
481 match m;
482 try t;
483
484 initializer = NULL;
485 as = NULL;
486
487 /* When we get here, we've just matched a list of attributes and
488 maybe a type and a double colon. The next thing we expect to see
489 is the name of the symbol. */
490 m = gfc_match_name (name);
491 if (m != MATCH_YES)
492 goto cleanup;
493
494 var_locus = *gfc_current_locus ();
495
496 /* Now we could see the optional array spec. or character length. */
497 m = gfc_match_array_spec (&as);
498 if (m == MATCH_ERROR)
499 goto cleanup;
500 if (m == MATCH_NO)
501 as = gfc_copy_array_spec (current_as);
502
503 char_len = NULL;
504 cl = NULL;
505
506 if (current_ts.type == BT_CHARACTER)
507 {
508 switch (match_char_length (&char_len))
509 {
510 case MATCH_YES:
511 cl = gfc_get_charlen ();
512 cl->next = gfc_current_ns->cl_list;
513 gfc_current_ns->cl_list = cl;
514
515 cl->length = char_len;
516 break;
517
518 case MATCH_NO:
519 cl = current_ts.cl;
520 break;
521
522 case MATCH_ERROR:
523 goto cleanup;
524 }
525 }
526
527 /* OK, we've successfully matched the declaration. Now put the
528 symbol in the current namespace, because it might be used in the
529 optional intialization expression for this symbol, e.g. this is
530 perfectly legal:
531
532 integer, parameter :: i = huge(i)
533
534 This is only true for parameters or variables of a basic type.
535 For components of derived types, it is not true, so we don't
536 create a symbol for those yet. If we fail to create the symbol,
537 bail out. */
538 if (gfc_current_state () != COMP_DERIVED
539 && build_sym (name, cl, &as, &var_locus) == FAILURE)
540 {
541 m = MATCH_ERROR;
542 goto cleanup;
543 }
544
545 /* In functions that have a RESULT variable defined, the function
546 name always refers to function calls. Therefore, the name is
547 not allowed to appear in specification statements. */
548 if (gfc_current_state () == COMP_FUNCTION
549 && gfc_current_block () != NULL
550 && gfc_current_block ()->result != NULL
551 && gfc_current_block ()->result != gfc_current_block ()
552 && strcmp (gfc_current_block ()->name, name) == 0)
553 {
554 gfc_error ("Function name '%s' not allowed at %C", name);
555 m = MATCH_ERROR;
556 goto cleanup;
557 }
558
559 /* The double colon must be present in order to have initializers.
560 Otherwise the statement is ambiguous with an assignment statement. */
561 if (colon_seen)
562 {
563 if (gfc_match (" =>") == MATCH_YES)
564 {
565
566 if (!current_attr.pointer)
567 {
568 gfc_error ("Initialization at %C isn't for a pointer variable");
569 m = MATCH_ERROR;
570 goto cleanup;
571 }
572
573 m = gfc_match_null (&initializer);
574 if (m == MATCH_NO)
575 {
576 gfc_error ("Pointer initialization requires a NULL at %C");
577 m = MATCH_ERROR;
578 }
579
580 if (gfc_pure (NULL))
581 {
582 gfc_error
583 ("Initialization of pointer at %C is not allowed in a "
584 "PURE procedure");
585 m = MATCH_ERROR;
586 }
587
588 if (m != MATCH_YES)
589 goto cleanup;
590
591 initializer->ts = current_ts;
592
593 }
594 else if (gfc_match_char ('=') == MATCH_YES)
595 {
596 if (current_attr.pointer)
597 {
598 gfc_error
599 ("Pointer initialization at %C requires '=>', not '='");
600 m = MATCH_ERROR;
601 goto cleanup;
602 }
603
604 m = gfc_match_init_expr (&initializer);
605 if (m == MATCH_NO)
606 {
607 gfc_error ("Expected an initialization expression at %C");
608 m = MATCH_ERROR;
609 }
610
611 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
612 {
613 gfc_error
614 ("Initialization of variable at %C is not allowed in a "
615 "PURE procedure");
616 m = MATCH_ERROR;
617 }
618
619 if (m != MATCH_YES)
620 goto cleanup;
621 }
622 else if (current_ts.type == BT_DERIVED)
623 {
624 initializer = default_initializer ();
625 }
626 }
627
628 /* Add the initializer. Note that it is fine if &initializer is
629 NULL here, because we sometimes also need to check if a
630 declaration *must* have an initialization expression. */
631 if (gfc_current_state () != COMP_DERIVED)
632 t = add_init_expr_to_sym (name, &initializer, &var_locus);
633 else
634 t = build_struct (name, cl, &initializer, &as);
635
636 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
637
638cleanup:
639 /* Free stuff up and return. */
640 gfc_free_expr (initializer);
641 gfc_free_array_spec (as);
642
643 return m;
644}
645
646
647/* Match an extended-f77 kind specification. */
648
649match
650gfc_match_old_kind_spec (gfc_typespec * ts)
651{
652 match m;
653
654 if (gfc_match_char ('*') != MATCH_YES)
655 return MATCH_NO;
656
657 m = gfc_match_small_literal_int (&ts->kind);
658 if (m != MATCH_YES)
659 return MATCH_ERROR;
660
661 /* Massage the kind numbers for complex types. */
662 if (ts->type == BT_COMPLEX && ts->kind == 8)
663 ts->kind = 4;
664 if (ts->type == BT_COMPLEX && ts->kind == 16)
665 ts->kind = 8;
666
667 if (gfc_validate_kind (ts->type, ts->kind) == -1)
668 {
669 gfc_error ("Old-style kind %d not supported for type %s at %C",
670 ts->kind, gfc_basic_typename (ts->type));
671
672 return MATCH_ERROR;
673 }
674
675 return MATCH_YES;
676}
677
678
679/* Match a kind specification. Since kinds are generally optional, we
680 usually return MATCH_NO if something goes wrong. If a "kind="
681 string is found, then we know we have an error. */
682
683match
684gfc_match_kind_spec (gfc_typespec * ts)
685{
686 locus where;
687 gfc_expr *e;
688 match m, n;
689 const char *msg;
690
691 m = MATCH_NO;
692 e = NULL;
693
694 where = *gfc_current_locus ();
695
696 if (gfc_match_char ('(') == MATCH_NO)
697 return MATCH_NO;
698
699 /* Also gobbles optional text. */
700 if (gfc_match (" kind = ") == MATCH_YES)
701 m = MATCH_ERROR;
702
703 n = gfc_match_init_expr (&e);
704 if (n == MATCH_NO)
705 gfc_error ("Expected initialization expression at %C");
706 if (n != MATCH_YES)
707 return MATCH_ERROR;
708
709 if (e->rank != 0)
710 {
711 gfc_error ("Expected scalar initialization expression at %C");
712 m = MATCH_ERROR;
713 goto no_match;
714 }
715
716 msg = gfc_extract_int (e, &ts->kind);
717 if (msg != NULL)
718 {
719 gfc_error (msg);
720 m = MATCH_ERROR;
721 goto no_match;
722 }
723
724 gfc_free_expr (e);
725 e = NULL;
726
727 if (gfc_validate_kind (ts->type, ts->kind) == -1)
728 {
729 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
730 gfc_basic_typename (ts->type));
731
732 m = MATCH_ERROR;
733 goto no_match;
734 }
735
736 if (gfc_match_char (')') != MATCH_YES)
737 {
738 gfc_error ("Missing right paren at %C");
739 goto no_match;
740 }
741
742 return MATCH_YES;
743
744no_match:
745 gfc_free_expr (e);
746 gfc_set_locus (&where);
747 return m;
748}
749
750
751/* Match the various kind/length specifications in a CHARACTER
752 declaration. We don't return MATCH_NO. */
753
754static match
755match_char_spec (gfc_typespec * ts)
756{
757 int i, kind, seen_length;
758 gfc_charlen *cl;
759 gfc_expr *len;
760 match m;
761
762 kind = gfc_default_character_kind ();
763 len = NULL;
764 seen_length = 0;
765
766 /* Try the old-style specification first. */
767 old_char_selector = 0;
768
769 m = match_char_length (&len);
770 if (m != MATCH_NO)
771 {
772 if (m == MATCH_YES)
773 old_char_selector = 1;
774 seen_length = 1;
775 goto done;
776 }
777
778 m = gfc_match_char ('(');
779 if (m != MATCH_YES)
780 {
781 m = MATCH_YES; /* character without length is a single char */
782 goto done;
783 }
784
785 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
786 if (gfc_match (" kind =") == MATCH_YES)
787 {
788 m = gfc_match_small_int (&kind);
789 if (m == MATCH_ERROR)
790 goto done;
791 if (m == MATCH_NO)
792 goto syntax;
793
794 if (gfc_match (" , len =") == MATCH_NO)
795 goto rparen;
796
797 m = char_len_param_value (&len);
798 if (m == MATCH_NO)
799 goto syntax;
800 if (m == MATCH_ERROR)
801 goto done;
802 seen_length = 1;
803
804 goto rparen;
805 }
806
807 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
808 if (gfc_match (" len =") == MATCH_YES)
809 {
810 m = char_len_param_value (&len);
811 if (m == MATCH_NO)
812 goto syntax;
813 if (m == MATCH_ERROR)
814 goto done;
815 seen_length = 1;
816
817 if (gfc_match_char (')') == MATCH_YES)
818 goto done;
819
820 if (gfc_match (" , kind =") != MATCH_YES)
821 goto syntax;
822
823 gfc_match_small_int (&kind);
824
825 if (gfc_validate_kind (BT_CHARACTER, kind) == -1)
826 {
827 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
828 return MATCH_YES;
829 }
830
831 goto rparen;
832 }
833
834 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
835 m = char_len_param_value (&len);
836 if (m == MATCH_NO)
837 goto syntax;
838 if (m == MATCH_ERROR)
839 goto done;
840 seen_length = 1;
841
842 m = gfc_match_char (')');
843 if (m == MATCH_YES)
844 goto done;
845
846 if (gfc_match_char (',') != MATCH_YES)
847 goto syntax;
848
849 gfc_match (" kind ="); /* Gobble optional text */
850
851 m = gfc_match_small_int (&kind);
852 if (m == MATCH_ERROR)
853 goto done;
854 if (m == MATCH_NO)
855 goto syntax;
856
857rparen:
858 /* Require a right-paren at this point. */
859 m = gfc_match_char (')');
860 if (m == MATCH_YES)
861 goto done;
862
863syntax:
864 gfc_error ("Syntax error in CHARACTER declaration at %C");
865 m = MATCH_ERROR;
866
867done:
868 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind) == -1)
869 {
870 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
871 m = MATCH_ERROR;
872 }
873
874 if (m != MATCH_YES)
875 {
876 gfc_free_expr (len);
877 return m;
878 }
879
880 /* Do some final massaging of the length values. */
881 cl = gfc_get_charlen ();
882 cl->next = gfc_current_ns->cl_list;
883 gfc_current_ns->cl_list = cl;
884
885 if (seen_length == 0)
886 cl->length = gfc_int_expr (1);
887 else
888 {
889 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
890 cl->length = len;
891 else
892 {
893 gfc_free_expr (len);
894 cl->length = gfc_int_expr (0);
895 }
896 }
897
898 ts->cl = cl;
899 ts->kind = kind;
900
901 return MATCH_YES;
902}
903
904
905/* Matches a type specification. If successful, sets the ts structure
906 to the matched specification. This is necessary for FUNCTION and
907 IMPLICIT statements.
908
909 If kind_flag is nonzero, then we check for the optional kind
910 specification. Not doing so is needed for matching an IMPLICIT
911 statement correctly. */
912
913match
914gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
915{
916 char name[GFC_MAX_SYMBOL_LEN + 1];
917 gfc_symbol *sym;
918 match m;
919
920 gfc_clear_ts (ts);
921
922 if (gfc_match (" integer") == MATCH_YES)
923 {
924 ts->type = BT_INTEGER;
925 ts->kind = gfc_default_integer_kind ();
926 goto get_kind;
927 }
928
929 if (gfc_match (" character") == MATCH_YES)
930 {
931 ts->type = BT_CHARACTER;
932 return match_char_spec (ts);
933 }
934
935 if (gfc_match (" real") == MATCH_YES)
936 {
937 ts->type = BT_REAL;
938 ts->kind = gfc_default_real_kind ();
939 goto get_kind;
940 }
941
942 if (gfc_match (" double precision") == MATCH_YES)
943 {
944 ts->type = BT_REAL;
945 ts->kind = gfc_default_double_kind ();
946 return MATCH_YES;
947 }
948
949 if (gfc_match (" complex") == MATCH_YES)
950 {
951 ts->type = BT_COMPLEX;
952 ts->kind = gfc_default_complex_kind ();
953 goto get_kind;
954 }
955
956 if (gfc_match (" double complex") == MATCH_YES)
957 {
958 ts->type = BT_COMPLEX;
959 ts->kind = gfc_default_double_kind ();
960 return MATCH_YES;
961 }
962
963 if (gfc_match (" logical") == MATCH_YES)
964 {
965 ts->type = BT_LOGICAL;
966 ts->kind = gfc_default_logical_kind ();
967 goto get_kind;
968 }
969
970 m = gfc_match (" type ( %n )", name);
971 if (m != MATCH_YES)
972 return m;
973
974 /* Search for the name but allow the components to be defined later. */
975 if (gfc_get_ha_symbol (name, &sym))
976 {
977 gfc_error ("Type name '%s' at %C is ambiguous", name);
978 return MATCH_ERROR;
979 }
980
981 if (sym->attr.flavor != FL_DERIVED
982 && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
983 return MATCH_ERROR;
984
985 ts->type = BT_DERIVED;
986 ts->kind = 0;
987 ts->derived = sym;
988
989 return MATCH_YES;
990
991get_kind:
992 /* For all types except double, derived and character, look for an
993 optional kind specifier. MATCH_NO is actually OK at this point. */
994 if (kind_flag == 0)
995 return MATCH_YES;
996
997 m = gfc_match_kind_spec (ts);
998 if (m == MATCH_NO && ts->type != BT_CHARACTER)
999 m = gfc_match_old_kind_spec (ts);
1000
1001 if (m == MATCH_NO)
1002 m = MATCH_YES; /* No kind specifier found. */
1003
1004 return m;
1005}
1006
1007
1008/* Matches an attribute specification including array specs. If
1009 successful, leaves the variables current_attr and current_as
1010 holding the specification. Also sets the colon_seen variable for
1011 later use by matchers associated with initializations.
1012
1013 This subroutine is a little tricky in the sense that we don't know
1014 if we really have an attr-spec until we hit the double colon.
1015 Until that time, we can only return MATCH_NO. This forces us to
1016 check for duplicate specification at this level. */
1017
1018static match
1019match_attr_spec (void)
1020{
1021
1022 /* Modifiers that can exist in a type statement. */
1023 typedef enum
1024 { GFC_DECL_BEGIN = 0,
1025 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1026 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1027 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1028 DECL_TARGET, DECL_COLON, DECL_NONE,
1029 GFC_DECL_END /* Sentinel */
1030 }
1031 decl_types;
1032
1033/* GFC_DECL_END is the sentinel, index starts at 0. */
1034#define NUM_DECL GFC_DECL_END
1035
1036 static mstring decls[] = {
1037 minit (", allocatable", DECL_ALLOCATABLE),
1038 minit (", dimension", DECL_DIMENSION),
1039 minit (", external", DECL_EXTERNAL),
1040 minit (", intent ( in )", DECL_IN),
1041 minit (", intent ( out )", DECL_OUT),
1042 minit (", intent ( in out )", DECL_INOUT),
1043 minit (", intrinsic", DECL_INTRINSIC),
1044 minit (", optional", DECL_OPTIONAL),
1045 minit (", parameter", DECL_PARAMETER),
1046 minit (", pointer", DECL_POINTER),
1047 minit (", private", DECL_PRIVATE),
1048 minit (", public", DECL_PUBLIC),
1049 minit (", save", DECL_SAVE),
1050 minit (", target", DECL_TARGET),
1051 minit ("::", DECL_COLON),
1052 minit (NULL, DECL_NONE)
1053 };
1054
1055 locus start, seen_at[NUM_DECL];
1056 int seen[NUM_DECL];
1057 decl_types d;
1058 const char *attr;
1059 match m;
1060 try t;
1061
1062 gfc_clear_attr (&current_attr);
1063 start = *gfc_current_locus ();
1064
1065 current_as = NULL;
1066 colon_seen = 0;
1067
1068 /* See if we get all of the keywords up to the final double colon. */
1069 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1070 seen[d] = 0;
1071
1072 for (;;)
1073 {
1074 d = (decl_types) gfc_match_strings (decls);
1075 if (d == DECL_NONE || d == DECL_COLON)
1076 break;
1077
1078 seen[d]++;
1079 seen_at[d] = *gfc_current_locus ();
1080
1081 if (d == DECL_DIMENSION)
1082 {
1083 m = gfc_match_array_spec (&current_as);
1084
1085 if (m == MATCH_NO)
1086 {
1087 gfc_error ("Missing dimension specification at %C");
1088 m = MATCH_ERROR;
1089 }
1090
1091 if (m == MATCH_ERROR)
1092 goto cleanup;
1093 }
1094 }
1095
1096 /* No double colon, so assume that we've been looking at something
1097 else the whole time. */
1098 if (d == DECL_NONE)
1099 {
1100 m = MATCH_NO;
1101 goto cleanup;
1102 }
1103
1104 /* Since we've seen a double colon, we have to be looking at an
1105 attr-spec. This means that we can now issue errors. */
1106 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1107 if (seen[d] > 1)
1108 {
1109 switch (d)
1110 {
1111 case DECL_ALLOCATABLE:
1112 attr = "ALLOCATABLE";
1113 break;
1114 case DECL_DIMENSION:
1115 attr = "DIMENSION";
1116 break;
1117 case DECL_EXTERNAL:
1118 attr = "EXTERNAL";
1119 break;
1120 case DECL_IN:
1121 attr = "INTENT (IN)";
1122 break;
1123 case DECL_OUT:
1124 attr = "INTENT (OUT)";
1125 break;
1126 case DECL_INOUT:
1127 attr = "INTENT (IN OUT)";
1128 break;
1129 case DECL_INTRINSIC:
1130 attr = "INTRINSIC";
1131 break;
1132 case DECL_OPTIONAL:
1133 attr = "OPTIONAL";
1134 break;
1135 case DECL_PARAMETER:
1136 attr = "PARAMETER";
1137 break;
1138 case DECL_POINTER:
1139 attr = "POINTER";
1140 break;
1141 case DECL_PRIVATE:
1142 attr = "PRIVATE";
1143 break;
1144 case DECL_PUBLIC:
1145 attr = "PUBLIC";
1146 break;
1147 case DECL_SAVE:
1148 attr = "SAVE";
1149 break;
1150 case DECL_TARGET:
1151 attr = "TARGET";
1152 break;
1153 default:
1154 attr = NULL; /* This shouldn't happen */
1155 }
1156
1157 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1158 m = MATCH_ERROR;
1159 goto cleanup;
1160 }
1161
1162 /* Now that we've dealt with duplicate attributes, add the attributes
1163 to the current attribute. */
1164 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1165 {
1166 if (seen[d] == 0)
1167 continue;
1168
1169 if (gfc_current_state () == COMP_DERIVED
1170 && d != DECL_DIMENSION && d != DECL_POINTER
1171 && d != DECL_COLON && d != DECL_NONE)
1172 {
1173
1174 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1175 &seen_at[d]);
1176 m = MATCH_ERROR;
1177 goto cleanup;
1178 }
1179
1180 switch (d)
1181 {
1182 case DECL_ALLOCATABLE:
1183 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
1184 break;
1185
1186 case DECL_DIMENSION:
1187 t = gfc_add_dimension (&current_attr, &seen_at[d]);
1188 break;
1189
1190 case DECL_EXTERNAL:
1191 t = gfc_add_external (&current_attr, &seen_at[d]);
1192 break;
1193
1194 case DECL_IN:
1195 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
1196 break;
1197
1198 case DECL_OUT:
1199 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
1200 break;
1201
1202 case DECL_INOUT:
1203 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
1204 break;
1205
1206 case DECL_INTRINSIC:
1207 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
1208 break;
1209
1210 case DECL_OPTIONAL:
1211 t = gfc_add_optional (&current_attr, &seen_at[d]);
1212 break;
1213
1214 case DECL_PARAMETER:
1215 t = gfc_add_flavor (&current_attr, FL_PARAMETER, &seen_at[d]);
1216 break;
1217
1218 case DECL_POINTER:
1219 t = gfc_add_pointer (&current_attr, &seen_at[d]);
1220 break;
1221
1222 case DECL_PRIVATE:
1223 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, &seen_at[d]);
1224 break;
1225
1226 case DECL_PUBLIC:
1227 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, &seen_at[d]);
1228 break;
1229
1230 case DECL_SAVE:
1231 t = gfc_add_save (&current_attr, &seen_at[d]);
1232 break;
1233
1234 case DECL_TARGET:
1235 t = gfc_add_target (&current_attr, &seen_at[d]);
1236 break;
1237
1238 default:
1239 gfc_internal_error ("match_attr_spec(): Bad attribute");
1240 }
1241
1242 if (t == FAILURE)
1243 {
1244 m = MATCH_ERROR;
1245 goto cleanup;
1246 }
1247 }
1248
1249 colon_seen = 1;
1250 return MATCH_YES;
1251
1252cleanup:
1253 gfc_set_locus (&start);
1254 gfc_free_array_spec (current_as);
1255 current_as = NULL;
1256 return m;
1257}
1258
1259
1260/* Match a data declaration statement. */
1261
1262match
1263gfc_match_data_decl (void)
1264{
1265 gfc_symbol *sym;
1266 match m;
1267
1268 m = gfc_match_type_spec (&current_ts, 1);
1269 if (m != MATCH_YES)
1270 return m;
1271
1272 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
1273 {
1274 sym = gfc_use_derived (current_ts.derived);
1275
1276 if (sym == NULL)
1277 {
1278 m = MATCH_ERROR;
1279 goto cleanup;
1280 }
1281
1282 current_ts.derived = sym;
1283 }
1284
1285 m = match_attr_spec ();
1286 if (m == MATCH_ERROR)
1287 {
1288 m = MATCH_NO;
1289 goto cleanup;
1290 }
1291
1292 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
1293 {
1294
1295 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
1296 goto ok;
1297
1298 if (gfc_find_symbol (current_ts.derived->name,
1299 current_ts.derived->ns->parent, 1, &sym) == 0)
1300 goto ok;
1301
1302 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1303 if (sym != NULL && sym->attr.flavor == FL_DERIVED)
1304 goto ok;
1305
1306 gfc_error ("Derived type at %C has not been previously defined");
1307 m = MATCH_ERROR;
1308 goto cleanup;
1309 }
1310
1311ok:
1312 /* If we have an old-style character declaration, and no new-style
1313 attribute specifications, then there a comma is optional between
1314 the type specification and the variable list. */
1315 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
1316 gfc_match_char (',');
1317
1318 /* Give the types/attributes to symbols that follow. */
1319 for (;;)
1320 {
1321 m = variable_decl ();
1322 if (m == MATCH_ERROR)
1323 goto cleanup;
1324 if (m == MATCH_NO)
1325 break;
1326
1327 if (gfc_match_eos () == MATCH_YES)
1328 goto cleanup;
1329 if (gfc_match_char (',') != MATCH_YES)
1330 break;
1331 }
1332
1333 gfc_error ("Syntax error in data declaration at %C");
1334 m = MATCH_ERROR;
1335
1336cleanup:
1337 gfc_free_array_spec (current_as);
1338 current_as = NULL;
1339 return m;
1340}
1341
1342
1343/* Match a prefix associated with a function or subroutine
1344 declaration. If the typespec pointer is nonnull, then a typespec
1345 can be matched. Note that if nothing matches, MATCH_YES is
1346 returned (the null string was matched). */
1347
1348static match
1349match_prefix (gfc_typespec * ts)
1350{
1351 int seen_type;
1352
1353 gfc_clear_attr (&current_attr);
1354 seen_type = 0;
1355
1356loop:
1357 if (!seen_type && ts != NULL
1358 && gfc_match_type_spec (ts, 1) == MATCH_YES
1359 && gfc_match_space () == MATCH_YES)
1360 {
1361
1362 seen_type = 1;
1363 goto loop;
1364 }
1365
1366 if (gfc_match ("elemental% ") == MATCH_YES)
1367 {
1368 if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
1369 return MATCH_ERROR;
1370
1371 goto loop;
1372 }
1373
1374 if (gfc_match ("pure% ") == MATCH_YES)
1375 {
1376 if (gfc_add_pure (&current_attr, NULL) == FAILURE)
1377 return MATCH_ERROR;
1378
1379 goto loop;
1380 }
1381
1382 if (gfc_match ("recursive% ") == MATCH_YES)
1383 {
1384 if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
1385 return MATCH_ERROR;
1386
1387 goto loop;
1388 }
1389
1390 /* At this point, the next item is not a prefix. */
1391 return MATCH_YES;
1392}
1393
1394
1395/* Copy attributes matched by match_prefix() to attributes on a symbol. */
1396
1397static try
1398copy_prefix (symbol_attribute * dest, locus * where)
1399{
1400
1401 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
1402 return FAILURE;
1403
1404 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
1405 return FAILURE;
1406
1407 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
1408 return FAILURE;
1409
1410 return SUCCESS;
1411}
1412
1413
1414/* Match a formal argument list. */
1415
1416match
1417gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
1418{
1419 gfc_formal_arglist *head, *tail, *p, *q;
1420 char name[GFC_MAX_SYMBOL_LEN + 1];
1421 gfc_symbol *sym;
1422 match m;
1423
1424 head = tail = NULL;
1425
1426 if (gfc_match_char ('(') != MATCH_YES)
1427 {
1428 if (null_flag)
1429 goto ok;
1430 return MATCH_NO;
1431 }
1432
1433 if (gfc_match_char (')') == MATCH_YES)
1434 goto ok;
1435
1436 for (;;)
1437 {
1438 if (gfc_match_char ('*') == MATCH_YES)
1439 sym = NULL;
1440 else
1441 {
1442 m = gfc_match_name (name);
1443 if (m != MATCH_YES)
1444 goto cleanup;
1445
1446 if (gfc_get_symbol (name, NULL, &sym))
1447 goto cleanup;
1448 }
1449
1450 p = gfc_get_formal_arglist ();
1451
1452 if (head == NULL)
1453 head = tail = p;
1454 else
1455 {
1456 tail->next = p;
1457 tail = p;
1458 }
1459
1460 tail->sym = sym;
1461
1462 /* We don't add the VARIABLE flavor because the name could be a
1463 dummy procedure. We don't apply these attributes to formal
1464 arguments of statement functions. */
1465 if (sym != NULL && !st_flag
1466 && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
1467 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
1468 {
1469 m = MATCH_ERROR;
1470 goto cleanup;
1471 }
1472
1473 /* The name of a program unit can be in a different namespace,
1474 so check for it explicitly. After the statement is accepted,
1475 the name is checked for especially in gfc_get_symbol(). */
1476 if (gfc_new_block != NULL && sym != NULL
1477 && strcmp (sym->name, gfc_new_block->name) == 0)
1478 {
1479 gfc_error ("Name '%s' at %C is the name of the procedure",
1480 sym->name);
1481 m = MATCH_ERROR;
1482 goto cleanup;
1483 }
1484
1485 if (gfc_match_char (')') == MATCH_YES)
1486 goto ok;
1487
1488 m = gfc_match_char (',');
1489 if (m != MATCH_YES)
1490 {
1491 gfc_error ("Unexpected junk in formal argument list at %C");
1492 goto cleanup;
1493 }
1494 }
1495
1496ok:
1497 /* Check for duplicate symbols in the formal argument list. */
1498 if (head != NULL)
1499 {
1500 for (p = head; p->next; p = p->next)
1501 {
1502 if (p->sym == NULL)
1503 continue;
1504
1505 for (q = p->next; q; q = q->next)
1506 if (p->sym == q->sym)
1507 {
1508 gfc_error
1509 ("Duplicate symbol '%s' in formal argument list at %C",
1510 p->sym->name);
1511
1512 m = MATCH_ERROR;
1513 goto cleanup;
1514 }
1515 }
1516 }
1517
1518 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
1519 FAILURE)
1520 {
1521 m = MATCH_ERROR;
1522 goto cleanup;
1523 }
1524
1525 return MATCH_YES;
1526
1527cleanup:
1528 gfc_free_formal_arglist (head);
1529 return m;
1530}
1531
1532
1533/* Match a RESULT specification following a function declaration or
1534 ENTRY statement. Also matches the end-of-statement. */
1535
1536static match
1537match_result (gfc_symbol * function, gfc_symbol ** result)
1538{
1539 char name[GFC_MAX_SYMBOL_LEN + 1];
1540 gfc_symbol *r;
1541 match m;
1542
1543 if (gfc_match (" result (") != MATCH_YES)
1544 return MATCH_NO;
1545
1546 m = gfc_match_name (name);
1547 if (m != MATCH_YES)
1548 return m;
1549
1550 if (gfc_match (" )%t") != MATCH_YES)
1551 {
1552 gfc_error ("Unexpected junk following RESULT variable at %C");
1553 return MATCH_ERROR;
1554 }
1555
1556 if (strcmp (function->name, name) == 0)
1557 {
1558 gfc_error
1559 ("RESULT variable at %C must be different than function name");
1560 return MATCH_ERROR;
1561 }
1562
1563 if (gfc_get_symbol (name, NULL, &r))
1564 return MATCH_ERROR;
1565
1566 if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
1567 || gfc_add_result (&r->attr, NULL) == FAILURE)
1568 return MATCH_ERROR;
1569
1570 *result = r;
1571
1572 return MATCH_YES;
1573}
1574
1575
1576/* Match a function declaration. */
1577
1578match
1579gfc_match_function_decl (void)
1580{
1581 char name[GFC_MAX_SYMBOL_LEN + 1];
1582 gfc_symbol *sym, *result;
1583 locus old_loc;
1584 match m;
1585
1586 if (gfc_current_state () != COMP_NONE
1587 && gfc_current_state () != COMP_INTERFACE
1588 && gfc_current_state () != COMP_CONTAINS)
1589 return MATCH_NO;
1590
1591 gfc_clear_ts (&current_ts);
1592
1593 old_loc = *gfc_current_locus ();
1594
1595 m = match_prefix (&current_ts);
1596 if (m != MATCH_YES)
1597 {
1598 gfc_set_locus (&old_loc);
1599 return m;
1600 }
1601
1602 if (gfc_match ("function% %n", name) != MATCH_YES)
1603 {
1604 gfc_set_locus (&old_loc);
1605 return MATCH_NO;
1606 }
1607
1608 if (get_proc_name (name, &sym))
1609 return MATCH_ERROR;
1610 gfc_new_block = sym;
1611
1612 m = gfc_match_formal_arglist (sym, 0, 0);
1613 if (m == MATCH_NO)
1614 gfc_error ("Expected formal argument list in function definition at %C");
1615 else if (m == MATCH_ERROR)
1616 goto cleanup;
1617
1618 result = NULL;
1619
1620 if (gfc_match_eos () != MATCH_YES)
1621 {
1622 /* See if a result variable is present. */
1623 m = match_result (sym, &result);
1624 if (m == MATCH_NO)
1625 gfc_error ("Unexpected junk after function declaration at %C");
1626
1627 if (m != MATCH_YES)
1628 {
1629 m = MATCH_ERROR;
1630 goto cleanup;
1631 }
1632 }
1633
1634 /* Make changes to the symbol. */
1635 m = MATCH_ERROR;
1636
1637 if (gfc_add_function (&sym->attr, NULL) == FAILURE)
1638 goto cleanup;
1639
1640 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
1641 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1642 goto cleanup;
1643
1644 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
1645 {
1646 gfc_error ("Function '%s' at %C already has a type of %s", name,
1647 gfc_basic_typename (sym->ts.type));
1648 goto cleanup;
1649 }
1650
1651 if (result == NULL)
1652 {
1653 sym->ts = current_ts;
1654 sym->result = sym;
1655 }
1656 else
1657 {
1658 result->ts = current_ts;
1659 sym->result = result;
1660 }
1661
1662 return MATCH_YES;
1663
1664cleanup:
1665 gfc_set_locus (&old_loc);
1666 return m;
1667}
1668
1669
1670/* Match an ENTRY statement. */
1671
1672match
1673gfc_match_entry (void)
1674{
1675 gfc_symbol *function, *result, *entry;
1676 char name[GFC_MAX_SYMBOL_LEN + 1];
1677 gfc_compile_state state;
1678 match m;
1679
1680 m = gfc_match_name (name);
1681 if (m != MATCH_YES)
1682 return m;
1683
1684 if (get_proc_name (name, &entry))
1685 return MATCH_ERROR;
1686
1687 gfc_enclosing_unit (&state);
1688 switch (state)
1689 {
1690 case COMP_SUBROUTINE:
1691 m = gfc_match_formal_arglist (entry, 0, 1);
1692 if (m != MATCH_YES)
1693 return MATCH_ERROR;
1694
1695 if (gfc_current_state () != COMP_SUBROUTINE)
1696 goto exec_construct;
1697
1698 if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1699 || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
1700 return MATCH_ERROR;
1701
1702 break;
1703
1704 case COMP_FUNCTION:
1705 m = gfc_match_formal_arglist (entry, 0, 0);
1706 if (m != MATCH_YES)
1707 return MATCH_ERROR;
1708
1709 if (gfc_current_state () != COMP_FUNCTION)
1710 goto exec_construct;
1711 function = gfc_state_stack->sym;
1712
1713 result = NULL;
1714
1715 if (gfc_match_eos () == MATCH_YES)
1716 {
1717 if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1718 || gfc_add_function (&entry->attr, NULL) == FAILURE)
1719 return MATCH_ERROR;
1720
1721 entry->result = function->result;
1722
1723 }
1724 else
1725 {
1726 m = match_result (function, &result);
1727 if (m == MATCH_NO)
1728 gfc_syntax_error (ST_ENTRY);
1729 if (m != MATCH_YES)
1730 return MATCH_ERROR;
1731
1732 if (gfc_add_result (&result->attr, NULL) == FAILURE
1733 || gfc_add_entry (&entry->attr, NULL) == FAILURE
1734 || gfc_add_function (&entry->attr, NULL) == FAILURE)
1735 return MATCH_ERROR;
1736 }
1737
1738 if (function->attr.recursive && result == NULL)
1739 {
1740 gfc_error ("RESULT attribute required in ENTRY statement at %C");
1741 return MATCH_ERROR;
1742 }
1743
1744 break;
1745
1746 default:
1747 goto exec_construct;
1748 }
1749
1750 if (gfc_match_eos () != MATCH_YES)
1751 {
1752 gfc_syntax_error (ST_ENTRY);
1753 return MATCH_ERROR;
1754 }
1755
1756 return MATCH_YES;
1757
1758exec_construct:
1759 gfc_error ("ENTRY statement at %C cannot appear within %s",
1760 gfc_state_name (gfc_current_state ()));
1761
1762 return MATCH_ERROR;
1763}
1764
1765
1766/* Match a subroutine statement, including optional prefixes. */
1767
1768match
1769gfc_match_subroutine (void)
1770{
1771 char name[GFC_MAX_SYMBOL_LEN + 1];
1772 gfc_symbol *sym;
1773 match m;
1774
1775 if (gfc_current_state () != COMP_NONE
1776 && gfc_current_state () != COMP_INTERFACE
1777 && gfc_current_state () != COMP_CONTAINS)
1778 return MATCH_NO;
1779
1780 m = match_prefix (NULL);
1781 if (m != MATCH_YES)
1782 return m;
1783
1784 m = gfc_match ("subroutine% %n", name);
1785 if (m != MATCH_YES)
1786 return m;
1787
1788 if (get_proc_name (name, &sym))
1789 return MATCH_ERROR;
1790 gfc_new_block = sym;
1791
1792 if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1793 return MATCH_ERROR;
1794
1795 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
1796 return MATCH_ERROR;
1797
1798 if (gfc_match_eos () != MATCH_YES)
1799 {
1800 gfc_syntax_error (ST_SUBROUTINE);
1801 return MATCH_ERROR;
1802 }
1803
1804 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1805 return MATCH_ERROR;
1806
1807 return MATCH_YES;
1808}
1809
1810
1811/* Match any of the various end-block statements. Returns the type of
1812 END to the caller. The END INTERFACE, END IF, END DO and END
1813 SELECT statements cannot be replaced by a single END statement. */
1814
1815match
1816gfc_match_end (gfc_statement * st)
1817{
1818 char name[GFC_MAX_SYMBOL_LEN + 1];
1819 gfc_compile_state state;
1820 locus old_loc;
1821 const char *block_name;
1822 const char *target;
1823 match m;
1824
1825 old_loc = *gfc_current_locus ();
1826 if (gfc_match ("end") != MATCH_YES)
1827 return MATCH_NO;
1828
1829 state = gfc_current_state ();
1830 block_name =
1831 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
1832
1833 if (state == COMP_CONTAINS)
1834 {
1835 state = gfc_state_stack->previous->state;
1836 block_name = gfc_state_stack->previous->sym == NULL ? NULL
1837 : gfc_state_stack->previous->sym->name;
1838 }
1839
1840 switch (state)
1841 {
1842 case COMP_NONE:
1843 case COMP_PROGRAM:
1844 *st = ST_END_PROGRAM;
1845 target = " program";
1846 break;
1847
1848 case COMP_SUBROUTINE:
1849 *st = ST_END_SUBROUTINE;
1850 target = " subroutine";
1851 break;
1852
1853 case COMP_FUNCTION:
1854 *st = ST_END_FUNCTION;
1855 target = " function";
1856 break;
1857
1858 case COMP_BLOCK_DATA:
1859 *st = ST_END_BLOCK_DATA;
1860 target = " block data";
1861 break;
1862
1863 case COMP_MODULE:
1864 *st = ST_END_MODULE;
1865 target = " module";
1866 break;
1867
1868 case COMP_INTERFACE:
1869 *st = ST_END_INTERFACE;
1870 target = " interface";
1871 break;
1872
1873 case COMP_DERIVED:
1874 *st = ST_END_TYPE;
1875 target = " type";
1876 break;
1877
1878 case COMP_IF:
1879 *st = ST_ENDIF;
1880 target = " if";
1881 break;
1882
1883 case COMP_DO:
1884 *st = ST_ENDDO;
1885 target = " do";
1886 break;
1887
1888 case COMP_SELECT:
1889 *st = ST_END_SELECT;
1890 target = " select";
1891 break;
1892
1893 case COMP_FORALL:
1894 *st = ST_END_FORALL;
1895 target = " forall";
1896 break;
1897
1898 case COMP_WHERE:
1899 *st = ST_END_WHERE;
1900 target = " where";
1901 break;
1902
1903 default:
1904 gfc_error ("Unexpected END statement at %C");
1905 goto cleanup;
1906 }
1907
1908 if (gfc_match_eos () == MATCH_YES)
1909 {
1910
1911 if (*st == ST_ENDIF || *st == ST_ENDDO || *st == ST_END_SELECT
1912 || *st == ST_END_INTERFACE || *st == ST_END_FORALL
1913 || *st == ST_END_WHERE)
1914 {
1915
1916 gfc_error ("%s statement expected at %C",
1917 gfc_ascii_statement (*st));
1918 goto cleanup;
1919 }
1920
1921 return MATCH_YES;
1922 }
1923
1924 /* Verify that we've got the sort of end-block that we're expecting. */
1925 if (gfc_match (target) != MATCH_YES)
1926 {
1927 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
1928 goto cleanup;
1929 }
1930
1931 /* If we're at the end, make sure a block name wasn't required. */
1932 if (gfc_match_eos () == MATCH_YES)
1933 {
1934
1935 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
1936 return MATCH_YES;
1937
1938 if (gfc_current_block () == NULL)
1939 return MATCH_YES;
1940
1941 gfc_error ("Expected block name of '%s' in %s statement at %C",
1942 block_name, gfc_ascii_statement (*st));
1943
1944 return MATCH_ERROR;
1945 }
1946
1947 /* END INTERFACE has a special handler for its several possible endings. */
1948 if (*st == ST_END_INTERFACE)
1949 return gfc_match_end_interface ();
1950
1951 /* We haven't hit the end of statement, so what is left must be an end-name. */
1952 m = gfc_match_space ();
1953 if (m == MATCH_YES)
1954 m = gfc_match_name (name);
1955
1956 if (m == MATCH_NO)
1957 gfc_error ("Expected terminating name at %C");
1958 if (m != MATCH_YES)
1959 goto cleanup;
1960
1961 if (block_name == NULL)
1962 goto syntax;
1963
1964 if (strcmp (name, block_name) != 0)
1965 {
1966 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
1967 gfc_ascii_statement (*st));
1968 goto cleanup;
1969 }
1970
1971 if (gfc_match_eos () == MATCH_YES)
1972 return MATCH_YES;
1973
1974syntax:
1975 gfc_syntax_error (*st);
1976
1977cleanup:
1978 gfc_set_locus (&old_loc);
1979 return MATCH_ERROR;
1980}
1981
1982
1983
1984/***************** Attribute declaration statements ****************/
1985
1986/* Set the attribute of a single variable. */
1987
1988static match
1989attr_decl1 (void)
1990{
1991 char name[GFC_MAX_SYMBOL_LEN + 1];
1992 gfc_array_spec *as;
1993 gfc_symbol *sym;
1994 locus var_locus;
1995 match m;
1996
1997 as = NULL;
1998
1999 m = gfc_match_name (name);
2000 if (m != MATCH_YES)
2001 goto cleanup;
2002
2003 if (find_special (name, &sym))
2004 return MATCH_ERROR;
2005
2006 var_locus = *gfc_current_locus ();
2007
2008 /* Deal with possible array specification for certain attributes. */
2009 if (current_attr.dimension
2010 || current_attr.allocatable
2011 || current_attr.pointer
2012 || current_attr.target)
2013 {
2014 m = gfc_match_array_spec (&as);
2015 if (m == MATCH_ERROR)
2016 goto cleanup;
2017
2018 if (current_attr.dimension && m == MATCH_NO)
2019 {
2020 gfc_error
2021 ("Missing array specification at %L in DIMENSION statement",
2022 &var_locus);
2023 m = MATCH_ERROR;
2024 goto cleanup;
2025 }
2026
2027 if ((current_attr.allocatable || current_attr.pointer)
2028 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2029 {
2030 gfc_error ("Array specification must be deferred at %L",
2031 &var_locus);
2032 m = MATCH_ERROR;
2033 goto cleanup;
2034 }
2035 }
2036
2037 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2038 if (current_attr.dimension == 0
2039 && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
2040 {
2041 m = MATCH_ERROR;
2042 goto cleanup;
2043 }
2044
2045 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2046 {
2047 m = MATCH_ERROR;
2048 goto cleanup;
2049 }
2050
2051 if ((current_attr.external || current_attr.intrinsic)
2052 && sym->attr.flavor != FL_PROCEDURE
2053 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
2054 {
2055 m = MATCH_ERROR;
2056 goto cleanup;
2057 }
2058
2059 return MATCH_YES;
2060
2061cleanup:
2062 gfc_free_array_spec (as);
2063 return m;
2064}
2065
2066
2067/* Generic attribute declaration subroutine. Used for attributes that
2068 just have a list of names. */
2069
2070static match
2071attr_decl (void)
2072{
2073 match m;
2074
2075 /* Gobble the optional double colon, by simply ignoring the result
2076 of gfc_match(). */
2077 gfc_match (" ::");
2078
2079 for (;;)
2080 {
2081 m = attr_decl1 ();
2082 if (m != MATCH_YES)
2083 break;
2084
2085 if (gfc_match_eos () == MATCH_YES)
2086 {
2087 m = MATCH_YES;
2088 break;
2089 }
2090
2091 if (gfc_match_char (',') != MATCH_YES)
2092 {
2093 gfc_error ("Unexpected character in variable list at %C");
2094 m = MATCH_ERROR;
2095 break;
2096 }
2097 }
2098
2099 return m;
2100}
2101
2102
2103match
2104gfc_match_external (void)
2105{
2106
2107 gfc_clear_attr (&current_attr);
2108 gfc_add_external (&current_attr, NULL);
2109
2110 return attr_decl ();
2111}
2112
2113
2114
2115match
2116gfc_match_intent (void)
2117{
2118 sym_intent intent;
2119
2120 intent = match_intent_spec ();
2121 if (intent == INTENT_UNKNOWN)
2122 return MATCH_ERROR;
2123
2124 gfc_clear_attr (&current_attr);
2125 gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
2126
2127 return attr_decl ();
2128}
2129
2130
2131match
2132gfc_match_intrinsic (void)
2133{
2134
2135 gfc_clear_attr (&current_attr);
2136 gfc_add_intrinsic (&current_attr, NULL);
2137
2138 return attr_decl ();
2139}
2140
2141
2142match
2143gfc_match_optional (void)
2144{
2145
2146 gfc_clear_attr (&current_attr);
2147 gfc_add_optional (&current_attr, NULL);
2148
2149 return attr_decl ();
2150}
2151
2152
2153match
2154gfc_match_pointer (void)
2155{
2156
2157 gfc_clear_attr (&current_attr);
2158 gfc_add_pointer (&current_attr, NULL);
2159
2160 return attr_decl ();
2161}
2162
2163
2164match
2165gfc_match_allocatable (void)
2166{
2167
2168 gfc_clear_attr (&current_attr);
2169 gfc_add_allocatable (&current_attr, NULL);
2170
2171 return attr_decl ();
2172}
2173
2174
2175match
2176gfc_match_dimension (void)
2177{
2178
2179 gfc_clear_attr (&current_attr);
2180 gfc_add_dimension (&current_attr, NULL);
2181
2182 return attr_decl ();
2183}
2184
2185
2186match
2187gfc_match_target (void)
2188{
2189
2190 gfc_clear_attr (&current_attr);
2191 gfc_add_target (&current_attr, NULL);
2192
2193 return attr_decl ();
2194}
2195
2196
2197/* Match the list of entities being specified in a PUBLIC or PRIVATE
2198 statement. */
2199
2200static match
2201access_attr_decl (gfc_statement st)
2202{
2203 char name[GFC_MAX_SYMBOL_LEN + 1];
2204 interface_type type;
2205 gfc_user_op *uop;
2206 gfc_symbol *sym;
2207 gfc_intrinsic_op operator;
2208 match m;
2209
2210 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2211 goto done;
2212
2213 for (;;)
2214 {
2215 m = gfc_match_generic_spec (&type, name, &operator);
2216 if (m == MATCH_NO)
2217 goto syntax;
2218 if (m == MATCH_ERROR)
2219 return MATCH_ERROR;
2220
2221 switch (type)
2222 {
2223 case INTERFACE_NAMELESS:
2224 goto syntax;
2225
2226 case INTERFACE_GENERIC:
2227 if (gfc_get_symbol (name, NULL, &sym))
2228 goto done;
2229
2230 if (gfc_add_access (&sym->attr,
2231 (st ==
2232 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2233 NULL) == FAILURE)
2234 return MATCH_ERROR;
2235
2236 break;
2237
2238 case INTERFACE_INTRINSIC_OP:
2239 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2240 {
2241 gfc_current_ns->operator_access[operator] =
2242 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2243 }
2244 else
2245 {
2246 gfc_error ("Access specification of the %s operator at %C has "
2247 "already been specified", gfc_op2string (operator));
2248 goto done;
2249 }
2250
2251 break;
2252
2253 case INTERFACE_USER_OP:
2254 uop = gfc_get_uop (name);
2255
2256 if (uop->access == ACCESS_UNKNOWN)
2257 {
2258 uop->access =
2259 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2260 }
2261 else
2262 {
2263 gfc_error
2264 ("Access specification of the .%s. operator at %C has "
2265 "already been specified", sym->name);
2266 goto done;
2267 }
2268
2269 break;
2270 }
2271
2272 if (gfc_match_char (',') == MATCH_NO)
2273 break;
2274 }
2275
2276 if (gfc_match_eos () != MATCH_YES)
2277 goto syntax;
2278 return MATCH_YES;
2279
2280syntax:
2281 gfc_syntax_error (st);
2282
2283done:
2284 return MATCH_ERROR;
2285}
2286
2287
2288/* The PRIVATE statement is a bit weird in that it can be a attribute
2289 declaration, but also works as a standlone statement inside of a
2290 type declaration or a module. */
2291
2292match
2293gfc_match_private (gfc_statement * st)
2294{
2295
2296 if (gfc_match ("private") != MATCH_YES)
2297 return MATCH_NO;
2298
2299 if (gfc_current_state () == COMP_DERIVED)
2300 {
2301 if (gfc_match_eos () == MATCH_YES)
2302 {
2303 *st = ST_PRIVATE;
2304 return MATCH_YES;
2305 }
2306
2307 gfc_syntax_error (ST_PRIVATE);
2308 return MATCH_ERROR;
2309 }
2310
2311 if (gfc_match_eos () == MATCH_YES)
2312 {
2313 *st = ST_PRIVATE;
2314 return MATCH_YES;
2315 }
2316
2317 *st = ST_ATTR_DECL;
2318 return access_attr_decl (ST_PRIVATE);
2319}
2320
2321
2322match
2323gfc_match_public (gfc_statement * st)
2324{
2325
2326 if (gfc_match ("public") != MATCH_YES)
2327 return MATCH_NO;
2328
2329 if (gfc_match_eos () == MATCH_YES)
2330 {
2331 *st = ST_PUBLIC;
2332 return MATCH_YES;
2333 }
2334
2335 *st = ST_ATTR_DECL;
2336 return access_attr_decl (ST_PUBLIC);
2337}
2338
2339
2340/* Workhorse for gfc_match_parameter. */
2341
2342static match
2343do_parm (void)
2344{
2345 gfc_symbol *sym;
2346 gfc_expr *init;
2347 match m;
2348
2349 m = gfc_match_symbol (&sym, 0);
2350 if (m == MATCH_NO)
2351 gfc_error ("Expected variable name at %C in PARAMETER statement");
2352
2353 if (m != MATCH_YES)
2354 return m;
2355
2356 if (gfc_match_char ('=') == MATCH_NO)
2357 {
2358 gfc_error ("Expected = sign in PARAMETER statement at %C");
2359 return MATCH_ERROR;
2360 }
2361
2362 m = gfc_match_init_expr (&init);
2363 if (m == MATCH_NO)
2364 gfc_error ("Expected expression at %C in PARAMETER statement");
2365 if (m != MATCH_YES)
2366 return m;
2367
2368 if (sym->ts.type == BT_UNKNOWN
2369 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2370 {
2371 m = MATCH_ERROR;
2372 goto cleanup;
2373 }
2374
2375 if (gfc_check_assign_symbol (sym, init) == FAILURE
2376 || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
2377 {
2378 m = MATCH_ERROR;
2379 goto cleanup;
2380 }
2381
2382 sym->value = init;
2383 return MATCH_YES;
2384
2385cleanup:
2386 gfc_free_expr (init);
2387 return m;
2388}
2389
2390
2391/* Match a parameter statement, with the weird syntax that these have. */
2392
2393match
2394gfc_match_parameter (void)
2395{
2396 match m;
2397
2398 if (gfc_match_char ('(') == MATCH_NO)
2399 return MATCH_NO;
2400
2401 for (;;)
2402 {
2403 m = do_parm ();
2404 if (m != MATCH_YES)
2405 break;
2406
2407 if (gfc_match (" )%t") == MATCH_YES)
2408 break;
2409
2410 if (gfc_match_char (',') != MATCH_YES)
2411 {
2412 gfc_error ("Unexpected characters in PARAMETER statement at %C");
2413 m = MATCH_ERROR;
2414 break;
2415 }
2416 }
2417
2418 return m;
2419}
2420
2421
2422/* Save statements have a special syntax. */
2423
2424match
2425gfc_match_save (void)
2426{
2427 gfc_symbol *sym;
2428 match m;
2429
2430 if (gfc_match_eos () == MATCH_YES)
2431 {
2432 if (gfc_current_ns->seen_save)
2433 {
2434 gfc_error ("Blanket SAVE statement at %C follows previous "
2435 "SAVE statement");
2436
2437 return MATCH_ERROR;
2438 }
2439
2440 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
2441 return MATCH_YES;
2442 }
2443
2444 if (gfc_current_ns->save_all)
2445 {
2446 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2447 return MATCH_ERROR;
2448 }
2449
2450 gfc_match (" ::");
2451
2452 for (;;)
2453 {
2454 m = gfc_match_symbol (&sym, 0);
2455 switch (m)
2456 {
2457 case MATCH_YES:
2458 if (gfc_add_save (&sym->attr, gfc_current_locus ()) == FAILURE)
2459 return MATCH_ERROR;
2460 goto next_item;
2461
2462 case MATCH_NO:
2463 break;
2464
2465 case MATCH_ERROR:
2466 return MATCH_ERROR;
2467 }
2468
2469 m = gfc_match (" / %s /", &sym);
2470 if (m == MATCH_ERROR)
2471 return MATCH_ERROR;
2472 if (m == MATCH_NO)
2473 goto syntax;
2474
2475 if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE)
2476 return MATCH_ERROR;
2477 gfc_current_ns->seen_save = 1;
2478
2479 next_item:
2480 if (gfc_match_eos () == MATCH_YES)
2481 break;
2482 if (gfc_match_char (',') != MATCH_YES)
2483 goto syntax;
2484 }
2485
2486 return MATCH_YES;
2487
2488syntax:
2489 gfc_error ("Syntax error in SAVE statement at %C");
2490 return MATCH_ERROR;
2491}
2492
2493
2494/* Match a module procedure statement. Note that we have to modify
2495 symbols in the parent's namespace because the current one was there
2496 to receive symbols that are in a interface's formal argument list. */
2497
2498match
2499gfc_match_modproc (void)
2500{
2501 char name[GFC_MAX_SYMBOL_LEN + 1];
2502 gfc_symbol *sym;
2503 match m;
2504
2505 if (gfc_state_stack->state != COMP_INTERFACE
2506 || gfc_state_stack->previous == NULL
2507 || current_interface.type == INTERFACE_NAMELESS)
2508 {
2509 gfc_error
2510 ("MODULE PROCEDURE at %C must be in a generic module interface");
2511 return MATCH_ERROR;
2512 }
2513
2514 for (;;)
2515 {
2516 m = gfc_match_name (name);
2517 if (m == MATCH_NO)
2518 goto syntax;
2519 if (m != MATCH_YES)
2520 return MATCH_ERROR;
2521
2522 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
2523 return MATCH_ERROR;
2524
2525 if (sym->attr.proc != PROC_MODULE
2526 && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
2527 return MATCH_ERROR;
2528
2529 if (gfc_add_interface (sym) == FAILURE)
2530 return MATCH_ERROR;
2531
2532 if (gfc_match_eos () == MATCH_YES)
2533 break;
2534 if (gfc_match_char (',') != MATCH_YES)
2535 goto syntax;
2536 }
2537
2538 return MATCH_YES;
2539
2540syntax:
2541 gfc_syntax_error (ST_MODULE_PROC);
2542 return MATCH_ERROR;
2543}
2544
2545
2546/* Match the beginning of a derived type declaration. If a type name
2547 was the result of a function, then it is possible to have a symbol
2548 already to be known as a derived type yet have no components. */
2549
2550match
2551gfc_match_derived_decl (void)
2552{
2553 char name[GFC_MAX_SYMBOL_LEN + 1];
2554 symbol_attribute attr;
2555 gfc_symbol *sym;
2556 match m;
2557
2558 if (gfc_current_state () == COMP_DERIVED)
2559 return MATCH_NO;
2560
2561 gfc_clear_attr (&attr);
2562
2563loop:
2564 if (gfc_match (" , private") == MATCH_YES)
2565 {
2566 if (gfc_find_state (COMP_MODULE) == FAILURE)
2567 {
2568 gfc_error
2569 ("Derived type at %C can only be PRIVATE within a MODULE");
2570 return MATCH_ERROR;
2571 }
2572
2573 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
2574 return MATCH_ERROR;
2575 goto loop;
2576 }
2577
2578 if (gfc_match (" , public") == MATCH_YES)
2579 {
2580 if (gfc_find_state (COMP_MODULE) == FAILURE)
2581 {
2582 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2583 return MATCH_ERROR;
2584 }
2585
2586 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
2587 return MATCH_ERROR;
2588 goto loop;
2589 }
2590
2591 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
2592 {
2593 gfc_error ("Expected :: in TYPE definition at %C");
2594 return MATCH_ERROR;
2595 }
2596
2597 m = gfc_match (" %n%t", name);
2598 if (m != MATCH_YES)
2599 return m;
2600
2601 /* Make sure the name isn't the name of an intrinsic type. The
2602 'double precision' type doesn't get past the name matcher. */
2603 if (strcmp (name, "integer") == 0
2604 || strcmp (name, "real") == 0
2605 || strcmp (name, "character") == 0
2606 || strcmp (name, "logical") == 0
2607 || strcmp (name, "complex") == 0)
2608 {
2609 gfc_error
2610 ("Type name '%s' at %C cannot be the same as an intrinsic type",
2611 name);
2612 return MATCH_ERROR;
2613 }
2614
2615 if (gfc_get_symbol (name, NULL, &sym))
2616 return MATCH_ERROR;
2617
2618 if (sym->ts.type != BT_UNKNOWN)
2619 {
2620 gfc_error ("Derived type name '%s' at %C already has a basic type "
2621 "of %s", sym->name, gfc_typename (&sym->ts));
2622 return MATCH_ERROR;
2623 }
2624
2625 /* The symbol may already have the derived attribute without the
2626 components. The ways this can happen is via a function
2627 definition, an INTRINSIC statement or a subtype in another
2628 derived type that is a pointer. The first part of the AND clause
2629 is true if a the symbol is not the return value of a function. */
2630 if (sym->attr.flavor != FL_DERIVED
2631 && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
2632 return MATCH_ERROR;
2633
2634 if (sym->components != NULL)
2635 {
2636 gfc_error
2637 ("Derived type definition of '%s' at %C has already been defined",
2638 sym->name);
2639 return MATCH_ERROR;
2640 }
2641
2642 if (attr.access != ACCESS_UNKNOWN
2643 && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
2644 return MATCH_ERROR;
2645
2646 gfc_new_block = sym;
2647
2648 return MATCH_YES;
2649}
Mirror of https://gcc.gnu.org/git/gcc.git