]> gcc.gnu.org Git - gcc.git/blame_incremental - gcc/fortran/decl.c
git://gcc.gnu.org / gcc.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
jvm.h (_Jv_SetGCFreeSpaceDivisor): Declare new function.
[gcc.git] / gcc / fortran / decl.c
... / ...
CommitLineData
1/* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6This file is part of GCC.
7
8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 3, or (at your option) any later
11version.
12
13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
17
18You should have received a copy of the GNU General Public License
19along with GCC; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. */
21
22#include "config.h"
23#include "system.h"
24#include "gfortran.h"
25#include "match.h"
26#include "parse.h"
27
28
29/* Macros to access allocate memory for gfc_data_variable,
30 gfc_data_value and gfc_data. */
31#define gfc_get_data_variable() gfc_getmem (sizeof (gfc_data_variable))
32#define gfc_get_data_value() gfc_getmem (sizeof (gfc_data_value))
33#define gfc_get_data() gfc_getmem( sizeof (gfc_data))
34
35
36/* This flag is set if an old-style length selector is matched
37 during a type-declaration statement. */
38
39static int old_char_selector;
40
41/* When variables acquire types and attributes from a declaration
42 statement, they get them from the following static variables. The
43 first part of a declaration sets these variables and the second
44 part copies these into symbol structures. */
45
46static gfc_typespec current_ts;
47
48static symbol_attribute current_attr;
49static gfc_array_spec *current_as;
50static int colon_seen;
51
52/* The current binding label (if any). */
53static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
54/* Need to know how many identifiers are on the current data declaration
55 line in case we're given the BIND(C) attribute with a NAME= specifier. */
56static int num_idents_on_line;
57/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
58 can supply a name if the curr_binding_label is nil and NAME= was not. */
59static int has_name_equals = 0;
60
61/* Initializer of the previous enumerator. */
62
63static gfc_expr *last_initializer;
64
65/* History of all the enumerators is maintained, so that
66 kind values of all the enumerators could be updated depending
67 upon the maximum initialized value. */
68
69typedef struct enumerator_history
70{
71 gfc_symbol *sym;
72 gfc_expr *initializer;
73 struct enumerator_history *next;
74}
75enumerator_history;
76
77/* Header of enum history chain. */
78
79static enumerator_history *enum_history = NULL;
80
81/* Pointer of enum history node containing largest initializer. */
82
83static enumerator_history *max_enum = NULL;
84
85/* gfc_new_block points to the symbol of a newly matched block. */
86
87gfc_symbol *gfc_new_block;
88
89locus gfc_function_kind_locus;
90locus gfc_function_type_locus;
91
92
93/********************* DATA statement subroutines *********************/
94
95static bool in_match_data = false;
96
97bool
98gfc_in_match_data (void)
99{
100 return in_match_data;
101}
102
103static void
104set_in_match_data (bool set_value)
105{
106 in_match_data = set_value;
107}
108
109/* Free a gfc_data_variable structure and everything beneath it. */
110
111static void
112free_variable (gfc_data_variable *p)
113{
114 gfc_data_variable *q;
115
116 for (; p; p = q)
117 {
118 q = p->next;
119 gfc_free_expr (p->expr);
120 gfc_free_iterator (&p->iter, 0);
121 free_variable (p->list);
122 gfc_free (p);
123 }
124}
125
126
127/* Free a gfc_data_value structure and everything beneath it. */
128
129static void
130free_value (gfc_data_value *p)
131{
132 gfc_data_value *q;
133
134 for (; p; p = q)
135 {
136 q = p->next;
137 gfc_free_expr (p->expr);
138 gfc_free (p);
139 }
140}
141
142
143/* Free a list of gfc_data structures. */
144
145void
146gfc_free_data (gfc_data *p)
147{
148 gfc_data *q;
149
150 for (; p; p = q)
151 {
152 q = p->next;
153 free_variable (p->var);
154 free_value (p->value);
155 gfc_free (p);
156 }
157}
158
159
160/* Free all data in a namespace. */
161
162static void
163gfc_free_data_all (gfc_namespace *ns)
164{
165 gfc_data *d;
166
167 for (;ns->data;)
168 {
169 d = ns->data->next;
170 gfc_free (ns->data);
171 ns->data = d;
172 }
173}
174
175
176static match var_element (gfc_data_variable *);
177
178/* Match a list of variables terminated by an iterator and a right
179 parenthesis. */
180
181static match
182var_list (gfc_data_variable *parent)
183{
184 gfc_data_variable *tail, var;
185 match m;
186
187 m = var_element (&var);
188 if (m == MATCH_ERROR)
189 return MATCH_ERROR;
190 if (m == MATCH_NO)
191 goto syntax;
192
193 tail = gfc_get_data_variable ();
194 *tail = var;
195
196 parent->list = tail;
197
198 for (;;)
199 {
200 if (gfc_match_char (',') != MATCH_YES)
201 goto syntax;
202
203 m = gfc_match_iterator (&parent->iter, 1);
204 if (m == MATCH_YES)
205 break;
206 if (m == MATCH_ERROR)
207 return MATCH_ERROR;
208
209 m = var_element (&var);
210 if (m == MATCH_ERROR)
211 return MATCH_ERROR;
212 if (m == MATCH_NO)
213 goto syntax;
214
215 tail->next = gfc_get_data_variable ();
216 tail = tail->next;
217
218 *tail = var;
219 }
220
221 if (gfc_match_char (')') != MATCH_YES)
222 goto syntax;
223 return MATCH_YES;
224
225syntax:
226 gfc_syntax_error (ST_DATA);
227 return MATCH_ERROR;
228}
229
230
231/* Match a single element in a data variable list, which can be a
232 variable-iterator list. */
233
234static match
235var_element (gfc_data_variable *new)
236{
237 match m;
238 gfc_symbol *sym;
239
240 memset (new, 0, sizeof (gfc_data_variable));
241
242 if (gfc_match_char ('(') == MATCH_YES)
243 return var_list (new);
244
245 m = gfc_match_variable (&new->expr, 0);
246 if (m != MATCH_YES)
247 return m;
248
249 sym = new->expr->symtree->n.sym;
250
251 if (!sym->attr.function && gfc_current_ns->parent
252 && gfc_current_ns->parent == sym->ns)
253 {
254 gfc_error ("Host associated variable '%s' may not be in the DATA "
255 "statement at %C", sym->name);
256 return MATCH_ERROR;
257 }
258
259 if (gfc_current_state () != COMP_BLOCK_DATA
260 && sym->attr.in_common
261 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
262 "common block variable '%s' in DATA statement at %C",
263 sym->name) == FAILURE)
264 return MATCH_ERROR;
265
266 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
267 return MATCH_ERROR;
268
269 return MATCH_YES;
270}
271
272
273/* Match the top-level list of data variables. */
274
275static match
276top_var_list (gfc_data *d)
277{
278 gfc_data_variable var, *tail, *new;
279 match m;
280
281 tail = NULL;
282
283 for (;;)
284 {
285 m = var_element (&var);
286 if (m == MATCH_NO)
287 goto syntax;
288 if (m == MATCH_ERROR)
289 return MATCH_ERROR;
290
291 new = gfc_get_data_variable ();
292 *new = var;
293
294 if (tail == NULL)
295 d->var = new;
296 else
297 tail->next = new;
298
299 tail = new;
300
301 if (gfc_match_char ('/') == MATCH_YES)
302 break;
303 if (gfc_match_char (',') != MATCH_YES)
304 goto syntax;
305 }
306
307 return MATCH_YES;
308
309syntax:
310 gfc_syntax_error (ST_DATA);
311 gfc_free_data_all (gfc_current_ns);
312 return MATCH_ERROR;
313}
314
315
316static match
317match_data_constant (gfc_expr **result)
318{
319 char name[GFC_MAX_SYMBOL_LEN + 1];
320 gfc_symbol *sym;
321 gfc_expr *expr;
322 match m;
323 locus old_loc;
324
325 m = gfc_match_literal_constant (&expr, 1);
326 if (m == MATCH_YES)
327 {
328 *result = expr;
329 return MATCH_YES;
330 }
331
332 if (m == MATCH_ERROR)
333 return MATCH_ERROR;
334
335 m = gfc_match_null (result);
336 if (m != MATCH_NO)
337 return m;
338
339 old_loc = gfc_current_locus;
340
341 /* Should this be a structure component, try to match it
342 before matching a name. */
343 m = gfc_match_rvalue (result);
344 if (m == MATCH_ERROR)
345 return m;
346
347 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
348 {
349 if (gfc_simplify_expr (*result, 0) == FAILURE)
350 m = MATCH_ERROR;
351 return m;
352 }
353
354 gfc_current_locus = old_loc;
355
356 m = gfc_match_name (name);
357 if (m != MATCH_YES)
358 return m;
359
360 if (gfc_find_symbol (name, NULL, 1, &sym))
361 return MATCH_ERROR;
362
363 if (sym == NULL
364 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
365 {
366 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
367 name);
368 return MATCH_ERROR;
369 }
370 else if (sym->attr.flavor == FL_DERIVED)
371 return gfc_match_structure_constructor (sym, result);
372
373 *result = gfc_copy_expr (sym->value);
374 return MATCH_YES;
375}
376
377
378/* Match a list of values in a DATA statement. The leading '/' has
379 already been seen at this point. */
380
381static match
382top_val_list (gfc_data *data)
383{
384 gfc_data_value *new, *tail;
385 gfc_expr *expr;
386 const char *msg;
387 match m;
388
389 tail = NULL;
390
391 for (;;)
392 {
393 m = match_data_constant (&expr);
394 if (m == MATCH_NO)
395 goto syntax;
396 if (m == MATCH_ERROR)
397 return MATCH_ERROR;
398
399 new = gfc_get_data_value ();
400
401 if (tail == NULL)
402 data->value = new;
403 else
404 tail->next = new;
405
406 tail = new;
407
408 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
409 {
410 tail->expr = expr;
411 tail->repeat = 1;
412 }
413 else
414 {
415 signed int tmp;
416 msg = gfc_extract_int (expr, &tmp);
417 gfc_free_expr (expr);
418 if (msg != NULL)
419 {
420 gfc_error (msg);
421 return MATCH_ERROR;
422 }
423 tail->repeat = tmp;
424
425 m = match_data_constant (&tail->expr);
426 if (m == MATCH_NO)
427 goto syntax;
428 if (m == MATCH_ERROR)
429 return MATCH_ERROR;
430 }
431
432 if (gfc_match_char ('/') == MATCH_YES)
433 break;
434 if (gfc_match_char (',') == MATCH_NO)
435 goto syntax;
436 }
437
438 return MATCH_YES;
439
440syntax:
441 gfc_syntax_error (ST_DATA);
442 gfc_free_data_all (gfc_current_ns);
443 return MATCH_ERROR;
444}
445
446
447/* Matches an old style initialization. */
448
449static match
450match_old_style_init (const char *name)
451{
452 match m;
453 gfc_symtree *st;
454 gfc_symbol *sym;
455 gfc_data *newdata;
456
457 /* Set up data structure to hold initializers. */
458 gfc_find_sym_tree (name, NULL, 0, &st);
459 sym = st->n.sym;
460
461 newdata = gfc_get_data ();
462 newdata->var = gfc_get_data_variable ();
463 newdata->var->expr = gfc_get_variable_expr (st);
464 newdata->where = gfc_current_locus;
465
466 /* Match initial value list. This also eats the terminal '/'. */
467 m = top_val_list (newdata);
468 if (m != MATCH_YES)
469 {
470 gfc_free (newdata);
471 return m;
472 }
473
474 if (gfc_pure (NULL))
475 {
476 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
477 gfc_free (newdata);
478 return MATCH_ERROR;
479 }
480
481 /* Mark the variable as having appeared in a data statement. */
482 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
483 {
484 gfc_free (newdata);
485 return MATCH_ERROR;
486 }
487
488 /* Chain in namespace list of DATA initializers. */
489 newdata->next = gfc_current_ns->data;
490 gfc_current_ns->data = newdata;
491
492 return m;
493}
494
495
496/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
497 we are matching a DATA statement and are therefore issuing an error
498 if we encounter something unexpected, if not, we're trying to match
499 an old-style initialization expression of the form INTEGER I /2/. */
500
501match
502gfc_match_data (void)
503{
504 gfc_data *new;
505 match m;
506
507 set_in_match_data (true);
508
509 for (;;)
510 {
511 new = gfc_get_data ();
512 new->where = gfc_current_locus;
513
514 m = top_var_list (new);
515 if (m != MATCH_YES)
516 goto cleanup;
517
518 m = top_val_list (new);
519 if (m != MATCH_YES)
520 goto cleanup;
521
522 new->next = gfc_current_ns->data;
523 gfc_current_ns->data = new;
524
525 if (gfc_match_eos () == MATCH_YES)
526 break;
527
528 gfc_match_char (','); /* Optional comma */
529 }
530
531 set_in_match_data (false);
532
533 if (gfc_pure (NULL))
534 {
535 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
536 return MATCH_ERROR;
537 }
538
539 return MATCH_YES;
540
541cleanup:
542 set_in_match_data (false);
543 gfc_free_data (new);
544 return MATCH_ERROR;
545}
546
547
548/************************ Declaration statements *********************/
549
550/* Match an intent specification. Since this can only happen after an
551 INTENT word, a legal intent-spec must follow. */
552
553static sym_intent
554match_intent_spec (void)
555{
556
557 if (gfc_match (" ( in out )") == MATCH_YES)
558 return INTENT_INOUT;
559 if (gfc_match (" ( in )") == MATCH_YES)
560 return INTENT_IN;
561 if (gfc_match (" ( out )") == MATCH_YES)
562 return INTENT_OUT;
563
564 gfc_error ("Bad INTENT specification at %C");
565 return INTENT_UNKNOWN;
566}
567
568
569/* Matches a character length specification, which is either a
570 specification expression or a '*'. */
571
572static match
573char_len_param_value (gfc_expr **expr)
574{
575 if (gfc_match_char ('*') == MATCH_YES)
576 {
577 *expr = NULL;
578 return MATCH_YES;
579 }
580
581 return gfc_match_expr (expr);
582}
583
584
585/* A character length is a '*' followed by a literal integer or a
586 char_len_param_value in parenthesis. */
587
588static match
589match_char_length (gfc_expr **expr)
590{
591 int length;
592 match m;
593
594 m = gfc_match_char ('*');
595 if (m != MATCH_YES)
596 return m;
597
598 m = gfc_match_small_literal_int (&length, NULL);
599 if (m == MATCH_ERROR)
600 return m;
601
602 if (m == MATCH_YES)
603 {
604 *expr = gfc_int_expr (length);
605 return m;
606 }
607
608 if (gfc_match_char ('(') == MATCH_NO)
609 goto syntax;
610
611 m = char_len_param_value (expr);
612 if (m == MATCH_ERROR)
613 return m;
614 if (m == MATCH_NO)
615 goto syntax;
616
617 if (gfc_match_char (')') == MATCH_NO)
618 {
619 gfc_free_expr (*expr);
620 *expr = NULL;
621 goto syntax;
622 }
623
624 return MATCH_YES;
625
626syntax:
627 gfc_error ("Syntax error in character length specification at %C");
628 return MATCH_ERROR;
629}
630
631
632/* Special subroutine for finding a symbol. Check if the name is found
633 in the current name space. If not, and we're compiling a function or
634 subroutine and the parent compilation unit is an interface, then check
635 to see if the name we've been given is the name of the interface
636 (located in another namespace). */
637
638static int
639find_special (const char *name, gfc_symbol **result)
640{
641 gfc_state_data *s;
642 int i;
643
644 i = gfc_get_symbol (name, NULL, result);
645 if (i == 0)
646 goto end;
647
648 if (gfc_current_state () != COMP_SUBROUTINE
649 && gfc_current_state () != COMP_FUNCTION)
650 goto end;
651
652 s = gfc_state_stack->previous;
653 if (s == NULL)
654 goto end;
655
656 if (s->state != COMP_INTERFACE)
657 goto end;
658 if (s->sym == NULL)
659 goto end; /* Nameless interface. */
660
661 if (strcmp (name, s->sym->name) == 0)
662 {
663 *result = s->sym;
664 return 0;
665 }
666
667end:
668 return i;
669}
670
671
672/* Special subroutine for getting a symbol node associated with a
673 procedure name, used in SUBROUTINE and FUNCTION statements. The
674 symbol is created in the parent using with symtree node in the
675 child unit pointing to the symbol. If the current namespace has no
676 parent, then the symbol is just created in the current unit. */
677
678static int
679get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
680{
681 gfc_symtree *st;
682 gfc_symbol *sym;
683 int rc = 0;
684
685 /* Module functions have to be left in their own namespace because
686 they have potentially (almost certainly!) already been referenced.
687 In this sense, they are rather like external functions. This is
688 fixed up in resolve.c(resolve_entries), where the symbol name-
689 space is set to point to the master function, so that the fake
690 result mechanism can work. */
691 if (module_fcn_entry)
692 {
693 /* Present if entry is declared to be a module procedure. */
694 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
695
696 if (*result == NULL)
697 rc = gfc_get_symbol (name, NULL, result);
698 else if (gfc_get_symbol (name, NULL, &sym) == 0
699 && sym
700 && sym->ts.type != BT_UNKNOWN
701 && (*result)->ts.type == BT_UNKNOWN
702 && sym->attr.flavor == FL_UNKNOWN)
703 /* Pick up the typespec for the entry, if declared in the function
704 body. Note that this symbol is FL_UNKNOWN because it will
705 only have appeared in a type declaration. The local symtree
706 is set to point to the module symbol and a unique symtree
707 to the local version. This latter ensures a correct clearing
708 of the symbols. */
709 {
710 (*result)->ts = sym->ts;
711 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
712 st->n.sym = *result;
713 st = gfc_get_unique_symtree (gfc_current_ns);
714 st->n.sym = sym;
715 }
716 }
717 else
718 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
719
720 if (rc)
721 return rc;
722
723 sym = *result;
724 gfc_current_ns->refs++;
725
726 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
727 {
728 /* Trap another encompassed procedure with the same name. All
729 these conditions are necessary to avoid picking up an entry
730 whose name clashes with that of the encompassing procedure;
731 this is handled using gsymbols to register unique,globally
732 accessible names. */
733 if (sym->attr.flavor != 0
734 && sym->attr.proc != 0
735 && (sym->attr.subroutine || sym->attr.function)
736 && sym->attr.if_source != IFSRC_UNKNOWN)
737 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
738 name, &sym->declared_at);
739
740 /* Trap a procedure with a name the same as interface in the
741 encompassing scope. */
742 if (sym->attr.generic != 0
743 && (sym->attr.subroutine || sym->attr.function)
744 && !sym->attr.mod_proc)
745 gfc_error_now ("Name '%s' at %C is already defined"
746 " as a generic interface at %L",
747 name, &sym->declared_at);
748
749 /* Trap declarations of attributes in encompassing scope. The
750 signature for this is that ts.kind is set. Legitimate
751 references only set ts.type. */
752 if (sym->ts.kind != 0
753 && !sym->attr.implicit_type
754 && sym->attr.proc == 0
755 && gfc_current_ns->parent != NULL
756 && sym->attr.access == 0
757 && !module_fcn_entry)
758 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
759 "and must not have attributes declared at %L",
760 name, &sym->declared_at);
761 }
762
763 if (gfc_current_ns->parent == NULL || *result == NULL)
764 return rc;
765
766 /* Module function entries will already have a symtree in
767 the current namespace but will need one at module level. */
768 if (module_fcn_entry)
769 {
770 /* Present if entry is declared to be a module procedure. */
771 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
772 if (st == NULL)
773 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
774 }
775 else
776 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
777
778 st->n.sym = sym;
779 sym->refs++;
780
781 /* See if the procedure should be a module procedure. */
782
783 if (((sym->ns->proc_name != NULL
784 && sym->ns->proc_name->attr.flavor == FL_MODULE
785 && sym->attr.proc != PROC_MODULE)
786 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
787 && gfc_add_procedure (&sym->attr, PROC_MODULE,
788 sym->name, NULL) == FAILURE)
789 rc = 2;
790
791 return rc;
792}
793
794
795/* Verify that the given symbol representing a parameter is C
796 interoperable, by checking to see if it was marked as such after
797 its declaration. If the given symbol is not interoperable, a
798 warning is reported, thus removing the need to return the status to
799 the calling function. The standard does not require the user use
800 one of the iso_c_binding named constants to declare an
801 interoperable parameter, but we can't be sure if the param is C
802 interop or not if the user doesn't. For example, integer(4) may be
803 legal Fortran, but doesn't have meaning in C. It may interop with
804 a number of the C types, which causes a problem because the
805 compiler can't know which one. This code is almost certainly not
806 portable, and the user will get what they deserve if the C type
807 across platforms isn't always interoperable with integer(4). If
808 the user had used something like integer(c_int) or integer(c_long),
809 the compiler could have automatically handled the varying sizes
810 across platforms. */
811
812try
813verify_c_interop_param (gfc_symbol *sym)
814{
815 int is_c_interop = 0;
816 try retval = SUCCESS;
817
818 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
819 Don't repeat the checks here. */
820 if (sym->attr.implicit_type)
821 return SUCCESS;
822
823 /* For subroutines or functions that are passed to a BIND(C) procedure,
824 they're interoperable if they're BIND(C) and their params are all
825 interoperable. */
826 if (sym->attr.flavor == FL_PROCEDURE)
827 {
828 if (sym->attr.is_bind_c == 0)
829 {
830 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
831 "attribute to be C interoperable", sym->name,
832 &(sym->declared_at));
833
834 return FAILURE;
835 }
836 else
837 {
838 if (sym->attr.is_c_interop == 1)
839 /* We've already checked this procedure; don't check it again. */
840 return SUCCESS;
841 else
842 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
843 sym->common_block);
844 }
845 }
846
847 /* See if we've stored a reference to a procedure that owns sym. */
848 if (sym->ns != NULL && sym->ns->proc_name != NULL)
849 {
850 if (sym->ns->proc_name->attr.is_bind_c == 1)
851 {
852 is_c_interop =
853 (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
854 == SUCCESS ? 1 : 0);
855
856 if (is_c_interop != 1)
857 {
858 /* Make personalized messages to give better feedback. */
859 if (sym->ts.type == BT_DERIVED)
860 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
861 " procedure '%s' but is not C interoperable "
862 "because derived type '%s' is not C interoperable",
863 sym->name, &(sym->declared_at),
864 sym->ns->proc_name->name,
865 sym->ts.derived->name);
866 else
867 gfc_warning ("Variable '%s' at %L is a parameter to the "
868 "BIND(C) procedure '%s' but may not be C "
869 "interoperable",
870 sym->name, &(sym->declared_at),
871 sym->ns->proc_name->name);
872 }
873
874 /* Character strings are only C interoperable if they have a
875 length of 1. */
876 if (sym->ts.type == BT_CHARACTER)
877 {
878 gfc_charlen *cl = sym->ts.cl;
879 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
880 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
881 {
882 gfc_error ("Character argument '%s' at %L "
883 "must be length 1 because "
884 "procedure '%s' is BIND(C)",
885 sym->name, &sym->declared_at,
886 sym->ns->proc_name->name);
887 retval = FAILURE;
888 }
889 }
890
891 /* We have to make sure that any param to a bind(c) routine does
892 not have the allocatable, pointer, or optional attributes,
893 according to J3/04-007, section 5.1. */
894 if (sym->attr.allocatable == 1)
895 {
896 gfc_error ("Variable '%s' at %L cannot have the "
897 "ALLOCATABLE attribute because procedure '%s'"
898 " is BIND(C)", sym->name, &(sym->declared_at),
899 sym->ns->proc_name->name);
900 retval = FAILURE;
901 }
902
903 if (sym->attr.pointer == 1)
904 {
905 gfc_error ("Variable '%s' at %L cannot have the "
906 "POINTER attribute because procedure '%s'"
907 " is BIND(C)", sym->name, &(sym->declared_at),
908 sym->ns->proc_name->name);
909 retval = FAILURE;
910 }
911
912 if (sym->attr.optional == 1)
913 {
914 gfc_error ("Variable '%s' at %L cannot have the "
915 "OPTIONAL attribute because procedure '%s'"
916 " is BIND(C)", sym->name, &(sym->declared_at),
917 sym->ns->proc_name->name);
918 retval = FAILURE;
919 }
920
921 /* Make sure that if it has the dimension attribute, that it is
922 either assumed size or explicit shape. */
923 if (sym->as != NULL)
924 {
925 if (sym->as->type == AS_ASSUMED_SHAPE)
926 {
927 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
928 "argument to the procedure '%s' at %L because "
929 "the procedure is BIND(C)", sym->name,
930 &(sym->declared_at), sym->ns->proc_name->name,
931 &(sym->ns->proc_name->declared_at));
932 retval = FAILURE;
933 }
934
935 if (sym->as->type == AS_DEFERRED)
936 {
937 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
938 "argument to the procedure '%s' at %L because "
939 "the procedure is BIND(C)", sym->name,
940 &(sym->declared_at), sym->ns->proc_name->name,
941 &(sym->ns->proc_name->declared_at));
942 retval = FAILURE;
943 }
944 }
945 }
946 }
947
948 return retval;
949}
950
951
952/* Function called by variable_decl() that adds a name to the symbol table. */
953
954static try
955build_sym (const char *name, gfc_charlen *cl,
956 gfc_array_spec **as, locus *var_locus)
957{
958 symbol_attribute attr;
959 gfc_symbol *sym;
960
961 if (gfc_get_symbol (name, NULL, &sym))
962 return FAILURE;
963
964 /* Start updating the symbol table. Add basic type attribute if present. */
965 if (current_ts.type != BT_UNKNOWN
966 && (sym->attr.implicit_type == 0
967 || !gfc_compare_types (&sym->ts, &current_ts))
968 && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
969 return FAILURE;
970
971 if (sym->ts.type == BT_CHARACTER)
972 sym->ts.cl = cl;
973
974 /* Add dimension attribute if present. */
975 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
976 return FAILURE;
977 *as = NULL;
978
979 /* Add attribute to symbol. The copy is so that we can reset the
980 dimension attribute. */
981 attr = current_attr;
982 attr.dimension = 0;
983
984 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
985 return FAILURE;
986
987 /* Finish any work that may need to be done for the binding label,
988 if it's a bind(c). The bind(c) attr is found before the symbol
989 is made, and before the symbol name (for data decls), so the
990 current_ts is holding the binding label, or nothing if the
991 name= attr wasn't given. Therefore, test here if we're dealing
992 with a bind(c) and make sure the binding label is set correctly. */
993 if (sym->attr.is_bind_c == 1)
994 {
995 if (sym->binding_label[0] == '\0')
996 {
997 /* Set the binding label and verify that if a NAME= was specified
998 then only one identifier was in the entity-decl-list. */
999 if (set_binding_label (sym->binding_label, sym->name,
1000 num_idents_on_line) == FAILURE)
1001 return FAILURE;
1002 }
1003 }
1004
1005 /* See if we know we're in a common block, and if it's a bind(c)
1006 common then we need to make sure we're an interoperable type. */
1007 if (sym->attr.in_common == 1)
1008 {
1009 /* Test the common block object. */
1010 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1011 && sym->ts.is_c_interop != 1)
1012 {
1013 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1014 "must be declared with a C interoperable "
1015 "kind since common block '%s' is BIND(C)",
1016 sym->name, sym->common_block->name,
1017 sym->common_block->name);
1018 gfc_clear_error ();
1019 }
1020 }
1021
1022 sym->attr.implied_index = 0;
1023
1024 return SUCCESS;
1025}
1026
1027
1028/* Set character constant to the given length. The constant will be padded or
1029 truncated. */
1030
1031void
1032gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
1033{
1034 char *s;
1035 int slen;
1036
1037 gcc_assert (expr->expr_type == EXPR_CONSTANT);
1038 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
1039
1040 slen = expr->value.character.length;
1041 if (len != slen)
1042 {
1043 s = gfc_getmem (len + 1);
1044 memcpy (s, expr->value.character.string, MIN (len, slen));
1045 if (len > slen)
1046 memset (&s[slen], ' ', len - slen);
1047
1048 if (gfc_option.warn_character_truncation && slen > len)
1049 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1050 "(%d/%d)", &expr->where, slen, len);
1051
1052 /* Apply the standard by 'hand' otherwise it gets cleared for
1053 initializers. */
1054 if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
1055 gfc_error_now ("The CHARACTER elements of the array constructor "
1056 "at %L must have the same length (%d/%d)",
1057 &expr->where, slen, len);
1058
1059 s[len] = '\0';
1060 gfc_free (expr->value.character.string);
1061 expr->value.character.string = s;
1062 expr->value.character.length = len;
1063 }
1064}
1065
1066
1067/* Function to create and update the enumerator history
1068 using the information passed as arguments.
1069 Pointer "max_enum" is also updated, to point to
1070 enum history node containing largest initializer.
1071
1072 SYM points to the symbol node of enumerator.
1073 INIT points to its enumerator value. */
1074
1075static void
1076create_enum_history (gfc_symbol *sym, gfc_expr *init)
1077{
1078 enumerator_history *new_enum_history;
1079 gcc_assert (sym != NULL && init != NULL);
1080
1081 new_enum_history = gfc_getmem (sizeof (enumerator_history));
1082
1083 new_enum_history->sym = sym;
1084 new_enum_history->initializer = init;
1085 new_enum_history->next = NULL;
1086
1087 if (enum_history == NULL)
1088 {
1089 enum_history = new_enum_history;
1090 max_enum = enum_history;
1091 }
1092 else
1093 {
1094 new_enum_history->next = enum_history;
1095 enum_history = new_enum_history;
1096
1097 if (mpz_cmp (max_enum->initializer->value.integer,
1098 new_enum_history->initializer->value.integer) < 0)
1099 max_enum = new_enum_history;
1100 }
1101}
1102
1103
1104/* Function to free enum kind history. */
1105
1106void
1107gfc_free_enum_history (void)
1108{
1109 enumerator_history *current = enum_history;
1110 enumerator_history *next;
1111
1112 while (current != NULL)
1113 {
1114 next = current->next;
1115 gfc_free (current);
1116 current = next;
1117 }
1118 max_enum = NULL;
1119 enum_history = NULL;
1120}
1121
1122
1123/* Function called by variable_decl() that adds an initialization
1124 expression to a symbol. */
1125
1126static try
1127add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1128{
1129 symbol_attribute attr;
1130 gfc_symbol *sym;
1131 gfc_expr *init;
1132
1133 init = *initp;
1134 if (find_special (name, &sym))
1135 return FAILURE;
1136
1137 attr = sym->attr;
1138
1139 /* If this symbol is confirming an implicit parameter type,
1140 then an initialization expression is not allowed. */
1141 if (attr.flavor == FL_PARAMETER
1142 && sym->value != NULL
1143 && *initp != NULL)
1144 {
1145 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1146 sym->name);
1147 return FAILURE;
1148 }
1149
1150 if (attr.in_common
1151 && !attr.data
1152 && *initp != NULL)
1153 {
1154 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1155 sym->name);
1156 return FAILURE;
1157 }
1158
1159 if (init == NULL)
1160 {
1161 /* An initializer is required for PARAMETER declarations. */
1162 if (attr.flavor == FL_PARAMETER)
1163 {
1164 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1165 return FAILURE;
1166 }
1167 }
1168 else
1169 {
1170 /* If a variable appears in a DATA block, it cannot have an
1171 initializer. */
1172 if (sym->attr.data)
1173 {
1174 gfc_error ("Variable '%s' at %C with an initializer already "
1175 "appears in a DATA statement", sym->name);
1176 return FAILURE;
1177 }
1178
1179 /* Check if the assignment can happen. This has to be put off
1180 until later for a derived type variable. */
1181 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1182 && gfc_check_assign_symbol (sym, init) == FAILURE)
1183 return FAILURE;
1184
1185 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1186 {
1187 /* Update symbol character length according initializer. */
1188 if (sym->ts.cl->length == NULL)
1189 {
1190 int clen;
1191 /* If there are multiple CHARACTER variables declared on the
1192 same line, we don't want them to share the same length. */
1193 sym->ts.cl = gfc_get_charlen ();
1194 sym->ts.cl->next = gfc_current_ns->cl_list;
1195 gfc_current_ns->cl_list = sym->ts.cl;
1196
1197 if (sym->attr.flavor == FL_PARAMETER)
1198 {
1199 if (init->expr_type == EXPR_CONSTANT)
1200 {
1201 clen = init->value.character.length;
1202 sym->ts.cl->length = gfc_int_expr (clen);
1203 }
1204 else if (init->expr_type == EXPR_ARRAY)
1205 {
1206 gfc_expr *p = init->value.constructor->expr;
1207 clen = p->value.character.length;
1208 sym->ts.cl->length = gfc_int_expr (clen);
1209 }
1210 else if (init->ts.cl && init->ts.cl->length)
1211 sym->ts.cl->length =
1212 gfc_copy_expr (sym->value->ts.cl->length);
1213 }
1214 }
1215 /* Update initializer character length according symbol. */
1216 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1217 {
1218 int len = mpz_get_si (sym->ts.cl->length->value.integer);
1219 gfc_constructor * p;
1220
1221 if (init->expr_type == EXPR_CONSTANT)
1222 gfc_set_constant_character_len (len, init, false);
1223 else if (init->expr_type == EXPR_ARRAY)
1224 {
1225 /* Build a new charlen to prevent simplification from
1226 deleting the length before it is resolved. */
1227 init->ts.cl = gfc_get_charlen ();
1228 init->ts.cl->next = gfc_current_ns->cl_list;
1229 gfc_current_ns->cl_list = sym->ts.cl;
1230 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
1231
1232 for (p = init->value.constructor; p; p = p->next)
1233 gfc_set_constant_character_len (len, p->expr, false);
1234 }
1235 }
1236 }
1237
1238 /* Need to check if the expression we initialized this
1239 to was one of the iso_c_binding named constants. If so,
1240 and we're a parameter (constant), let it be iso_c.
1241 For example:
1242 integer(c_int), parameter :: my_int = c_int
1243 integer(my_int) :: my_int_2
1244 If we mark my_int as iso_c (since we can see it's value
1245 is equal to one of the named constants), then my_int_2
1246 will be considered C interoperable. */
1247 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1248 {
1249 sym->ts.is_iso_c |= init->ts.is_iso_c;
1250 sym->ts.is_c_interop |= init->ts.is_c_interop;
1251 /* attr bits needed for module files. */
1252 sym->attr.is_iso_c |= init->ts.is_iso_c;
1253 sym->attr.is_c_interop |= init->ts.is_c_interop;
1254 if (init->ts.is_iso_c)
1255 sym->ts.f90_type = init->ts.f90_type;
1256 }
1257
1258 /* Add initializer. Make sure we keep the ranks sane. */
1259 if (sym->attr.dimension && init->rank == 0)
1260 {
1261 mpz_t size;
1262 gfc_expr *array;
1263 gfc_constructor *c;
1264 int n;
1265 if (sym->attr.flavor == FL_PARAMETER
1266 && init->expr_type == EXPR_CONSTANT
1267 && spec_size (sym->as, &size) == SUCCESS
1268 && mpz_cmp_si (size, 0) > 0)
1269 {
1270 array = gfc_start_constructor (init->ts.type, init->ts.kind,
1271 &init->where);
1272
1273 array->value.constructor = c = NULL;
1274 for (n = 0; n < (int)mpz_get_si (size); n++)
1275 {
1276 if (array->value.constructor == NULL)
1277 {
1278 array->value.constructor = c = gfc_get_constructor ();
1279 c->expr = init;
1280 }
1281 else
1282 {
1283 c->next = gfc_get_constructor ();
1284 c = c->next;
1285 c->expr = gfc_copy_expr (init);
1286 }
1287 }
1288
1289 array->shape = gfc_get_shape (sym->as->rank);
1290 for (n = 0; n < sym->as->rank; n++)
1291 spec_dimen_size (sym->as, n, &array->shape[n]);
1292
1293 init = array;
1294 mpz_clear (size);
1295 }
1296 init->rank = sym->as->rank;
1297 }
1298
1299 sym->value = init;
1300 if (sym->attr.save == SAVE_NONE)
1301 sym->attr.save = SAVE_IMPLICIT;
1302 *initp = NULL;
1303 }
1304
1305 return SUCCESS;
1306}
1307
1308
1309/* Function called by variable_decl() that adds a name to a structure
1310 being built. */
1311
1312static try
1313build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1314 gfc_array_spec **as)
1315{
1316 gfc_component *c;
1317
1318 /* If the current symbol is of the same derived type that we're
1319 constructing, it must have the pointer attribute. */
1320 if (current_ts.type == BT_DERIVED
1321 && current_ts.derived == gfc_current_block ()
1322 && current_attr.pointer == 0)
1323 {
1324 gfc_error ("Component at %C must have the POINTER attribute");
1325 return FAILURE;
1326 }
1327
1328 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1329 {
1330 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1331 {
1332 gfc_error ("Array component of structure at %C must have explicit "
1333 "or deferred shape");
1334 return FAILURE;
1335 }
1336 }
1337
1338 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1339 return FAILURE;
1340
1341 c->ts = current_ts;
1342 c->ts.cl = cl;
1343 gfc_set_component_attr (c, &current_attr);
1344
1345 c->initializer = *init;
1346 *init = NULL;
1347
1348 c->as = *as;
1349 if (c->as != NULL)
1350 c->dimension = 1;
1351 *as = NULL;
1352
1353 /* Check array components. */
1354 if (!c->dimension)
1355 {
1356 if (c->allocatable)
1357 {
1358 gfc_error ("Allocatable component at %C must be an array");
1359 return FAILURE;
1360 }
1361 else
1362 return SUCCESS;
1363 }
1364
1365 if (c->pointer)
1366 {
1367 if (c->as->type != AS_DEFERRED)
1368 {
1369 gfc_error ("Pointer array component of structure at %C must have a "
1370 "deferred shape");
1371 return FAILURE;
1372 }
1373 }
1374 else if (c->allocatable)
1375 {
1376 if (c->as->type != AS_DEFERRED)
1377 {
1378 gfc_error ("Allocatable component of structure at %C must have a "
1379 "deferred shape");
1380 return FAILURE;
1381 }
1382 }
1383 else
1384 {
1385 if (c->as->type != AS_EXPLICIT)
1386 {
1387 gfc_error ("Array component of structure at %C must have an "
1388 "explicit shape");
1389 return FAILURE;
1390 }
1391 }
1392
1393 return SUCCESS;
1394}
1395
1396
1397/* Match a 'NULL()', and possibly take care of some side effects. */
1398
1399match
1400gfc_match_null (gfc_expr **result)
1401{
1402 gfc_symbol *sym;
1403 gfc_expr *e;
1404 match m;
1405
1406 m = gfc_match (" null ( )");
1407 if (m != MATCH_YES)
1408 return m;
1409
1410 /* The NULL symbol now has to be/become an intrinsic function. */
1411 if (gfc_get_symbol ("null", NULL, &sym))
1412 {
1413 gfc_error ("NULL() initialization at %C is ambiguous");
1414 return MATCH_ERROR;
1415 }
1416
1417 gfc_intrinsic_symbol (sym);
1418
1419 if (sym->attr.proc != PROC_INTRINSIC
1420 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1421 sym->name, NULL) == FAILURE
1422 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1423 return MATCH_ERROR;
1424
1425 e = gfc_get_expr ();
1426 e->where = gfc_current_locus;
1427 e->expr_type = EXPR_NULL;
1428 e->ts.type = BT_UNKNOWN;
1429
1430 *result = e;
1431
1432 return MATCH_YES;
1433}
1434
1435
1436/* Match a variable name with an optional initializer. When this
1437 subroutine is called, a variable is expected to be parsed next.
1438 Depending on what is happening at the moment, updates either the
1439 symbol table or the current interface. */
1440
1441static match
1442variable_decl (int elem)
1443{
1444 char name[GFC_MAX_SYMBOL_LEN + 1];
1445 gfc_expr *initializer, *char_len;
1446 gfc_array_spec *as;
1447 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1448 gfc_charlen *cl;
1449 locus var_locus;
1450 match m;
1451 try t;
1452 gfc_symbol *sym;
1453 locus old_locus;
1454
1455 initializer = NULL;
1456 as = NULL;
1457 cp_as = NULL;
1458 old_locus = gfc_current_locus;
1459
1460 /* When we get here, we've just matched a list of attributes and
1461 maybe a type and a double colon. The next thing we expect to see
1462 is the name of the symbol. */
1463 m = gfc_match_name (name);
1464 if (m != MATCH_YES)
1465 goto cleanup;
1466
1467 var_locus = gfc_current_locus;
1468
1469 /* Now we could see the optional array spec. or character length. */
1470 m = gfc_match_array_spec (&as);
1471 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1472 cp_as = gfc_copy_array_spec (as);
1473 else if (m == MATCH_ERROR)
1474 goto cleanup;
1475
1476 if (m == MATCH_NO)
1477 as = gfc_copy_array_spec (current_as);
1478
1479 char_len = NULL;
1480 cl = NULL;
1481
1482 if (current_ts.type == BT_CHARACTER)
1483 {
1484 switch (match_char_length (&char_len))
1485 {
1486 case MATCH_YES:
1487 cl = gfc_get_charlen ();
1488 cl->next = gfc_current_ns->cl_list;
1489 gfc_current_ns->cl_list = cl;
1490
1491 cl->length = char_len;
1492 break;
1493
1494 /* Non-constant lengths need to be copied after the first
1495 element. Also copy assumed lengths. */
1496 case MATCH_NO:
1497 if (elem > 1
1498 && (current_ts.cl->length == NULL
1499 || current_ts.cl->length->expr_type != EXPR_CONSTANT))
1500 {
1501 cl = gfc_get_charlen ();
1502 cl->next = gfc_current_ns->cl_list;
1503 gfc_current_ns->cl_list = cl;
1504 cl->length = gfc_copy_expr (current_ts.cl->length);
1505 }
1506 else
1507 cl = current_ts.cl;
1508
1509 break;
1510
1511 case MATCH_ERROR:
1512 goto cleanup;
1513 }
1514 }
1515
1516 /* If this symbol has already shown up in a Cray Pointer declaration,
1517 then we want to set the type & bail out. */
1518 if (gfc_option.flag_cray_pointer)
1519 {
1520 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1521 if (sym != NULL && sym->attr.cray_pointee)
1522 {
1523 sym->ts.type = current_ts.type;
1524 sym->ts.kind = current_ts.kind;
1525 sym->ts.cl = cl;
1526 sym->ts.derived = current_ts.derived;
1527 sym->ts.is_c_interop = current_ts.is_c_interop;
1528 sym->ts.is_iso_c = current_ts.is_iso_c;
1529 m = MATCH_YES;
1530
1531 /* Check to see if we have an array specification. */
1532 if (cp_as != NULL)
1533 {
1534 if (sym->as != NULL)
1535 {
1536 gfc_error ("Duplicate array spec for Cray pointee at %C");
1537 gfc_free_array_spec (cp_as);
1538 m = MATCH_ERROR;
1539 goto cleanup;
1540 }
1541 else
1542 {
1543 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1544 gfc_internal_error ("Couldn't set pointee array spec.");
1545
1546 /* Fix the array spec. */
1547 m = gfc_mod_pointee_as (sym->as);
1548 if (m == MATCH_ERROR)
1549 goto cleanup;
1550 }
1551 }
1552 goto cleanup;
1553 }
1554 else
1555 {
1556 gfc_free_array_spec (cp_as);
1557 }
1558 }
1559
1560
1561 /* OK, we've successfully matched the declaration. Now put the
1562 symbol in the current namespace, because it might be used in the
1563 optional initialization expression for this symbol, e.g. this is
1564 perfectly legal:
1565
1566 integer, parameter :: i = huge(i)
1567
1568 This is only true for parameters or variables of a basic type.
1569 For components of derived types, it is not true, so we don't
1570 create a symbol for those yet. If we fail to create the symbol,
1571 bail out. */
1572 if (gfc_current_state () != COMP_DERIVED
1573 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1574 {
1575 m = MATCH_ERROR;
1576 goto cleanup;
1577 }
1578
1579 /* An interface body specifies all of the procedure's
1580 characteristics and these shall be consistent with those
1581 specified in the procedure definition, except that the interface
1582 may specify a procedure that is not pure if the procedure is
1583 defined to be pure(12.3.2). */
1584 if (current_ts.type == BT_DERIVED
1585 && gfc_current_ns->proc_name
1586 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1587 && current_ts.derived->ns != gfc_current_ns)
1588 {
1589 gfc_symtree *st;
1590 st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
1591 if (!(current_ts.derived->attr.imported
1592 && st != NULL
1593 && st->n.sym == current_ts.derived)
1594 && !gfc_current_ns->has_import_set)
1595 {
1596 gfc_error ("the type of '%s' at %C has not been declared within the "
1597 "interface", name);
1598 m = MATCH_ERROR;
1599 goto cleanup;
1600 }
1601 }
1602
1603 /* In functions that have a RESULT variable defined, the function
1604 name always refers to function calls. Therefore, the name is
1605 not allowed to appear in specification statements. */
1606 if (gfc_current_state () == COMP_FUNCTION
1607 && gfc_current_block () != NULL
1608 && gfc_current_block ()->result != NULL
1609 && gfc_current_block ()->result != gfc_current_block ()
1610 && strcmp (gfc_current_block ()->name, name) == 0)
1611 {
1612 gfc_error ("Function name '%s' not allowed at %C", name);
1613 m = MATCH_ERROR;
1614 goto cleanup;
1615 }
1616
1617 /* We allow old-style initializations of the form
1618 integer i /2/, j(4) /3*3, 1/
1619 (if no colon has been seen). These are different from data
1620 statements in that initializers are only allowed to apply to the
1621 variable immediately preceding, i.e.
1622 integer i, j /1, 2/
1623 is not allowed. Therefore we have to do some work manually, that
1624 could otherwise be left to the matchers for DATA statements. */
1625
1626 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1627 {
1628 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1629 "initialization at %C") == FAILURE)
1630 return MATCH_ERROR;
1631
1632 return match_old_style_init (name);
1633 }
1634
1635 /* The double colon must be present in order to have initializers.
1636 Otherwise the statement is ambiguous with an assignment statement. */
1637 if (colon_seen)
1638 {
1639 if (gfc_match (" =>") == MATCH_YES)
1640 {
1641 if (!current_attr.pointer)
1642 {
1643 gfc_error ("Initialization at %C isn't for a pointer variable");
1644 m = MATCH_ERROR;
1645 goto cleanup;
1646 }
1647
1648 m = gfc_match_null (&initializer);
1649 if (m == MATCH_NO)
1650 {
1651 gfc_error ("Pointer initialization requires a NULL() at %C");
1652 m = MATCH_ERROR;
1653 }
1654
1655 if (gfc_pure (NULL))
1656 {
1657 gfc_error ("Initialization of pointer at %C is not allowed in "
1658 "a PURE procedure");
1659 m = MATCH_ERROR;
1660 }
1661
1662 if (m != MATCH_YES)
1663 goto cleanup;
1664
1665 }
1666 else if (gfc_match_char ('=') == MATCH_YES)
1667 {
1668 if (current_attr.pointer)
1669 {
1670 gfc_error ("Pointer initialization at %C requires '=>', "
1671 "not '='");
1672 m = MATCH_ERROR;
1673 goto cleanup;
1674 }
1675
1676 m = gfc_match_init_expr (&initializer);
1677 if (m == MATCH_NO)
1678 {
1679 gfc_error ("Expected an initialization expression at %C");
1680 m = MATCH_ERROR;
1681 }
1682
1683 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1684 {
1685 gfc_error ("Initialization of variable at %C is not allowed in "
1686 "a PURE procedure");
1687 m = MATCH_ERROR;
1688 }
1689
1690 if (m != MATCH_YES)
1691 goto cleanup;
1692 }
1693 }
1694
1695 if (initializer != NULL && current_attr.allocatable
1696 && gfc_current_state () == COMP_DERIVED)
1697 {
1698 gfc_error ("Initialization of allocatable component at %C is not "
1699 "allowed");
1700 m = MATCH_ERROR;
1701 goto cleanup;
1702 }
1703
1704 /* Add the initializer. Note that it is fine if initializer is
1705 NULL here, because we sometimes also need to check if a
1706 declaration *must* have an initialization expression. */
1707 if (gfc_current_state () != COMP_DERIVED)
1708 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1709 else
1710 {
1711 if (current_ts.type == BT_DERIVED
1712 && !current_attr.pointer && !initializer)
1713 initializer = gfc_default_initializer (&current_ts);
1714 t = build_struct (name, cl, &initializer, &as);
1715 }
1716
1717 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1718
1719cleanup:
1720 /* Free stuff up and return. */
1721 gfc_free_expr (initializer);
1722 gfc_free_array_spec (as);
1723
1724 return m;
1725}
1726
1727
1728/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1729 This assumes that the byte size is equal to the kind number for
1730 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1731
1732match
1733gfc_match_old_kind_spec (gfc_typespec *ts)
1734{
1735 match m;
1736 int original_kind;
1737
1738 if (gfc_match_char ('*') != MATCH_YES)
1739 return MATCH_NO;
1740
1741 m = gfc_match_small_literal_int (&ts->kind, NULL);
1742 if (m != MATCH_YES)
1743 return MATCH_ERROR;
1744
1745 original_kind = ts->kind;
1746
1747 /* Massage the kind numbers for complex types. */
1748 if (ts->type == BT_COMPLEX)
1749 {
1750 if (ts->kind % 2)
1751 {
1752 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1753 gfc_basic_typename (ts->type), original_kind);
1754 return MATCH_ERROR;
1755 }
1756 ts->kind /= 2;
1757 }
1758
1759 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1760 {
1761 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1762 gfc_basic_typename (ts->type), original_kind);
1763 return MATCH_ERROR;
1764 }
1765
1766 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1767 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1768 return MATCH_ERROR;
1769
1770 return MATCH_YES;
1771}
1772
1773
1774/* Match a kind specification. Since kinds are generally optional, we
1775 usually return MATCH_NO if something goes wrong. If a "kind="
1776 string is found, then we know we have an error. */
1777
1778match
1779gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
1780{
1781 locus where, loc;
1782 gfc_expr *e;
1783 match m, n;
1784 const char *msg;
1785
1786 m = MATCH_NO;
1787 n = MATCH_YES;
1788 e = NULL;
1789
1790 where = loc = gfc_current_locus;
1791
1792 if (kind_expr_only)
1793 goto kind_expr;
1794
1795 if (gfc_match_char ('(') == MATCH_NO)
1796 return MATCH_NO;
1797
1798 /* Also gobbles optional text. */
1799 if (gfc_match (" kind = ") == MATCH_YES)
1800 m = MATCH_ERROR;
1801
1802 loc = gfc_current_locus;
1803
1804kind_expr:
1805 n = gfc_match_init_expr (&e);
1806
1807 if (n != MATCH_YES)
1808 {
1809 if (gfc_current_state () == COMP_INTERFACE
1810 || gfc_current_state () == COMP_NONE
1811 || gfc_current_state () == COMP_CONTAINS)
1812 {
1813 /* Signal using kind = -1 that the expression might include
1814 use associated or imported parameters and try again after
1815 the specification expressions..... */
1816 if (gfc_match_char (')') != MATCH_YES)
1817 {
1818 gfc_error ("Missing right parenthesis at %C");
1819 m = MATCH_ERROR;
1820 goto no_match;
1821 }
1822
1823 gfc_free_expr (e);
1824 ts->kind = -1;
1825 gfc_function_kind_locus = loc;
1826 gfc_undo_symbols ();
1827 return MATCH_YES;
1828 }
1829 else
1830 {
1831 /* ....or else, the match is real. */
1832 if (n == MATCH_NO)
1833 gfc_error ("Expected initialization expression at %C");
1834 if (n != MATCH_YES)
1835 return MATCH_ERROR;
1836 }
1837 }
1838
1839 if (e->rank != 0)
1840 {
1841 gfc_error ("Expected scalar initialization expression at %C");
1842 m = MATCH_ERROR;
1843 goto no_match;
1844 }
1845
1846 msg = gfc_extract_int (e, &ts->kind);
1847 if (msg != NULL)
1848 {
1849 gfc_error (msg);
1850 m = MATCH_ERROR;
1851 goto no_match;
1852 }
1853
1854 /* Before throwing away the expression, let's see if we had a
1855 C interoperable kind (and store the fact). */
1856 if (e->ts.is_c_interop == 1)
1857 {
1858 /* Mark this as c interoperable if being declared with one
1859 of the named constants from iso_c_binding. */
1860 ts->is_c_interop = e->ts.is_iso_c;
1861 ts->f90_type = e->ts.f90_type;
1862 }
1863
1864 gfc_free_expr (e);
1865 e = NULL;
1866
1867 /* Ignore errors to this point, if we've gotten here. This means
1868 we ignore the m=MATCH_ERROR from above. */
1869 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1870 {
1871 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1872 gfc_basic_typename (ts->type));
1873 m = MATCH_ERROR;
1874 }
1875 else if (gfc_match_char (')') != MATCH_YES)
1876 {
1877 gfc_error ("Missing right parenthesis at %C");
1878 m = MATCH_ERROR;
1879 }
1880 else
1881 /* All tests passed. */
1882 m = MATCH_YES;
1883
1884 if(m == MATCH_ERROR)
1885 gfc_current_locus = where;
1886
1887 /* Return what we know from the test(s). */
1888 return m;
1889
1890no_match:
1891 gfc_free_expr (e);
1892 gfc_current_locus = where;
1893 return m;
1894}
1895
1896
1897static match
1898match_char_kind (int * kind, int * is_iso_c)
1899{
1900 locus where;
1901 gfc_expr *e;
1902 match m, n;
1903 const char *msg;
1904
1905 m = MATCH_NO;
1906 e = NULL;
1907 where = gfc_current_locus;
1908
1909 n = gfc_match_init_expr (&e);
1910 if (n == MATCH_NO)
1911 gfc_error ("Expected initialization expression at %C");
1912 if (n != MATCH_YES)
1913 return MATCH_ERROR;
1914
1915 if (e->rank != 0)
1916 {
1917 gfc_error ("Expected scalar initialization expression at %C");
1918 m = MATCH_ERROR;
1919 goto no_match;
1920 }
1921
1922 msg = gfc_extract_int (e, kind);
1923 *is_iso_c = e->ts.is_iso_c;
1924 if (msg != NULL)
1925 {
1926 gfc_error (msg);
1927 m = MATCH_ERROR;
1928 goto no_match;
1929 }
1930
1931 gfc_free_expr (e);
1932
1933 /* Ignore errors to this point, if we've gotten here. This means
1934 we ignore the m=MATCH_ERROR from above. */
1935 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
1936 {
1937 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
1938 m = MATCH_ERROR;
1939 }
1940 else
1941 /* All tests passed. */
1942 m = MATCH_YES;
1943
1944 if (m == MATCH_ERROR)
1945 gfc_current_locus = where;
1946
1947 /* Return what we know from the test(s). */
1948 return m;
1949
1950no_match:
1951 gfc_free_expr (e);
1952 gfc_current_locus = where;
1953 return m;
1954}
1955
1956/* Match the various kind/length specifications in a CHARACTER
1957 declaration. We don't return MATCH_NO. */
1958
1959static match
1960match_char_spec (gfc_typespec *ts)
1961{
1962 int kind, seen_length, is_iso_c;
1963 gfc_charlen *cl;
1964 gfc_expr *len;
1965 match m;
1966
1967 len = NULL;
1968 seen_length = 0;
1969 kind = 0;
1970 is_iso_c = 0;
1971
1972 /* Try the old-style specification first. */
1973 old_char_selector = 0;
1974
1975 m = match_char_length (&len);
1976 if (m != MATCH_NO)
1977 {
1978 if (m == MATCH_YES)
1979 old_char_selector = 1;
1980 seen_length = 1;
1981 goto done;
1982 }
1983
1984 m = gfc_match_char ('(');
1985 if (m != MATCH_YES)
1986 {
1987 m = MATCH_YES; /* Character without length is a single char. */
1988 goto done;
1989 }
1990
1991 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
1992 if (gfc_match (" kind =") == MATCH_YES)
1993 {
1994 m = match_char_kind (&kind, &is_iso_c);
1995
1996 if (m == MATCH_ERROR)
1997 goto done;
1998 if (m == MATCH_NO)
1999 goto syntax;
2000
2001 if (gfc_match (" , len =") == MATCH_NO)
2002 goto rparen;
2003
2004 m = char_len_param_value (&len);
2005 if (m == MATCH_NO)
2006 goto syntax;
2007 if (m == MATCH_ERROR)
2008 goto done;
2009 seen_length = 1;
2010
2011 goto rparen;
2012 }
2013
2014 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2015 if (gfc_match (" len =") == MATCH_YES)
2016 {
2017 m = char_len_param_value (&len);
2018 if (m == MATCH_NO)
2019 goto syntax;
2020 if (m == MATCH_ERROR)
2021 goto done;
2022 seen_length = 1;
2023
2024 if (gfc_match_char (')') == MATCH_YES)
2025 goto done;
2026
2027 if (gfc_match (" , kind =") != MATCH_YES)
2028 goto syntax;
2029
2030 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2031 goto done;
2032
2033 goto rparen;
2034 }
2035
2036 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2037 m = char_len_param_value (&len);
2038 if (m == MATCH_NO)
2039 goto syntax;
2040 if (m == MATCH_ERROR)
2041 goto done;
2042 seen_length = 1;
2043
2044 m = gfc_match_char (')');
2045 if (m == MATCH_YES)
2046 goto done;
2047
2048 if (gfc_match_char (',') != MATCH_YES)
2049 goto syntax;
2050
2051 gfc_match (" kind ="); /* Gobble optional text. */
2052
2053 m = match_char_kind (&kind, &is_iso_c);
2054 if (m == MATCH_ERROR)
2055 goto done;
2056 if (m == MATCH_NO)
2057 goto syntax;
2058
2059rparen:
2060 /* Require a right-paren at this point. */
2061 m = gfc_match_char (')');
2062 if (m == MATCH_YES)
2063 goto done;
2064
2065syntax:
2066 gfc_error ("Syntax error in CHARACTER declaration at %C");
2067 m = MATCH_ERROR;
2068 gfc_free_expr (len);
2069 return m;
2070
2071done:
2072 if (m != MATCH_YES)
2073 {
2074 gfc_free_expr (len);
2075 return m;
2076 }
2077
2078 /* Do some final massaging of the length values. */
2079 cl = gfc_get_charlen ();
2080 cl->next = gfc_current_ns->cl_list;
2081 gfc_current_ns->cl_list = cl;
2082
2083 if (seen_length == 0)
2084 cl->length = gfc_int_expr (1);
2085 else
2086 cl->length = len;
2087
2088 ts->cl = cl;
2089 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2090
2091 /* We have to know if it was a c interoperable kind so we can
2092 do accurate type checking of bind(c) procs, etc. */
2093 if (kind != 0)
2094 /* Mark this as c interoperable if being declared with one
2095 of the named constants from iso_c_binding. */
2096 ts->is_c_interop = is_iso_c;
2097 else if (len != NULL)
2098 /* Here, we might have parsed something such as: character(c_char)
2099 In this case, the parsing code above grabs the c_char when
2100 looking for the length (line 1690, roughly). it's the last
2101 testcase for parsing the kind params of a character variable.
2102 However, it's not actually the length. this seems like it
2103 could be an error.
2104 To see if the user used a C interop kind, test the expr
2105 of the so called length, and see if it's C interoperable. */
2106 ts->is_c_interop = len->ts.is_iso_c;
2107
2108 return MATCH_YES;
2109}
2110
2111
2112/* Matches a type specification. If successful, sets the ts structure
2113 to the matched specification. This is necessary for FUNCTION and
2114 IMPLICIT statements.
2115
2116 If implicit_flag is nonzero, then we don't check for the optional
2117 kind specification. Not doing so is needed for matching an IMPLICIT
2118 statement correctly. */
2119
2120match
2121gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
2122{
2123 char name[GFC_MAX_SYMBOL_LEN + 1];
2124 gfc_symbol *sym;
2125 match m;
2126 int c;
2127 locus loc = gfc_current_locus;
2128
2129 gfc_clear_ts (ts);
2130
2131 /* Clear the current binding label, in case one is given. */
2132 curr_binding_label[0] = '\0';
2133
2134 if (gfc_match (" byte") == MATCH_YES)
2135 {
2136 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
2137 == FAILURE)
2138 return MATCH_ERROR;
2139
2140 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2141 {
2142 gfc_error ("BYTE type used at %C "
2143 "is not available on the target machine");
2144 return MATCH_ERROR;
2145 }
2146
2147 ts->type = BT_INTEGER;
2148 ts->kind = 1;
2149 return MATCH_YES;
2150 }
2151
2152 if (gfc_match (" integer") == MATCH_YES)
2153 {
2154 ts->type = BT_INTEGER;
2155 ts->kind = gfc_default_integer_kind;
2156 goto get_kind;
2157 }
2158
2159 if (gfc_match (" character") == MATCH_YES)
2160 {
2161 ts->type = BT_CHARACTER;
2162 if (implicit_flag == 0)
2163 return match_char_spec (ts);
2164 else
2165 return MATCH_YES;
2166 }
2167
2168 if (gfc_match (" real") == MATCH_YES)
2169 {
2170 ts->type = BT_REAL;
2171 ts->kind = gfc_default_real_kind;
2172 goto get_kind;
2173 }
2174
2175 if (gfc_match (" double precision") == MATCH_YES)
2176 {
2177 ts->type = BT_REAL;
2178 ts->kind = gfc_default_double_kind;
2179 return MATCH_YES;
2180 }
2181
2182 if (gfc_match (" complex") == MATCH_YES)
2183 {
2184 ts->type = BT_COMPLEX;
2185 ts->kind = gfc_default_complex_kind;
2186 goto get_kind;
2187 }
2188
2189 if (gfc_match (" double complex") == MATCH_YES)
2190 {
2191 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2192 "conform to the Fortran 95 standard") == FAILURE)
2193 return MATCH_ERROR;
2194
2195 ts->type = BT_COMPLEX;
2196 ts->kind = gfc_default_double_kind;
2197 return MATCH_YES;
2198 }
2199
2200 if (gfc_match (" logical") == MATCH_YES)
2201 {
2202 ts->type = BT_LOGICAL;
2203 ts->kind = gfc_default_logical_kind;
2204 goto get_kind;
2205 }
2206
2207 m = gfc_match (" type ( %n )", name);
2208 if (m != MATCH_YES)
2209 return m;
2210
2211 if (gfc_current_state () == COMP_INTERFACE
2212 || gfc_current_state () == COMP_NONE)
2213 {
2214 gfc_function_type_locus = loc;
2215 ts->type = BT_UNKNOWN;
2216 ts->kind = -1;
2217 return MATCH_YES;
2218 }
2219
2220 /* Search for the name but allow the components to be defined later. If
2221 type = -1, this typespec has been seen in a function declaration but
2222 the type could not legally be accessed at that point. */
2223 if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2224 {
2225 gfc_error ("Type name '%s' at %C is ambiguous", name);
2226 return MATCH_ERROR;
2227 }
2228 else if (ts->kind == -1)
2229 {
2230 if (gfc_find_symbol (name, NULL, 0, &sym))
2231 {
2232 gfc_error ("Type name '%s' at %C is ambiguous", name);
2233 return MATCH_ERROR;
2234 }
2235
2236 if (sym == NULL)
2237 return MATCH_NO;
2238 }
2239
2240 if (sym->attr.flavor != FL_DERIVED
2241 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2242 return MATCH_ERROR;
2243
2244 ts->type = BT_DERIVED;
2245 ts->kind = 0;
2246 ts->derived = sym;
2247
2248 return MATCH_YES;
2249
2250get_kind:
2251 /* For all types except double, derived and character, look for an
2252 optional kind specifier. MATCH_NO is actually OK at this point. */
2253 if (implicit_flag == 1)
2254 return MATCH_YES;
2255
2256 if (gfc_current_form == FORM_FREE)
2257 {
2258 c = gfc_peek_char();
2259 if (!gfc_is_whitespace(c) && c != '*' && c != '('
2260 && c != ':' && c != ',')
2261 return MATCH_NO;
2262 }
2263
2264 m = gfc_match_kind_spec (ts, false);
2265 if (m == MATCH_NO && ts->type != BT_CHARACTER)
2266 m = gfc_match_old_kind_spec (ts);
2267
2268 if (m == MATCH_NO)
2269 m = MATCH_YES; /* No kind specifier found. */
2270
2271 return m;
2272}
2273
2274
2275/* Match an IMPLICIT NONE statement. Actually, this statement is
2276 already matched in parse.c, or we would not end up here in the
2277 first place. So the only thing we need to check, is if there is
2278 trailing garbage. If not, the match is successful. */
2279
2280match
2281gfc_match_implicit_none (void)
2282{
2283 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2284}
2285
2286
2287/* Match the letter range(s) of an IMPLICIT statement. */
2288
2289static match
2290match_implicit_range (void)
2291{
2292 int c, c1, c2, inner;
2293 locus cur_loc;
2294
2295 cur_loc = gfc_current_locus;
2296
2297 gfc_gobble_whitespace ();
2298 c = gfc_next_char ();
2299 if (c != '(')
2300 {
2301 gfc_error ("Missing character range in IMPLICIT at %C");
2302 goto bad;
2303 }
2304
2305 inner = 1;
2306 while (inner)
2307 {
2308 gfc_gobble_whitespace ();
2309 c1 = gfc_next_char ();
2310 if (!ISALPHA (c1))
2311 goto bad;
2312
2313 gfc_gobble_whitespace ();
2314 c = gfc_next_char ();
2315
2316 switch (c)
2317 {
2318 case ')':
2319 inner = 0; /* Fall through. */
2320
2321 case ',':
2322 c2 = c1;
2323 break;
2324
2325 case '-':
2326 gfc_gobble_whitespace ();
2327 c2 = gfc_next_char ();
2328 if (!ISALPHA (c2))
2329 goto bad;
2330
2331 gfc_gobble_whitespace ();
2332 c = gfc_next_char ();
2333
2334 if ((c != ',') && (c != ')'))
2335 goto bad;
2336 if (c == ')')
2337 inner = 0;
2338
2339 break;
2340
2341 default:
2342 goto bad;
2343 }
2344
2345 if (c1 > c2)
2346 {
2347 gfc_error ("Letters must be in alphabetic order in "
2348 "IMPLICIT statement at %C");
2349 goto bad;
2350 }
2351
2352 /* See if we can add the newly matched range to the pending
2353 implicits from this IMPLICIT statement. We do not check for
2354 conflicts with whatever earlier IMPLICIT statements may have
2355 set. This is done when we've successfully finished matching
2356 the current one. */
2357 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2358 goto bad;
2359 }
2360
2361 return MATCH_YES;
2362
2363bad:
2364 gfc_syntax_error (ST_IMPLICIT);
2365
2366 gfc_current_locus = cur_loc;
2367 return MATCH_ERROR;
2368}
2369
2370
2371/* Match an IMPLICIT statement, storing the types for
2372 gfc_set_implicit() if the statement is accepted by the parser.
2373 There is a strange looking, but legal syntactic construction
2374 possible. It looks like:
2375
2376 IMPLICIT INTEGER (a-b) (c-d)
2377
2378 This is legal if "a-b" is a constant expression that happens to
2379 equal one of the legal kinds for integers. The real problem
2380 happens with an implicit specification that looks like:
2381
2382 IMPLICIT INTEGER (a-b)
2383
2384 In this case, a typespec matcher that is "greedy" (as most of the
2385 matchers are) gobbles the character range as a kindspec, leaving
2386 nothing left. We therefore have to go a bit more slowly in the
2387 matching process by inhibiting the kindspec checking during
2388 typespec matching and checking for a kind later. */
2389
2390match
2391gfc_match_implicit (void)
2392{
2393 gfc_typespec ts;
2394 locus cur_loc;
2395 int c;
2396 match m;
2397
2398 /* We don't allow empty implicit statements. */
2399 if (gfc_match_eos () == MATCH_YES)
2400 {
2401 gfc_error ("Empty IMPLICIT statement at %C");
2402 return MATCH_ERROR;
2403 }
2404
2405 do
2406 {
2407 /* First cleanup. */
2408 gfc_clear_new_implicit ();
2409
2410 /* A basic type is mandatory here. */
2411 m = gfc_match_type_spec (&ts, 1);
2412 if (m == MATCH_ERROR)
2413 goto error;
2414 if (m == MATCH_NO)
2415 goto syntax;
2416
2417 cur_loc = gfc_current_locus;
2418 m = match_implicit_range ();
2419
2420 if (m == MATCH_YES)
2421 {
2422 /* We may have <TYPE> (<RANGE>). */
2423 gfc_gobble_whitespace ();
2424 c = gfc_next_char ();
2425 if ((c == '\n') || (c == ','))
2426 {
2427 /* Check for CHARACTER with no length parameter. */
2428 if (ts.type == BT_CHARACTER && !ts.cl)
2429 {
2430 ts.kind = gfc_default_character_kind;
2431 ts.cl = gfc_get_charlen ();
2432 ts.cl->next = gfc_current_ns->cl_list;
2433 gfc_current_ns->cl_list = ts.cl;
2434 ts.cl->length = gfc_int_expr (1);
2435 }
2436
2437 /* Record the Successful match. */
2438 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2439 return MATCH_ERROR;
2440 continue;
2441 }
2442
2443 gfc_current_locus = cur_loc;
2444 }
2445
2446 /* Discard the (incorrectly) matched range. */
2447 gfc_clear_new_implicit ();
2448
2449 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2450 if (ts.type == BT_CHARACTER)
2451 m = match_char_spec (&ts);
2452 else
2453 {
2454 m = gfc_match_kind_spec (&ts, false);
2455 if (m == MATCH_NO)
2456 {
2457 m = gfc_match_old_kind_spec (&ts);
2458 if (m == MATCH_ERROR)
2459 goto error;
2460 if (m == MATCH_NO)
2461 goto syntax;
2462 }
2463 }
2464 if (m == MATCH_ERROR)
2465 goto error;
2466
2467 m = match_implicit_range ();
2468 if (m == MATCH_ERROR)
2469 goto error;
2470 if (m == MATCH_NO)
2471 goto syntax;
2472
2473 gfc_gobble_whitespace ();
2474 c = gfc_next_char ();
2475 if ((c != '\n') && (c != ','))
2476 goto syntax;
2477
2478 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2479 return MATCH_ERROR;
2480 }
2481 while (c == ',');
2482
2483 return MATCH_YES;
2484
2485syntax:
2486 gfc_syntax_error (ST_IMPLICIT);
2487
2488error:
2489 return MATCH_ERROR;
2490}
2491
2492
2493match
2494gfc_match_import (void)
2495{
2496 char name[GFC_MAX_SYMBOL_LEN + 1];
2497 match m;
2498 gfc_symbol *sym;
2499 gfc_symtree *st;
2500
2501 if (gfc_current_ns->proc_name == NULL
2502 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2503 {
2504 gfc_error ("IMPORT statement at %C only permitted in "
2505 "an INTERFACE body");
2506 return MATCH_ERROR;
2507 }
2508
2509 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2510 == FAILURE)
2511 return MATCH_ERROR;
2512
2513 if (gfc_match_eos () == MATCH_YES)
2514 {
2515 /* All host variables should be imported. */
2516 gfc_current_ns->has_import_set = 1;
2517 return MATCH_YES;
2518 }
2519
2520 if (gfc_match (" ::") == MATCH_YES)
2521 {
2522 if (gfc_match_eos () == MATCH_YES)
2523 {
2524 gfc_error ("Expecting list of named entities at %C");
2525 return MATCH_ERROR;
2526 }
2527 }
2528
2529 for(;;)
2530 {
2531 m = gfc_match (" %n", name);
2532 switch (m)
2533 {
2534 case MATCH_YES:
2535 if (gfc_current_ns->parent != NULL
2536 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2537 {
2538 gfc_error ("Type name '%s' at %C is ambiguous", name);
2539 return MATCH_ERROR;
2540 }
2541 else if (gfc_current_ns->proc_name->ns->parent != NULL
2542 && gfc_find_symbol (name,
2543 gfc_current_ns->proc_name->ns->parent,
2544 1, &sym))
2545 {
2546 gfc_error ("Type name '%s' at %C is ambiguous", name);
2547 return MATCH_ERROR;
2548 }
2549
2550 if (sym == NULL)
2551 {
2552 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2553 "at %C - does not exist.", name);
2554 return MATCH_ERROR;
2555 }
2556
2557 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2558 {
2559 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2560 "at %C.", name);
2561 goto next_item;
2562 }
2563
2564 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2565 st->n.sym = sym;
2566 sym->refs++;
2567 sym->attr.imported = 1;
2568
2569 goto next_item;
2570
2571 case MATCH_NO:
2572 break;
2573
2574 case MATCH_ERROR:
2575 return MATCH_ERROR;
2576 }
2577
2578 next_item:
2579 if (gfc_match_eos () == MATCH_YES)
2580 break;
2581 if (gfc_match_char (',') != MATCH_YES)
2582 goto syntax;
2583 }
2584
2585 return MATCH_YES;
2586
2587syntax:
2588 gfc_error ("Syntax error in IMPORT statement at %C");
2589 return MATCH_ERROR;
2590}
2591
2592
2593/* A minimal implementation of gfc_match without whitespace, escape
2594 characters or variable arguments. Returns true if the next
2595 characters match the TARGET template exactly. */
2596
2597static bool
2598match_string_p (const char *target)
2599{
2600 const char *p;
2601
2602 for (p = target; *p; p++)
2603 if (gfc_next_char () != *p)
2604 return false;
2605 return true;
2606}
2607
2608/* Matches an attribute specification including array specs. If
2609 successful, leaves the variables current_attr and current_as
2610 holding the specification. Also sets the colon_seen variable for
2611 later use by matchers associated with initializations.
2612
2613 This subroutine is a little tricky in the sense that we don't know
2614 if we really have an attr-spec until we hit the double colon.
2615 Until that time, we can only return MATCH_NO. This forces us to
2616 check for duplicate specification at this level. */
2617
2618static match
2619match_attr_spec (void)
2620{
2621 /* Modifiers that can exist in a type statement. */
2622 typedef enum
2623 { GFC_DECL_BEGIN = 0,
2624 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2625 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2626 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2627 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2628 DECL_IS_BIND_C, DECL_NONE,
2629 GFC_DECL_END /* Sentinel */
2630 }
2631 decl_types;
2632
2633/* GFC_DECL_END is the sentinel, index starts at 0. */
2634#define NUM_DECL GFC_DECL_END
2635
2636 locus start, seen_at[NUM_DECL];
2637 int seen[NUM_DECL];
2638 decl_types d;
2639 const char *attr;
2640 match m;
2641 try t;
2642
2643 gfc_clear_attr (&current_attr);
2644 start = gfc_current_locus;
2645
2646 current_as = NULL;
2647 colon_seen = 0;
2648
2649 /* See if we get all of the keywords up to the final double colon. */
2650 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2651 seen[d] = 0;
2652
2653 for (;;)
2654 {
2655 int ch;
2656
2657 d = DECL_NONE;
2658 gfc_gobble_whitespace ();
2659
2660 ch = gfc_next_char ();
2661 if (ch == ':')
2662 {
2663 /* This is the successful exit condition for the loop. */
2664 if (gfc_next_char () == ':')
2665 break;
2666 }
2667 else if (ch == ',')
2668 {
2669 gfc_gobble_whitespace ();
2670 switch (gfc_peek_char ())
2671 {
2672 case 'a':
2673 if (match_string_p ("allocatable"))
2674 d = DECL_ALLOCATABLE;
2675 break;
2676
2677 case 'b':
2678 /* Try and match the bind(c). */
2679 m = gfc_match_bind_c (NULL);
2680 if (m == MATCH_YES)
2681 d = DECL_IS_BIND_C;
2682 else if (m == MATCH_ERROR)
2683 goto cleanup;
2684 break;
2685
2686 case 'd':
2687 if (match_string_p ("dimension"))
2688 d = DECL_DIMENSION;
2689 break;
2690
2691 case 'e':
2692 if (match_string_p ("external"))
2693 d = DECL_EXTERNAL;
2694 break;
2695
2696 case 'i':
2697 if (match_string_p ("int"))
2698 {
2699 ch = gfc_next_char ();
2700 if (ch == 'e')
2701 {
2702 if (match_string_p ("nt"))
2703 {
2704 /* Matched "intent". */
2705 /* TODO: Call match_intent_spec from here. */
2706 if (gfc_match (" ( in out )") == MATCH_YES)
2707 d = DECL_INOUT;
2708 else if (gfc_match (" ( in )") == MATCH_YES)
2709 d = DECL_IN;
2710 else if (gfc_match (" ( out )") == MATCH_YES)
2711 d = DECL_OUT;
2712 }
2713 }
2714 else if (ch == 'r')
2715 {
2716 if (match_string_p ("insic"))
2717 {
2718 /* Matched "intrinsic". */
2719 d = DECL_INTRINSIC;
2720 }
2721 }
2722 }
2723 break;
2724
2725 case 'o':
2726 if (match_string_p ("optional"))
2727 d = DECL_OPTIONAL;
2728 break;
2729
2730 case 'p':
2731 gfc_next_char ();
2732 switch (gfc_next_char ())
2733 {
2734 case 'a':
2735 if (match_string_p ("rameter"))
2736 {
2737 /* Matched "parameter". */
2738 d = DECL_PARAMETER;
2739 }
2740 break;
2741
2742 case 'o':
2743 if (match_string_p ("inter"))
2744 {
2745 /* Matched "pointer". */
2746 d = DECL_POINTER;
2747 }
2748 break;
2749
2750 case 'r':
2751 ch = gfc_next_char ();
2752 if (ch == 'i')
2753 {
2754 if (match_string_p ("vate"))
2755 {
2756 /* Matched "private". */
2757 d = DECL_PRIVATE;
2758 }
2759 }
2760 else if (ch == 'o')
2761 {
2762 if (match_string_p ("tected"))
2763 {
2764 /* Matched "protected". */
2765 d = DECL_PROTECTED;
2766 }
2767 }
2768 break;
2769
2770 case 'u':
2771 if (match_string_p ("blic"))
2772 {
2773 /* Matched "public". */
2774 d = DECL_PUBLIC;
2775 }
2776 break;
2777 }
2778 break;
2779
2780 case 's':
2781 if (match_string_p ("save"))
2782 d = DECL_SAVE;
2783 break;
2784
2785 case 't':
2786 if (match_string_p ("target"))
2787 d = DECL_TARGET;
2788 break;
2789
2790 case 'v':
2791 gfc_next_char ();
2792 ch = gfc_next_char ();
2793 if (ch == 'a')
2794 {
2795 if (match_string_p ("lue"))
2796 {
2797 /* Matched "value". */
2798 d = DECL_VALUE;
2799 }
2800 }
2801 else if (ch == 'o')
2802 {
2803 if (match_string_p ("latile"))
2804 {
2805 /* Matched "volatile". */
2806 d = DECL_VOLATILE;
2807 }
2808 }
2809 break;
2810 }
2811 }
2812
2813 /* No double colon and no recognizable decl_type, so assume that
2814 we've been looking at something else the whole time. */
2815 if (d == DECL_NONE)
2816 {
2817 m = MATCH_NO;
2818 goto cleanup;
2819 }
2820
2821 seen[d]++;
2822 seen_at[d] = gfc_current_locus;
2823
2824 if (d == DECL_DIMENSION)
2825 {
2826 m = gfc_match_array_spec (&current_as);
2827
2828 if (m == MATCH_NO)
2829 {
2830 gfc_error ("Missing dimension specification at %C");
2831 m = MATCH_ERROR;
2832 }
2833
2834 if (m == MATCH_ERROR)
2835 goto cleanup;
2836 }
2837 }
2838
2839 /* Since we've seen a double colon, we have to be looking at an
2840 attr-spec. This means that we can now issue errors. */
2841 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2842 if (seen[d] > 1)
2843 {
2844 switch (d)
2845 {
2846 case DECL_ALLOCATABLE:
2847 attr = "ALLOCATABLE";
2848 break;
2849 case DECL_DIMENSION:
2850 attr = "DIMENSION";
2851 break;
2852 case DECL_EXTERNAL:
2853 attr = "EXTERNAL";
2854 break;
2855 case DECL_IN:
2856 attr = "INTENT (IN)";
2857 break;
2858 case DECL_OUT:
2859 attr = "INTENT (OUT)";
2860 break;
2861 case DECL_INOUT:
2862 attr = "INTENT (IN OUT)";
2863 break;
2864 case DECL_INTRINSIC:
2865 attr = "INTRINSIC";
2866 break;
2867 case DECL_OPTIONAL:
2868 attr = "OPTIONAL";
2869 break;
2870 case DECL_PARAMETER:
2871 attr = "PARAMETER";
2872 break;
2873 case DECL_POINTER:
2874 attr = "POINTER";
2875 break;
2876 case DECL_PROTECTED:
2877 attr = "PROTECTED";
2878 break;
2879 case DECL_PRIVATE:
2880 attr = "PRIVATE";
2881 break;
2882 case DECL_PUBLIC:
2883 attr = "PUBLIC";
2884 break;
2885 case DECL_SAVE:
2886 attr = "SAVE";
2887 break;
2888 case DECL_TARGET:
2889 attr = "TARGET";
2890 break;
2891 case DECL_IS_BIND_C:
2892 attr = "IS_BIND_C";
2893 break;
2894 case DECL_VALUE:
2895 attr = "VALUE";
2896 break;
2897 case DECL_VOLATILE:
2898 attr = "VOLATILE";
2899 break;
2900 default:
2901 attr = NULL; /* This shouldn't happen. */
2902 }
2903
2904 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2905 m = MATCH_ERROR;
2906 goto cleanup;
2907 }
2908
2909 /* Now that we've dealt with duplicate attributes, add the attributes
2910 to the current attribute. */
2911 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2912 {
2913 if (seen[d] == 0)
2914 continue;
2915
2916 if (gfc_current_state () == COMP_DERIVED
2917 && d != DECL_DIMENSION && d != DECL_POINTER
2918 && d != DECL_PRIVATE && d != DECL_PUBLIC
2919 && d != DECL_NONE)
2920 {
2921 if (d == DECL_ALLOCATABLE)
2922 {
2923 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2924 "attribute at %C in a TYPE definition")
2925 == FAILURE)
2926 {
2927 m = MATCH_ERROR;
2928 goto cleanup;
2929 }
2930 }
2931 else
2932 {
2933 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2934 &seen_at[d]);
2935 m = MATCH_ERROR;
2936 goto cleanup;
2937 }
2938 }
2939
2940 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2941 && gfc_current_state () != COMP_MODULE)
2942 {
2943 if (d == DECL_PRIVATE)
2944 attr = "PRIVATE";
2945 else
2946 attr = "PUBLIC";
2947 if (gfc_current_state () == COMP_DERIVED
2948 && gfc_state_stack->previous
2949 && gfc_state_stack->previous->state == COMP_MODULE)
2950 {
2951 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2952 "at %L in a TYPE definition", attr,
2953 &seen_at[d])
2954 == FAILURE)
2955 {
2956 m = MATCH_ERROR;
2957 goto cleanup;
2958 }
2959 }
2960 else
2961 {
2962 gfc_error ("%s attribute at %L is not allowed outside of the "
2963 "specification part of a module", attr, &seen_at[d]);
2964 m = MATCH_ERROR;
2965 goto cleanup;
2966 }
2967 }
2968
2969 switch (d)
2970 {
2971 case DECL_ALLOCATABLE:
2972 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2973 break;
2974
2975 case DECL_DIMENSION:
2976 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
2977 break;
2978
2979 case DECL_EXTERNAL:
2980 t = gfc_add_external (&current_attr, &seen_at[d]);
2981 break;
2982
2983 case DECL_IN:
2984 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2985 break;
2986
2987 case DECL_OUT:
2988 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2989 break;
2990
2991 case DECL_INOUT:
2992 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2993 break;
2994
2995 case DECL_INTRINSIC:
2996 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2997 break;
2998
2999 case DECL_OPTIONAL:
3000 t = gfc_add_optional (&current_attr, &seen_at[d]);
3001 break;
3002
3003 case DECL_PARAMETER:
3004 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
3005 break;
3006
3007 case DECL_POINTER:
3008 t = gfc_add_pointer (&current_attr, &seen_at[d]);
3009 break;
3010
3011 case DECL_PROTECTED:
3012 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3013 {
3014 gfc_error ("PROTECTED at %C only allowed in specification "
3015 "part of a module");
3016 t = FAILURE;
3017 break;
3018 }
3019
3020 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3021 "attribute at %C")
3022 == FAILURE)
3023 t = FAILURE;
3024 else
3025 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
3026 break;
3027
3028 case DECL_PRIVATE:
3029 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
3030 &seen_at[d]);
3031 break;
3032
3033 case DECL_PUBLIC:
3034 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
3035 &seen_at[d]);
3036 break;
3037
3038 case DECL_SAVE:
3039 t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
3040 break;
3041
3042 case DECL_TARGET:
3043 t = gfc_add_target (&current_attr, &seen_at[d]);
3044 break;
3045
3046 case DECL_IS_BIND_C:
3047 t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
3048 break;
3049
3050 case DECL_VALUE:
3051 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3052 "at %C")
3053 == FAILURE)
3054 t = FAILURE;
3055 else
3056 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
3057 break;
3058
3059 case DECL_VOLATILE:
3060 if (gfc_notify_std (GFC_STD_F2003,
3061 "Fortran 2003: VOLATILE attribute at %C")
3062 == FAILURE)
3063 t = FAILURE;
3064 else
3065 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
3066 break;
3067
3068 default:
3069 gfc_internal_error ("match_attr_spec(): Bad attribute");
3070 }
3071
3072 if (t == FAILURE)
3073 {
3074 m = MATCH_ERROR;
3075 goto cleanup;
3076 }
3077 }
3078
3079 colon_seen = 1;
3080 return MATCH_YES;
3081
3082cleanup:
3083 gfc_current_locus = start;
3084 gfc_free_array_spec (current_as);
3085 current_as = NULL;
3086 return m;
3087}
3088
3089
3090/* Set the binding label, dest_label, either with the binding label
3091 stored in the given gfc_typespec, ts, or if none was provided, it
3092 will be the symbol name in all lower case, as required by the draft
3093 (J3/04-007, section 15.4.1). If a binding label was given and
3094 there is more than one argument (num_idents), it is an error. */
3095
3096try
3097set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3098{
3099 if (num_idents > 1 && has_name_equals)
3100 {
3101 gfc_error ("Multiple identifiers provided with "
3102 "single NAME= specifier at %C");
3103 return FAILURE;
3104 }
3105
3106 if (curr_binding_label[0] != '\0')
3107 {
3108 /* Binding label given; store in temp holder til have sym. */
3109 strncpy (dest_label, curr_binding_label,
3110 strlen (curr_binding_label) + 1);
3111 }
3112 else
3113 {
3114 /* No binding label given, and the NAME= specifier did not exist,
3115 which means there was no NAME="". */
3116 if (sym_name != NULL && has_name_equals == 0)
3117 strncpy (dest_label, sym_name, strlen (sym_name) + 1);
3118 }
3119
3120 return SUCCESS;
3121}
3122
3123
3124/* Set the status of the given common block as being BIND(C) or not,
3125 depending on the given parameter, is_bind_c. */
3126
3127void
3128set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3129{
3130 com_block->is_bind_c = is_bind_c;
3131 return;
3132}
3133
3134
3135/* Verify that the given gfc_typespec is for a C interoperable type. */
3136
3137try
3138verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
3139{
3140 try t;
3141
3142 /* Make sure the kind used is appropriate for the type.
3143 The f90_type is unknown if an integer constant was
3144 used (e.g., real(4), bind(c) :: myFloat). */
3145 if (ts->f90_type != BT_UNKNOWN)
3146 {
3147 t = gfc_validate_c_kind (ts);
3148 if (t != SUCCESS)
3149 {
3150 /* Print an error, but continue parsing line. */
3151 gfc_error_now ("C kind parameter is for type %s but "
3152 "symbol '%s' at %L is of type %s",
3153 gfc_basic_typename (ts->f90_type),
3154 name, where,
3155 gfc_basic_typename (ts->type));
3156 }
3157 }
3158
3159 /* Make sure the kind is C interoperable. This does not care about the
3160 possible error above. */
3161 if (ts->type == BT_DERIVED && ts->derived != NULL)
3162 return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
3163 else if (ts->is_c_interop != 1)
3164 return FAILURE;
3165
3166 return SUCCESS;
3167}
3168
3169
3170/* Verify that the variables of a given common block, which has been
3171 defined with the attribute specifier bind(c), to be of a C
3172 interoperable type. Errors will be reported here, if
3173 encountered. */
3174
3175try
3176verify_com_block_vars_c_interop (gfc_common_head *com_block)
3177{
3178 gfc_symbol *curr_sym = NULL;
3179 try retval = SUCCESS;
3180
3181 curr_sym = com_block->head;
3182
3183 /* Make sure we have at least one symbol. */
3184 if (curr_sym == NULL)
3185 return retval;
3186
3187 /* Here we know we have a symbol, so we'll execute this loop
3188 at least once. */
3189 do
3190 {
3191 /* The second to last param, 1, says this is in a common block. */
3192 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3193 curr_sym = curr_sym->common_next;
3194 } while (curr_sym != NULL);
3195
3196 return retval;
3197}
3198
3199
3200/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3201 an appropriate error message is reported. */
3202
3203try
3204verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3205 int is_in_common, gfc_common_head *com_block)
3206{
3207 try retval = SUCCESS;
3208
3209 if (tmp_sym->attr.function && tmp_sym->result != NULL)
3210 {
3211 tmp_sym = tmp_sym->result;
3212 /* Make sure it wasn't an implicitly typed result. */
3213 if (tmp_sym->attr.implicit_type)
3214 {
3215 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3216 "%L may not be C interoperable", tmp_sym->name,
3217 &tmp_sym->declared_at);
3218 tmp_sym->ts.f90_type = tmp_sym->ts.type;
3219 /* Mark it as C interoperable to prevent duplicate warnings. */
3220 tmp_sym->ts.is_c_interop = 1;
3221 tmp_sym->attr.is_c_interop = 1;
3222 }
3223 }
3224
3225 /* Here, we know we have the bind(c) attribute, so if we have
3226 enough type info, then verify that it's a C interop kind.
3227 The info could be in the symbol already, or possibly still in
3228 the given ts (current_ts), so look in both. */
3229 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
3230 {
3231 if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
3232 &(tmp_sym->declared_at)) != SUCCESS)
3233 {
3234 /* See if we're dealing with a sym in a common block or not. */
3235 if (is_in_common == 1)
3236 {
3237 gfc_warning ("Variable '%s' in common block '%s' at %L "
3238 "may not be a C interoperable "
3239 "kind though common block '%s' is BIND(C)",
3240 tmp_sym->name, com_block->name,
3241 &(tmp_sym->declared_at), com_block->name);
3242 }
3243 else
3244 {
3245 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3246 gfc_error ("Type declaration '%s' at %L is not C "
3247 "interoperable but it is BIND(C)",
3248 tmp_sym->name, &(tmp_sym->declared_at));
3249 else
3250 gfc_warning ("Variable '%s' at %L "
3251 "may not be a C interoperable "
3252 "kind but it is bind(c)",
3253 tmp_sym->name, &(tmp_sym->declared_at));
3254 }
3255 }
3256
3257 /* Variables declared w/in a common block can't be bind(c)
3258 since there's no way for C to see these variables, so there's
3259 semantically no reason for the attribute. */
3260 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3261 {
3262 gfc_error ("Variable '%s' in common block '%s' at "
3263 "%L cannot be declared with BIND(C) "
3264 "since it is not a global",
3265 tmp_sym->name, com_block->name,
3266 &(tmp_sym->declared_at));
3267 retval = FAILURE;
3268 }
3269
3270 /* Scalar variables that are bind(c) can not have the pointer
3271 or allocatable attributes. */
3272 if (tmp_sym->attr.is_bind_c == 1)
3273 {
3274 if (tmp_sym->attr.pointer == 1)
3275 {
3276 gfc_error ("Variable '%s' at %L cannot have both the "
3277 "POINTER and BIND(C) attributes",
3278 tmp_sym->name, &(tmp_sym->declared_at));
3279 retval = FAILURE;
3280 }
3281
3282 if (tmp_sym->attr.allocatable == 1)
3283 {
3284 gfc_error ("Variable '%s' at %L cannot have both the "
3285 "ALLOCATABLE and BIND(C) attributes",
3286 tmp_sym->name, &(tmp_sym->declared_at));
3287 retval = FAILURE;
3288 }
3289
3290 /* If it is a BIND(C) function, make sure the return value is a
3291 scalar value. The previous tests in this function made sure
3292 the type is interoperable. */
3293 if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3294 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3295 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3296
3297 /* BIND(C) functions can not return a character string. */
3298 if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3299 if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3300 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3301 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3302 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3303 "be a character string", tmp_sym->name,
3304 &(tmp_sym->declared_at));
3305 }
3306 }
3307
3308 /* See if the symbol has been marked as private. If it has, make sure
3309 there is no binding label and warn the user if there is one. */
3310 if (tmp_sym->attr.access == ACCESS_PRIVATE
3311 && tmp_sym->binding_label[0] != '\0')
3312 /* Use gfc_warning_now because we won't say that the symbol fails
3313 just because of this. */
3314 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3315 "given the binding label '%s'", tmp_sym->name,
3316 &(tmp_sym->declared_at), tmp_sym->binding_label);
3317
3318 return retval;
3319}
3320
3321
3322/* Set the appropriate fields for a symbol that's been declared as
3323 BIND(C) (the is_bind_c flag and the binding label), and verify that
3324 the type is C interoperable. Errors are reported by the functions
3325 used to set/test these fields. */
3326
3327try
3328set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3329{
3330 try retval = SUCCESS;
3331
3332 /* TODO: Do we need to make sure the vars aren't marked private? */
3333
3334 /* Set the is_bind_c bit in symbol_attribute. */
3335 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3336
3337 if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3338 num_idents) != SUCCESS)
3339 return FAILURE;
3340
3341 return retval;
3342}
3343
3344
3345/* Set the fields marking the given common block as BIND(C), including
3346 a binding label, and report any errors encountered. */
3347
3348try
3349set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3350{
3351 try retval = SUCCESS;
3352
3353 /* destLabel, common name, typespec (which may have binding label). */
3354 if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3355 != SUCCESS)
3356 return FAILURE;
3357
3358 /* Set the given common block (com_block) to being bind(c) (1). */
3359 set_com_block_bind_c (com_block, 1);
3360
3361 return retval;
3362}
3363
3364
3365/* Retrieve the list of one or more identifiers that the given bind(c)
3366 attribute applies to. */
3367
3368try
3369get_bind_c_idents (void)
3370{
3371 char name[GFC_MAX_SYMBOL_LEN + 1];
3372 int num_idents = 0;
3373 gfc_symbol *tmp_sym = NULL;
3374 match found_id;
3375 gfc_common_head *com_block = NULL;
3376
3377 if (gfc_match_name (name) == MATCH_YES)
3378 {
3379 found_id = MATCH_YES;
3380 gfc_get_ha_symbol (name, &tmp_sym);
3381 }
3382 else if (match_common_name (name) == MATCH_YES)
3383 {
3384 found_id = MATCH_YES;
3385 com_block = gfc_get_common (name, 0);
3386 }
3387 else
3388 {
3389 gfc_error ("Need either entity or common block name for "
3390 "attribute specification statement at %C");
3391 return FAILURE;
3392 }
3393
3394 /* Save the current identifier and look for more. */
3395 do
3396 {
3397 /* Increment the number of identifiers found for this spec stmt. */
3398 num_idents++;
3399
3400 /* Make sure we have a sym or com block, and verify that it can
3401 be bind(c). Set the appropriate field(s) and look for more
3402 identifiers. */
3403 if (tmp_sym != NULL || com_block != NULL)
3404 {
3405 if (tmp_sym != NULL)
3406 {
3407 if (set_verify_bind_c_sym (tmp_sym, num_idents)
3408 != SUCCESS)
3409 return FAILURE;
3410 }
3411 else
3412 {
3413 if (set_verify_bind_c_com_block(com_block, num_idents)
3414 != SUCCESS)
3415 return FAILURE;
3416 }
3417
3418 /* Look to see if we have another identifier. */
3419 tmp_sym = NULL;
3420 if (gfc_match_eos () == MATCH_YES)
3421 found_id = MATCH_NO;
3422 else if (gfc_match_char (',') != MATCH_YES)
3423 found_id = MATCH_NO;
3424 else if (gfc_match_name (name) == MATCH_YES)
3425 {
3426 found_id = MATCH_YES;
3427 gfc_get_ha_symbol (name, &tmp_sym);
3428 }
3429 else if (match_common_name (name) == MATCH_YES)
3430 {
3431 found_id = MATCH_YES;
3432 com_block = gfc_get_common (name, 0);
3433 }
3434 else
3435 {
3436 gfc_error ("Missing entity or common block name for "
3437 "attribute specification statement at %C");
3438 return FAILURE;
3439 }
3440 }
3441 else
3442 {
3443 gfc_internal_error ("Missing symbol");
3444 }
3445 } while (found_id == MATCH_YES);
3446
3447 /* if we get here we were successful */
3448 return SUCCESS;
3449}
3450
3451
3452/* Try and match a BIND(C) attribute specification statement. */
3453
3454match
3455gfc_match_bind_c_stmt (void)
3456{
3457 match found_match = MATCH_NO;
3458 gfc_typespec *ts;
3459
3460 ts = &current_ts;
3461
3462 /* This may not be necessary. */
3463 gfc_clear_ts (ts);
3464 /* Clear the temporary binding label holder. */
3465 curr_binding_label[0] = '\0';
3466
3467 /* Look for the bind(c). */
3468 found_match = gfc_match_bind_c (NULL);
3469
3470 if (found_match == MATCH_YES)
3471 {
3472 /* Look for the :: now, but it is not required. */
3473 gfc_match (" :: ");
3474
3475 /* Get the identifier(s) that needs to be updated. This may need to
3476 change to hand the flag(s) for the attr specified so all identifiers
3477 found can have all appropriate parts updated (assuming that the same
3478 spec stmt can have multiple attrs, such as both bind(c) and
3479 allocatable...). */
3480 if (get_bind_c_idents () != SUCCESS)
3481 /* Error message should have printed already. */
3482 return MATCH_ERROR;
3483 }
3484
3485 return found_match;
3486}
3487
3488
3489/* Match a data declaration statement. */
3490
3491match
3492gfc_match_data_decl (void)
3493{
3494 gfc_symbol *sym;
3495 match m;
3496 int elem;
3497
3498 num_idents_on_line = 0;
3499
3500 m = gfc_match_type_spec (&current_ts, 0);
3501 if (m != MATCH_YES)
3502 return m;
3503
3504 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3505 {
3506 sym = gfc_use_derived (current_ts.derived);
3507
3508 if (sym == NULL)
3509 {
3510 m = MATCH_ERROR;
3511 goto cleanup;
3512 }
3513
3514 current_ts.derived = sym;
3515 }
3516
3517 m = match_attr_spec ();
3518 if (m == MATCH_ERROR)
3519 {
3520 m = MATCH_NO;
3521 goto cleanup;
3522 }
3523
3524 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL
3525 && !current_ts.derived->attr.zero_comp)
3526 {
3527
3528 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3529 goto ok;
3530
3531 gfc_find_symbol (current_ts.derived->name,
3532 current_ts.derived->ns->parent, 1, &sym);
3533
3534 /* Any symbol that we find had better be a type definition
3535 which has its components defined. */
3536 if (sym != NULL && sym->attr.flavor == FL_DERIVED
3537 && (current_ts.derived->components != NULL
3538 || current_ts.derived->attr.zero_comp))
3539 goto ok;
3540
3541 /* Now we have an error, which we signal, and then fix up
3542 because the knock-on is plain and simple confusing. */
3543 gfc_error_now ("Derived type at %C has not been previously defined "
3544 "and so cannot appear in a derived type definition");
3545 current_attr.pointer = 1;
3546 goto ok;
3547 }
3548
3549ok:
3550 /* If we have an old-style character declaration, and no new-style
3551 attribute specifications, then there a comma is optional between
3552 the type specification and the variable list. */
3553 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3554 gfc_match_char (',');
3555
3556 /* Give the types/attributes to symbols that follow. Give the element
3557 a number so that repeat character length expressions can be copied. */
3558 elem = 1;
3559 for (;;)
3560 {
3561 num_idents_on_line++;
3562 m = variable_decl (elem++);
3563 if (m == MATCH_ERROR)
3564 goto cleanup;
3565 if (m == MATCH_NO)
3566 break;
3567
3568 if (gfc_match_eos () == MATCH_YES)
3569 goto cleanup;
3570 if (gfc_match_char (',') != MATCH_YES)
3571 break;
3572 }
3573
3574 if (gfc_error_flag_test () == 0)
3575 gfc_error ("Syntax error in data declaration at %C");
3576 m = MATCH_ERROR;
3577
3578 gfc_free_data_all (gfc_current_ns);
3579
3580cleanup:
3581 gfc_free_array_spec (current_as);
3582 current_as = NULL;
3583 return m;
3584}
3585
3586
3587/* Match a prefix associated with a function or subroutine
3588 declaration. If the typespec pointer is nonnull, then a typespec
3589 can be matched. Note that if nothing matches, MATCH_YES is
3590 returned (the null string was matched). */
3591
3592static match
3593match_prefix (gfc_typespec *ts)
3594{
3595 int seen_type;
3596
3597 gfc_clear_attr (&current_attr);
3598 seen_type = 0;
3599
3600loop:
3601 if (!seen_type && ts != NULL
3602 && gfc_match_type_spec (ts, 0) == MATCH_YES
3603 && gfc_match_space () == MATCH_YES)
3604 {
3605
3606 seen_type = 1;
3607 goto loop;
3608 }
3609
3610 if (gfc_match ("elemental% ") == MATCH_YES)
3611 {
3612 if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3613 return MATCH_ERROR;
3614
3615 goto loop;
3616 }
3617
3618 if (gfc_match ("pure% ") == MATCH_YES)
3619 {
3620 if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3621 return MATCH_ERROR;
3622
3623 goto loop;
3624 }
3625
3626 if (gfc_match ("recursive% ") == MATCH_YES)
3627 {
3628 if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3629 return MATCH_ERROR;
3630
3631 goto loop;
3632 }
3633
3634 /* At this point, the next item is not a prefix. */
3635 return MATCH_YES;
3636}
3637
3638
3639/* Copy attributes matched by match_prefix() to attributes on a symbol. */
3640
3641static try
3642copy_prefix (symbol_attribute *dest, locus *where)
3643{
3644 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3645 return FAILURE;
3646
3647 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3648 return FAILURE;
3649
3650 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3651 return FAILURE;
3652
3653 return SUCCESS;
3654}
3655
3656
3657/* Match a formal argument list. */
3658
3659match
3660gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3661{
3662 gfc_formal_arglist *head, *tail, *p, *q;
3663 char name[GFC_MAX_SYMBOL_LEN + 1];
3664 gfc_symbol *sym;
3665 match m;
3666
3667 head = tail = NULL;
3668
3669 if (gfc_match_char ('(') != MATCH_YES)
3670 {
3671 if (null_flag)
3672 goto ok;
3673 return MATCH_NO;
3674 }
3675
3676 if (gfc_match_char (')') == MATCH_YES)
3677 goto ok;
3678
3679 for (;;)
3680 {
3681 if (gfc_match_char ('*') == MATCH_YES)
3682 sym = NULL;
3683 else
3684 {
3685 m = gfc_match_name (name);
3686 if (m != MATCH_YES)
3687 goto cleanup;
3688
3689 if (gfc_get_symbol (name, NULL, &sym))
3690 goto cleanup;
3691 }
3692
3693 p = gfc_get_formal_arglist ();
3694
3695 if (head == NULL)
3696 head = tail = p;
3697 else
3698 {
3699 tail->next = p;
3700 tail = p;
3701 }
3702
3703 tail->sym = sym;
3704
3705 /* We don't add the VARIABLE flavor because the name could be a
3706 dummy procedure. We don't apply these attributes to formal
3707 arguments of statement functions. */
3708 if (sym != NULL && !st_flag
3709 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3710 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3711 {
3712 m = MATCH_ERROR;
3713 goto cleanup;
3714 }
3715
3716 /* The name of a program unit can be in a different namespace,
3717 so check for it explicitly. After the statement is accepted,
3718 the name is checked for especially in gfc_get_symbol(). */
3719 if (gfc_new_block != NULL && sym != NULL
3720 && strcmp (sym->name, gfc_new_block->name) == 0)
3721 {
3722 gfc_error ("Name '%s' at %C is the name of the procedure",
3723 sym->name);
3724 m = MATCH_ERROR;
3725 goto cleanup;
3726 }
3727
3728 if (gfc_match_char (')') == MATCH_YES)
3729 goto ok;
3730
3731 m = gfc_match_char (',');
3732 if (m != MATCH_YES)
3733 {
3734 gfc_error ("Unexpected junk in formal argument list at %C");
3735 goto cleanup;
3736 }
3737 }
3738
3739ok:
3740 /* Check for duplicate symbols in the formal argument list. */
3741 if (head != NULL)
3742 {
3743 for (p = head; p->next; p = p->next)
3744 {
3745 if (p->sym == NULL)
3746 continue;
3747
3748 for (q = p->next; q; q = q->next)
3749 if (p->sym == q->sym)
3750 {
3751 gfc_error ("Duplicate symbol '%s' in formal argument list "
3752 "at %C", p->sym->name);
3753
3754 m = MATCH_ERROR;
3755 goto cleanup;
3756 }
3757 }
3758 }
3759
3760 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3761 == FAILURE)
3762 {
3763 m = MATCH_ERROR;
3764 goto cleanup;
3765 }
3766
3767 return MATCH_YES;
3768
3769cleanup:
3770 gfc_free_formal_arglist (head);
3771 return m;
3772}
3773
3774
3775/* Match a RESULT specification following a function declaration or
3776 ENTRY statement. Also matches the end-of-statement. */
3777
3778static match
3779match_result (gfc_symbol *function, gfc_symbol **result)
3780{
3781 char name[GFC_MAX_SYMBOL_LEN + 1];
3782 gfc_symbol *r;
3783 match m;
3784
3785 if (gfc_match (" result (") != MATCH_YES)
3786 return MATCH_NO;
3787
3788 m = gfc_match_name (name);
3789 if (m != MATCH_YES)
3790 return m;
3791
3792 /* Get the right paren, and that's it because there could be the
3793 bind(c) attribute after the result clause. */
3794 if (gfc_match_char(')') != MATCH_YES)
3795 {
3796 /* TODO: should report the missing right paren here. */
3797 return MATCH_ERROR;
3798 }
3799
3800 if (strcmp (function->name, name) == 0)
3801 {
3802 gfc_error ("RESULT variable at %C must be different than function name");
3803 return MATCH_ERROR;
3804 }
3805
3806 if (gfc_get_symbol (name, NULL, &r))
3807 return MATCH_ERROR;
3808
3809 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3810 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3811 return MATCH_ERROR;
3812
3813 *result = r;
3814
3815 return MATCH_YES;
3816}
3817
3818
3819/* Match a function suffix, which could be a combination of a result
3820 clause and BIND(C), either one, or neither. The draft does not
3821 require them to come in a specific order. */
3822
3823match
3824gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3825{
3826 match is_bind_c; /* Found bind(c). */
3827 match is_result; /* Found result clause. */
3828 match found_match; /* Status of whether we've found a good match. */
3829 int peek_char; /* Character we're going to peek at. */
3830
3831 /* Initialize to having found nothing. */
3832 found_match = MATCH_NO;
3833 is_bind_c = MATCH_NO;
3834 is_result = MATCH_NO;
3835
3836 /* Get the next char to narrow between result and bind(c). */
3837 gfc_gobble_whitespace ();
3838 peek_char = gfc_peek_char ();
3839
3840 switch (peek_char)
3841 {
3842 case 'r':
3843 /* Look for result clause. */
3844 is_result = match_result (sym, result);
3845 if (is_result == MATCH_YES)
3846 {
3847 /* Now see if there is a bind(c) after it. */
3848 is_bind_c = gfc_match_bind_c (sym);
3849 /* We've found the result clause and possibly bind(c). */
3850 found_match = MATCH_YES;
3851 }
3852 else
3853 /* This should only be MATCH_ERROR. */
3854 found_match = is_result;
3855 break;
3856 case 'b':
3857 /* Look for bind(c) first. */
3858 is_bind_c = gfc_match_bind_c (sym);
3859 if (is_bind_c == MATCH_YES)
3860 {
3861 /* Now see if a result clause followed it. */
3862 is_result = match_result (sym, result);
3863 found_match = MATCH_YES;
3864 }
3865 else
3866 {
3867 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
3868 found_match = MATCH_ERROR;
3869 }
3870 break;
3871 default:
3872 gfc_error ("Unexpected junk after function declaration at %C");
3873 found_match = MATCH_ERROR;
3874 break;
3875 }
3876
3877 if (is_bind_c == MATCH_YES)
3878 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3879 == FAILURE)
3880 return MATCH_ERROR;
3881
3882 return found_match;
3883}
3884
3885
3886/* Match a PROCEDURE declaration (R1211). */
3887
3888static match
3889match_procedure_decl (void)
3890{
3891 match m;
3892 locus old_loc, entry_loc;
3893 gfc_symbol *sym, *proc_if = NULL;
3894 int num;
3895
3896 old_loc = entry_loc = gfc_current_locus;
3897
3898 gfc_clear_ts (&current_ts);
3899
3900 if (gfc_match (" (") != MATCH_YES)
3901 {
3902 gfc_current_locus = entry_loc;
3903 return MATCH_NO;
3904 }
3905
3906 /* Get the type spec. for the procedure interface. */
3907 old_loc = gfc_current_locus;
3908 m = gfc_match_type_spec (&current_ts, 0);
3909 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
3910 goto got_ts;
3911
3912 if (m == MATCH_ERROR)
3913 return m;
3914
3915 gfc_current_locus = old_loc;
3916
3917 /* Get the name of the procedure or abstract interface
3918 to inherit the interface from. */
3919 m = gfc_match_symbol (&proc_if, 1);
3920
3921 if (m == MATCH_NO)
3922 goto syntax;
3923 else if (m == MATCH_ERROR)
3924 return m;
3925
3926 /* Various interface checks. */
3927 if (proc_if)
3928 {
3929 if (proc_if->generic)
3930 {
3931 gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
3932 return MATCH_ERROR;
3933 }
3934 if (proc_if->attr.proc == PROC_ST_FUNCTION)
3935 {
3936 gfc_error ("Interface '%s' at %C may not be a statement function",
3937 proc_if->name);
3938 return MATCH_ERROR;
3939 }
3940 /* Handle intrinsic procedures. */
3941 if (gfc_intrinsic_name (proc_if->name, 0)
3942 || gfc_intrinsic_name (proc_if->name, 1))
3943 proc_if->attr.intrinsic = 1;
3944 if (proc_if->attr.intrinsic
3945 && !gfc_intrinsic_actual_ok (proc_if->name, 0))
3946 {
3947 gfc_error ("Intrinsic procedure '%s' not allowed "
3948 "in PROCEDURE statement at %C", proc_if->name);
3949 return MATCH_ERROR;
3950 }
3951 /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
3952 (proc_if->name, 0) after PR33162 is fixed. */
3953 if (proc_if->attr.intrinsic)
3954 {
3955 gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
3956 "in PROCEDURE statement at %C not yet implemented "
3957 "in gfortran", proc_if->name);
3958 return MATCH_ERROR;
3959 }
3960 }
3961
3962got_ts:
3963
3964 if (gfc_match (" )") != MATCH_YES)
3965 {
3966 gfc_current_locus = entry_loc;
3967 return MATCH_NO;
3968 }
3969
3970 /* Parse attributes. */
3971 m = match_attr_spec();
3972 if (m == MATCH_ERROR)
3973 return MATCH_ERROR;
3974
3975 /* Get procedure symbols. */
3976 for(num=1;;num++)
3977 {
3978
3979 m = gfc_match_symbol (&sym, 0);
3980 if (m == MATCH_NO)
3981 goto syntax;
3982 else if (m == MATCH_ERROR)
3983 return m;
3984
3985 /* Add current_attr to the symbol attributes. */
3986 if (gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3987 return MATCH_ERROR;
3988
3989 if (sym->attr.is_bind_c)
3990 {
3991 /* Check for C1218. */
3992 if (!proc_if || !proc_if->attr.is_bind_c)
3993 {
3994 gfc_error ("BIND(C) attribute at %C requires "
3995 "an interface with BIND(C)");
3996 return MATCH_ERROR;
3997 }
3998 /* Check for C1217. */
3999 if (has_name_equals && sym->attr.pointer)
4000 {
4001 gfc_error ("BIND(C) procedure with NAME may not have "
4002 "POINTER attribute at %C");
4003 return MATCH_ERROR;
4004 }
4005 if (has_name_equals && sym->attr.dummy)
4006 {
4007 gfc_error ("Dummy procedure at %C may not have "
4008 "BIND(C) attribute with NAME");
4009 return MATCH_ERROR;
4010 }
4011 /* Set binding label for BIND(C). */
4012 if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
4013 return MATCH_ERROR;
4014 }
4015
4016 if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
4017 return MATCH_ERROR;
4018 if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
4019 return MATCH_ERROR;
4020
4021 /* Set interface. */
4022 if (proc_if != NULL)
4023 sym->interface = proc_if;
4024 else if (current_ts.type != BT_UNKNOWN)
4025 {
4026 sym->interface = gfc_new_symbol ("", gfc_current_ns);
4027 sym->interface->ts = current_ts;
4028 sym->interface->attr.function = 1;
4029 sym->ts = sym->interface->ts;
4030 sym->attr.function = sym->interface->attr.function;
4031 }
4032
4033 if (gfc_match_eos () == MATCH_YES)
4034 return MATCH_YES;
4035 if (gfc_match_char (',') != MATCH_YES)
4036 goto syntax;
4037 }
4038
4039syntax:
4040 gfc_error ("Syntax error in PROCEDURE statement at %C");
4041 return MATCH_ERROR;
4042}
4043
4044
4045/* Match a PROCEDURE declaration inside an interface (R1206). */
4046
4047static match
4048match_procedure_in_interface (void)
4049{
4050 match m;
4051 gfc_symbol *sym;
4052 char name[GFC_MAX_SYMBOL_LEN + 1];
4053
4054 if (current_interface.type == INTERFACE_NAMELESS
4055 || current_interface.type == INTERFACE_ABSTRACT)
4056 {
4057 gfc_error ("PROCEDURE at %C must be in a generic interface");
4058 return MATCH_ERROR;
4059 }
4060
4061 for(;;)
4062 {
4063 m = gfc_match_name (name);
4064 if (m == MATCH_NO)
4065 goto syntax;
4066 else if (m == MATCH_ERROR)
4067 return m;
4068 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4069 return MATCH_ERROR;
4070
4071 if (gfc_add_interface (sym) == FAILURE)
4072 return MATCH_ERROR;
4073
4074 sym->attr.procedure = 1;
4075
4076 if (gfc_match_eos () == MATCH_YES)
4077 break;
4078 if (gfc_match_char (',') != MATCH_YES)
4079 goto syntax;
4080 }
4081
4082 return MATCH_YES;
4083
4084syntax:
4085 gfc_error ("Syntax error in PROCEDURE statement at %C");
4086 return MATCH_ERROR;
4087}
4088
4089
4090/* General matcher for PROCEDURE declarations. */
4091
4092match
4093gfc_match_procedure (void)
4094{
4095 match m;
4096
4097 switch (gfc_current_state ())
4098 {
4099 case COMP_NONE:
4100 case COMP_PROGRAM:
4101 case COMP_MODULE:
4102 case COMP_SUBROUTINE:
4103 case COMP_FUNCTION:
4104 m = match_procedure_decl ();
4105 break;
4106 case COMP_INTERFACE:
4107 m = match_procedure_in_interface ();
4108 break;
4109 case COMP_DERIVED:
4110 gfc_error ("Fortran 2003: Procedure components at %C are "
4111 "not yet implemented in gfortran");
4112 return MATCH_ERROR;
4113 default:
4114 return MATCH_NO;
4115 }
4116
4117 if (m != MATCH_YES)
4118 return m;
4119
4120 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
4121 == FAILURE)
4122 return MATCH_ERROR;
4123
4124 return m;
4125}
4126
4127
4128/* Match a function declaration. */
4129
4130match
4131gfc_match_function_decl (void)
4132{
4133 char name[GFC_MAX_SYMBOL_LEN + 1];
4134 gfc_symbol *sym, *result;
4135 locus old_loc;
4136 match m;
4137 match suffix_match;
4138 match found_match; /* Status returned by match func. */
4139
4140 if (gfc_current_state () != COMP_NONE
4141 && gfc_current_state () != COMP_INTERFACE
4142 && gfc_current_state () != COMP_CONTAINS)
4143 return MATCH_NO;
4144
4145 gfc_clear_ts (&current_ts);
4146
4147 old_loc = gfc_current_locus;
4148
4149 m = match_prefix (&current_ts);
4150 if (m != MATCH_YES)
4151 {
4152 gfc_current_locus = old_loc;
4153 return m;
4154 }
4155
4156 if (gfc_match ("function% %n", name) != MATCH_YES)
4157 {
4158 gfc_current_locus = old_loc;
4159 return MATCH_NO;
4160 }
4161 if (get_proc_name (name, &sym, false))
4162 return MATCH_ERROR;
4163 gfc_new_block = sym;
4164
4165 m = gfc_match_formal_arglist (sym, 0, 0);
4166 if (m == MATCH_NO)
4167 {
4168 gfc_error ("Expected formal argument list in function "
4169 "definition at %C");
4170 m = MATCH_ERROR;
4171 goto cleanup;
4172 }
4173 else if (m == MATCH_ERROR)
4174 goto cleanup;
4175
4176 result = NULL;
4177
4178 /* According to the draft, the bind(c) and result clause can
4179 come in either order after the formal_arg_list (i.e., either
4180 can be first, both can exist together or by themselves or neither
4181 one). Therefore, the match_result can't match the end of the
4182 string, and check for the bind(c) or result clause in either order. */
4183 found_match = gfc_match_eos ();
4184
4185 /* Make sure that it isn't already declared as BIND(C). If it is, it
4186 must have been marked BIND(C) with a BIND(C) attribute and that is
4187 not allowed for procedures. */
4188 if (sym->attr.is_bind_c == 1)
4189 {
4190 sym->attr.is_bind_c = 0;
4191 if (sym->old_symbol != NULL)
4192 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4193 "variables or common blocks",
4194 &(sym->old_symbol->declared_at));
4195 else
4196 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4197 "variables or common blocks", &gfc_current_locus);
4198 }
4199
4200 if (found_match != MATCH_YES)
4201 {
4202 /* If we haven't found the end-of-statement, look for a suffix. */
4203 suffix_match = gfc_match_suffix (sym, &result);
4204 if (suffix_match == MATCH_YES)
4205 /* Need to get the eos now. */
4206 found_match = gfc_match_eos ();
4207 else
4208 found_match = suffix_match;
4209 }
4210
4211 if(found_match != MATCH_YES)
4212 m = MATCH_ERROR;
4213 else
4214 {
4215 /* Make changes to the symbol. */
4216 m = MATCH_ERROR;
4217
4218 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
4219 goto cleanup;
4220
4221 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
4222 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4223 goto cleanup;
4224
4225 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
4226 && !sym->attr.implicit_type)
4227 {
4228 gfc_error ("Function '%s' at %C already has a type of %s", name,
4229 gfc_basic_typename (sym->ts.type));
4230 goto cleanup;
4231 }
4232
4233 if (result == NULL)
4234 {
4235 sym->ts = current_ts;
4236 sym->result = sym;
4237 }
4238 else
4239 {
4240 result->ts = current_ts;
4241 sym->result = result;
4242 }
4243
4244 return MATCH_YES;
4245 }
4246
4247cleanup:
4248 gfc_current_locus = old_loc;
4249 return m;
4250}
4251
4252
4253/* This is mostly a copy of parse.c(add_global_procedure) but modified to
4254 pass the name of the entry, rather than the gfc_current_block name, and
4255 to return false upon finding an existing global entry. */
4256
4257static bool
4258add_global_entry (const char *name, int sub)
4259{
4260 gfc_gsymbol *s;
4261
4262 s = gfc_get_gsymbol(name);
4263
4264 if (s->defined
4265 || (s->type != GSYM_UNKNOWN
4266 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4267 gfc_global_used(s, NULL);
4268 else
4269 {
4270 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4271 s->where = gfc_current_locus;
4272 s->defined = 1;
4273 return true;
4274 }
4275 return false;
4276}
4277
4278
4279/* Match an ENTRY statement. */
4280
4281match
4282gfc_match_entry (void)
4283{
4284 gfc_symbol *proc;
4285 gfc_symbol *result;
4286 gfc_symbol *entry;
4287 char name[GFC_MAX_SYMBOL_LEN + 1];
4288 gfc_compile_state state;
4289 match m;
4290 gfc_entry_list *el;
4291 locus old_loc;
4292 bool module_procedure;
4293
4294 m = gfc_match_name (name);
4295 if (m != MATCH_YES)
4296 return m;
4297
4298 state = gfc_current_state ();
4299 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
4300 {
4301 switch (state)
4302 {
4303 case COMP_PROGRAM:
4304 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
4305 break;
4306 case COMP_MODULE:
4307 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
4308 break;
4309 case COMP_BLOCK_DATA:
4310 gfc_error ("ENTRY statement at %C cannot appear within "
4311 "a BLOCK DATA");
4312 break;
4313 case COMP_INTERFACE:
4314 gfc_error ("ENTRY statement at %C cannot appear within "
4315 "an INTERFACE");
4316 break;
4317 case COMP_DERIVED:
4318 gfc_error ("ENTRY statement at %C cannot appear within "
4319 "a DERIVED TYPE block");
4320 break;
4321 case COMP_IF:
4322 gfc_error ("ENTRY statement at %C cannot appear within "
4323 "an IF-THEN block");
4324 break;
4325 case COMP_DO:
4326 gfc_error ("ENTRY statement at %C cannot appear within "
4327 "a DO block");
4328 break;
4329 case COMP_SELECT:
4330 gfc_error ("ENTRY statement at %C cannot appear within "
4331 "a SELECT block");
4332 break;
4333 case COMP_FORALL:
4334 gfc_error ("ENTRY statement at %C cannot appear within "
4335 "a FORALL block");
4336 break;
4337 case COMP_WHERE:
4338 gfc_error ("ENTRY statement at %C cannot appear within "
4339 "a WHERE block");
4340 break;
4341 case COMP_CONTAINS:
4342 gfc_error ("ENTRY statement at %C cannot appear within "
4343 "a contained subprogram");
4344 break;
4345 default:
4346 gfc_internal_error ("gfc_match_entry(): Bad state");
4347 }
4348 return MATCH_ERROR;
4349 }
4350
4351 module_procedure = gfc_current_ns->parent != NULL
4352 && gfc_current_ns->parent->proc_name
4353 && gfc_current_ns->parent->proc_name->attr.flavor
4354 == FL_MODULE;
4355
4356 if (gfc_current_ns->parent != NULL
4357 && gfc_current_ns->parent->proc_name
4358 && !module_procedure)
4359 {
4360 gfc_error("ENTRY statement at %C cannot appear in a "
4361 "contained procedure");
4362 return MATCH_ERROR;
4363 }
4364
4365 /* Module function entries need special care in get_proc_name
4366 because previous references within the function will have
4367 created symbols attached to the current namespace. */
4368 if (get_proc_name (name, &entry,
4369 gfc_current_ns->parent != NULL
4370 && module_procedure
4371 && gfc_current_ns->proc_name->attr.function))
4372 return MATCH_ERROR;
4373
4374 proc = gfc_current_block ();
4375
4376 if (state == COMP_SUBROUTINE)
4377 {
4378 /* An entry in a subroutine. */
4379 if (!add_global_entry (name, 1))
4380 return MATCH_ERROR;
4381
4382 m = gfc_match_formal_arglist (entry, 0, 1);
4383 if (m != MATCH_YES)
4384 return MATCH_ERROR;
4385
4386 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4387 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4388 return MATCH_ERROR;
4389 }
4390 else
4391 {
4392 /* An entry in a function.
4393 We need to take special care because writing
4394 ENTRY f()
4395 as
4396 ENTRY f
4397 is allowed, whereas
4398 ENTRY f() RESULT (r)
4399 can't be written as
4400 ENTRY f RESULT (r). */
4401 if (!add_global_entry (name, 0))
4402 return MATCH_ERROR;
4403
4404 old_loc = gfc_current_locus;
4405 if (gfc_match_eos () == MATCH_YES)
4406 {
4407 gfc_current_locus = old_loc;
4408 /* Match the empty argument list, and add the interface to
4409 the symbol. */
4410 m = gfc_match_formal_arglist (entry, 0, 1);
4411 }
4412 else
4413 m = gfc_match_formal_arglist (entry, 0, 0);
4414
4415 if (m != MATCH_YES)
4416 return MATCH_ERROR;
4417
4418 result = NULL;
4419
4420 if (gfc_match_eos () == MATCH_YES)
4421 {
4422 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4423 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4424 return MATCH_ERROR;
4425
4426 entry->result = entry;
4427 }
4428 else
4429 {
4430 m = match_result (proc, &result);
4431 if (m == MATCH_NO)
4432 gfc_syntax_error (ST_ENTRY);
4433 if (m != MATCH_YES)
4434 return MATCH_ERROR;
4435
4436 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
4437 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
4438 || gfc_add_function (&entry->attr, result->name, NULL)
4439 == FAILURE)
4440 return MATCH_ERROR;
4441
4442 entry->result = result;
4443 }
4444 }
4445
4446 if (gfc_match_eos () != MATCH_YES)
4447 {
4448 gfc_syntax_error (ST_ENTRY);
4449 return MATCH_ERROR;
4450 }
4451
4452 entry->attr.recursive = proc->attr.recursive;
4453 entry->attr.elemental = proc->attr.elemental;
4454 entry->attr.pure = proc->attr.pure;
4455
4456 el = gfc_get_entry_list ();
4457 el->sym = entry;
4458 el->next = gfc_current_ns->entries;
4459 gfc_current_ns->entries = el;
4460 if (el->next)
4461 el->id = el->next->id + 1;
4462 else
4463 el->id = 1;
4464
4465 new_st.op = EXEC_ENTRY;
4466 new_st.ext.entry = el;
4467
4468 return MATCH_YES;
4469}
4470
4471
4472/* Match a subroutine statement, including optional prefixes. */
4473
4474match
4475gfc_match_subroutine (void)
4476{
4477 char name[GFC_MAX_SYMBOL_LEN + 1];
4478 gfc_symbol *sym;
4479 match m;
4480 match is_bind_c;
4481 char peek_char;
4482
4483 if (gfc_current_state () != COMP_NONE
4484 && gfc_current_state () != COMP_INTERFACE
4485 && gfc_current_state () != COMP_CONTAINS)
4486 return MATCH_NO;
4487
4488 m = match_prefix (NULL);
4489 if (m != MATCH_YES)
4490 return m;
4491
4492 m = gfc_match ("subroutine% %n", name);
4493 if (m != MATCH_YES)
4494 return m;
4495
4496 if (get_proc_name (name, &sym, false))
4497 return MATCH_ERROR;
4498 gfc_new_block = sym;
4499
4500 /* Check what next non-whitespace character is so we can tell if there
4501 where the required parens if we have a BIND(C). */
4502 gfc_gobble_whitespace ();
4503 peek_char = gfc_peek_char ();
4504
4505 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4506 return MATCH_ERROR;
4507
4508 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4509 return MATCH_ERROR;
4510
4511 /* Make sure that it isn't already declared as BIND(C). If it is, it
4512 must have been marked BIND(C) with a BIND(C) attribute and that is
4513 not allowed for procedures. */
4514 if (sym->attr.is_bind_c == 1)
4515 {
4516 sym->attr.is_bind_c = 0;
4517 if (sym->old_symbol != NULL)
4518 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4519 "variables or common blocks",
4520 &(sym->old_symbol->declared_at));
4521 else
4522 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4523 "variables or common blocks", &gfc_current_locus);
4524 }
4525
4526 /* Here, we are just checking if it has the bind(c) attribute, and if
4527 so, then we need to make sure it's all correct. If it doesn't,
4528 we still need to continue matching the rest of the subroutine line. */
4529 is_bind_c = gfc_match_bind_c (sym);
4530 if (is_bind_c == MATCH_ERROR)
4531 {
4532 /* There was an attempt at the bind(c), but it was wrong. An
4533 error message should have been printed w/in the gfc_match_bind_c
4534 so here we'll just return the MATCH_ERROR. */
4535 return MATCH_ERROR;
4536 }
4537
4538 if (is_bind_c == MATCH_YES)
4539 {
4540 if (peek_char != '(')
4541 {
4542 gfc_error ("Missing required parentheses before BIND(C) at %C");
4543 return MATCH_ERROR;
4544 }
4545 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4546 == FAILURE)
4547 return MATCH_ERROR;
4548 }
4549
4550 if (gfc_match_eos () != MATCH_YES)
4551 {
4552 gfc_syntax_error (ST_SUBROUTINE);
4553 return MATCH_ERROR;
4554 }
4555
4556 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4557 return MATCH_ERROR;
4558
4559 return MATCH_YES;
4560}
4561
4562
4563/* Match a BIND(C) specifier, with the optional 'name=' specifier if
4564 given, and set the binding label in either the given symbol (if not
4565 NULL), or in the current_ts. The symbol may be NULL because we may
4566 encounter the BIND(C) before the declaration itself. Return
4567 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4568 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4569 or MATCH_YES if the specifier was correct and the binding label and
4570 bind(c) fields were set correctly for the given symbol or the
4571 current_ts. */
4572
4573match
4574gfc_match_bind_c (gfc_symbol *sym)
4575{
4576 /* binding label, if exists */
4577 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4578 match double_quote;
4579 match single_quote;
4580
4581 /* Initialize the flag that specifies whether we encountered a NAME=
4582 specifier or not. */
4583 has_name_equals = 0;
4584
4585 /* Init the first char to nil so we can catch if we don't have
4586 the label (name attr) or the symbol name yet. */
4587 binding_label[0] = '\0';
4588
4589 /* This much we have to be able to match, in this order, if
4590 there is a bind(c) label. */
4591 if (gfc_match (" bind ( c ") != MATCH_YES)
4592 return MATCH_NO;
4593
4594 /* Now see if there is a binding label, or if we've reached the
4595 end of the bind(c) attribute without one. */
4596 if (gfc_match_char (',') == MATCH_YES)
4597 {
4598 if (gfc_match (" name = ") != MATCH_YES)
4599 {
4600 gfc_error ("Syntax error in NAME= specifier for binding label "
4601 "at %C");
4602 /* should give an error message here */
4603 return MATCH_ERROR;
4604 }
4605
4606 has_name_equals = 1;
4607
4608 /* Get the opening quote. */
4609 double_quote = MATCH_YES;
4610 single_quote = MATCH_YES;
4611 double_quote = gfc_match_char ('"');
4612 if (double_quote != MATCH_YES)
4613 single_quote = gfc_match_char ('\'');
4614 if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4615 {
4616 gfc_error ("Syntax error in NAME= specifier for binding label "
4617 "at %C");
4618 return MATCH_ERROR;
4619 }
4620
4621 /* Grab the binding label, using functions that will not lower
4622 case the names automatically. */
4623 if (gfc_match_name_C (binding_label) != MATCH_YES)
4624 return MATCH_ERROR;
4625
4626 /* Get the closing quotation. */
4627 if (double_quote == MATCH_YES)
4628 {
4629 if (gfc_match_char ('"') != MATCH_YES)
4630 {
4631 gfc_error ("Missing closing quote '\"' for binding label at %C");
4632 /* User started string with '"' so looked to match it. */
4633 return MATCH_ERROR;
4634 }
4635 }
4636 else
4637 {
4638 if (gfc_match_char ('\'') != MATCH_YES)
4639 {
4640 gfc_error ("Missing closing quote '\'' for binding label at %C");
4641 /* User started string with "'" char. */
4642 return MATCH_ERROR;
4643 }
4644 }
4645 }
4646
4647 /* Get the required right paren. */
4648 if (gfc_match_char (')') != MATCH_YES)
4649 {
4650 gfc_error ("Missing closing paren for binding label at %C");
4651 return MATCH_ERROR;
4652 }
4653
4654 /* Save the binding label to the symbol. If sym is null, we're
4655 probably matching the typespec attributes of a declaration and
4656 haven't gotten the name yet, and therefore, no symbol yet. */
4657 if (binding_label[0] != '\0')
4658 {
4659 if (sym != NULL)
4660 {
4661 strncpy (sym->binding_label, binding_label,
4662 strlen (binding_label)+1);
4663 }
4664 else
4665 strncpy (curr_binding_label, binding_label,
4666 strlen (binding_label) + 1);
4667 }
4668 else
4669 {
4670 /* No binding label, but if symbol isn't null, we
4671 can set the label for it here. */
4672 /* TODO: If the name= was given and no binding label (name=""), we simply
4673 will let fortran mangle the symbol name as it usually would.
4674 However, this could still let C call it if the user looked up the
4675 symbol in the object file. Should the name set during mangling in
4676 trans-decl.c be marked with characters that are invalid for C to
4677 prevent this? */
4678 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4679 strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4680 }
4681
4682 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
4683 && current_interface.type == INTERFACE_ABSTRACT)
4684 {
4685 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4686 return MATCH_ERROR;
4687 }
4688
4689 return MATCH_YES;
4690}
4691
4692
4693/* Return nonzero if we're currently compiling a contained procedure. */
4694
4695static int
4696contained_procedure (void)
4697{
4698 gfc_state_data *s;
4699
4700 for (s=gfc_state_stack; s; s=s->previous)
4701 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4702 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
4703 return 1;
4704
4705 return 0;
4706}
4707
4708/* Set the kind of each enumerator. The kind is selected such that it is
4709 interoperable with the corresponding C enumeration type, making
4710 sure that -fshort-enums is honored. */
4711
4712static void
4713set_enum_kind(void)
4714{
4715 enumerator_history *current_history = NULL;
4716 int kind;
4717 int i;
4718
4719 if (max_enum == NULL || enum_history == NULL)
4720 return;
4721
4722 if (!gfc_option.fshort_enums)
4723 return;
4724
4725 i = 0;
4726 do
4727 {
4728 kind = gfc_integer_kinds[i++].kind;
4729 }
4730 while (kind < gfc_c_int_kind
4731 && gfc_check_integer_range (max_enum->initializer->value.integer,
4732 kind) != ARITH_OK);
4733
4734 current_history = enum_history;
4735 while (current_history != NULL)
4736 {
4737 current_history->sym->ts.kind = kind;
4738 current_history = current_history->next;
4739 }
4740}
4741
4742
4743/* Match any of the various end-block statements. Returns the type of
4744 END to the caller. The END INTERFACE, END IF, END DO and END
4745 SELECT statements cannot be replaced by a single END statement. */
4746
4747match
4748gfc_match_end (gfc_statement *st)
4749{
4750 char name[GFC_MAX_SYMBOL_LEN + 1];
4751 gfc_compile_state state;
4752 locus old_loc;
4753 const char *block_name;
4754 const char *target;
4755 int eos_ok;
4756 match m;
4757
4758 old_loc = gfc_current_locus;
4759 if (gfc_match ("end") != MATCH_YES)
4760 return MATCH_NO;
4761
4762 state = gfc_current_state ();
4763 block_name = gfc_current_block () == NULL
4764 ? NULL : gfc_current_block ()->name;
4765
4766 if (state == COMP_CONTAINS)
4767 {
4768 state = gfc_state_stack->previous->state;
4769 block_name = gfc_state_stack->previous->sym == NULL
4770 ? NULL : gfc_state_stack->previous->sym->name;
4771 }
4772
4773 switch (state)
4774 {
4775 case COMP_NONE:
4776 case COMP_PROGRAM:
4777 *st = ST_END_PROGRAM;
4778 target = " program";
4779 eos_ok = 1;
4780 break;
4781
4782 case COMP_SUBROUTINE:
4783 *st = ST_END_SUBROUTINE;
4784 target = " subroutine";
4785 eos_ok = !contained_procedure ();
4786 break;
4787
4788 case COMP_FUNCTION:
4789 *st = ST_END_FUNCTION;
4790 target = " function";
4791 eos_ok = !contained_procedure ();
4792 break;
4793
4794 case COMP_BLOCK_DATA:
4795 *st = ST_END_BLOCK_DATA;
4796 target = " block data";
4797 eos_ok = 1;
4798 break;
4799
4800 case COMP_MODULE:
4801 *st = ST_END_MODULE;
4802 target = " module";
4803 eos_ok = 1;
4804 break;
4805
4806 case COMP_INTERFACE:
4807 *st = ST_END_INTERFACE;
4808 target = " interface";
4809 eos_ok = 0;
4810 break;
4811
4812 case COMP_DERIVED:
4813 *st = ST_END_TYPE;
4814 target = " type";
4815 eos_ok = 0;
4816 break;
4817
4818 case COMP_IF:
4819 *st = ST_ENDIF;
4820 target = " if";
4821 eos_ok = 0;
4822 break;
4823
4824 case COMP_DO:
4825 *st = ST_ENDDO;
4826 target = " do";
4827 eos_ok = 0;
4828 break;
4829
4830 case COMP_SELECT:
4831 *st = ST_END_SELECT;
4832 target = " select";
4833 eos_ok = 0;
4834 break;
4835
4836 case COMP_FORALL:
4837 *st = ST_END_FORALL;
4838 target = " forall";
4839 eos_ok = 0;
4840 break;
4841
4842 case COMP_WHERE:
4843 *st = ST_END_WHERE;
4844 target = " where";
4845 eos_ok = 0;
4846 break;
4847
4848 case COMP_ENUM:
4849 *st = ST_END_ENUM;
4850 target = " enum";
4851 eos_ok = 0;
4852 last_initializer = NULL;
4853 set_enum_kind ();
4854 gfc_free_enum_history ();
4855 break;
4856
4857 default:
4858 gfc_error ("Unexpected END statement at %C");
4859 goto cleanup;
4860 }
4861
4862 if (gfc_match_eos () == MATCH_YES)
4863 {
4864 if (!eos_ok)
4865 {
4866 /* We would have required END [something]. */
4867 gfc_error ("%s statement expected at %L",
4868 gfc_ascii_statement (*st), &old_loc);
4869 goto cleanup;
4870 }
4871
4872 return MATCH_YES;
4873 }
4874
4875 /* Verify that we've got the sort of end-block that we're expecting. */
4876 if (gfc_match (target) != MATCH_YES)
4877 {
4878 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
4879 goto cleanup;
4880 }
4881
4882 /* If we're at the end, make sure a block name wasn't required. */
4883 if (gfc_match_eos () == MATCH_YES)
4884 {
4885
4886 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
4887 && *st != ST_END_FORALL && *st != ST_END_WHERE)
4888 return MATCH_YES;
4889
4890 if (gfc_current_block () == NULL)
4891 return MATCH_YES;
4892
4893 gfc_error ("Expected block name of '%s' in %s statement at %C",
4894 block_name, gfc_ascii_statement (*st));
4895
4896 return MATCH_ERROR;
4897 }
4898
4899 /* END INTERFACE has a special handler for its several possible endings. */
4900 if (*st == ST_END_INTERFACE)
4901 return gfc_match_end_interface ();
4902
4903 /* We haven't hit the end of statement, so what is left must be an
4904 end-name. */
4905 m = gfc_match_space ();
4906 if (m == MATCH_YES)
4907 m = gfc_match_name (name);
4908
4909 if (m == MATCH_NO)
4910 gfc_error ("Expected terminating name at %C");
4911 if (m != MATCH_YES)
4912 goto cleanup;
4913
4914 if (block_name == NULL)
4915 goto syntax;
4916
4917 if (strcmp (name, block_name) != 0)
4918 {
4919 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
4920 gfc_ascii_statement (*st));
4921 goto cleanup;
4922 }
4923
4924 if (gfc_match_eos () == MATCH_YES)
4925 return MATCH_YES;
4926
4927syntax:
4928 gfc_syntax_error (*st);
4929
4930cleanup:
4931 gfc_current_locus = old_loc;
4932 return MATCH_ERROR;
4933}
4934
4935
4936
4937/***************** Attribute declaration statements ****************/
4938
4939/* Set the attribute of a single variable. */
4940
4941static match
4942attr_decl1 (void)
4943{
4944 char name[GFC_MAX_SYMBOL_LEN + 1];
4945 gfc_array_spec *as;
4946 gfc_symbol *sym;
4947 locus var_locus;
4948 match m;
4949
4950 as = NULL;
4951
4952 m = gfc_match_name (name);
4953 if (m != MATCH_YES)
4954 goto cleanup;
4955
4956 if (find_special (name, &sym))
4957 return MATCH_ERROR;
4958
4959 var_locus = gfc_current_locus;
4960
4961 /* Deal with possible array specification for certain attributes. */
4962 if (current_attr.dimension
4963 || current_attr.allocatable
4964 || current_attr.pointer
4965 || current_attr.target)
4966 {
4967 m = gfc_match_array_spec (&as);
4968 if (m == MATCH_ERROR)
4969 goto cleanup;
4970
4971 if (current_attr.dimension && m == MATCH_NO)
4972 {
4973 gfc_error ("Missing array specification at %L in DIMENSION "
4974 "statement", &var_locus);
4975 m = MATCH_ERROR;
4976 goto cleanup;
4977 }
4978
4979 if ((current_attr.allocatable || current_attr.pointer)
4980 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
4981 {
4982 gfc_error ("Array specification must be deferred at %L", &var_locus);
4983 m = MATCH_ERROR;
4984 goto cleanup;
4985 }
4986 }
4987
4988 /* Update symbol table. DIMENSION attribute is set
4989 in gfc_set_array_spec(). */
4990 if (current_attr.dimension == 0
4991 && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
4992 {
4993 m = MATCH_ERROR;
4994 goto cleanup;
4995 }
4996
4997 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
4998 {
4999 m = MATCH_ERROR;
5000 goto cleanup;
5001 }
5002
5003 if (sym->attr.cray_pointee && sym->as != NULL)
5004 {
5005 /* Fix the array spec. */
5006 m = gfc_mod_pointee_as (sym->as);
5007 if (m == MATCH_ERROR)
5008 goto cleanup;
5009 }
5010
5011 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
5012 {
5013 m = MATCH_ERROR;
5014 goto cleanup;
5015 }
5016
5017 if ((current_attr.external || current_attr.intrinsic)
5018 && sym->attr.flavor != FL_PROCEDURE
5019 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
5020 {
5021 m = MATCH_ERROR;
5022 goto cleanup;
5023 }
5024
5025 return MATCH_YES;
5026
5027cleanup:
5028 gfc_free_array_spec (as);
5029 return m;
5030}
5031
5032
5033/* Generic attribute declaration subroutine. Used for attributes that
5034 just have a list of names. */
5035
5036static match
5037attr_decl (void)
5038{
5039 match m;
5040
5041 /* Gobble the optional double colon, by simply ignoring the result
5042 of gfc_match(). */
5043 gfc_match (" ::");
5044
5045 for (;;)
5046 {
5047 m = attr_decl1 ();
5048 if (m != MATCH_YES)
5049 break;
5050
5051 if (gfc_match_eos () == MATCH_YES)
5052 {
5053 m = MATCH_YES;
5054 break;
5055 }
5056
5057 if (gfc_match_char (',') != MATCH_YES)
5058 {
5059 gfc_error ("Unexpected character in variable list at %C");
5060 m = MATCH_ERROR;
5061 break;
5062 }
5063 }
5064
5065 return m;
5066}
5067
5068
5069/* This routine matches Cray Pointer declarations of the form:
5070 pointer ( <pointer>, <pointee> )
5071 or
5072 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
5073 The pointer, if already declared, should be an integer. Otherwise, we
5074 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
5075 be either a scalar, or an array declaration. No space is allocated for
5076 the pointee. For the statement
5077 pointer (ipt, ar(10))
5078 any subsequent uses of ar will be translated (in C-notation) as
5079 ar(i) => ((<type> *) ipt)(i)
5080 After gimplification, pointee variable will disappear in the code. */
5081
5082static match
5083cray_pointer_decl (void)
5084{
5085 match m;
5086 gfc_array_spec *as;
5087 gfc_symbol *cptr; /* Pointer symbol. */
5088 gfc_symbol *cpte; /* Pointee symbol. */
5089 locus var_locus;
5090 bool done = false;
5091
5092 while (!done)
5093 {
5094 if (gfc_match_char ('(') != MATCH_YES)
5095 {
5096 gfc_error ("Expected '(' at %C");
5097 return MATCH_ERROR;
5098 }
5099
5100 /* Match pointer. */
5101 var_locus = gfc_current_locus;
5102 gfc_clear_attr (&current_attr);
5103 gfc_add_cray_pointer (&current_attr, &var_locus);
5104 current_ts.type = BT_INTEGER;
5105 current_ts.kind = gfc_index_integer_kind;
5106
5107 m = gfc_match_symbol (&cptr, 0);
5108 if (m != MATCH_YES)
5109 {
5110 gfc_error ("Expected variable name at %C");
5111 return m;
5112 }
5113
5114 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
5115 return MATCH_ERROR;
5116
5117 gfc_set_sym_referenced (cptr);
5118
5119 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
5120 {
5121 cptr->ts.type = BT_INTEGER;
5122 cptr->ts.kind = gfc_index_integer_kind;
5123 }
5124 else if (cptr->ts.type != BT_INTEGER)
5125 {
5126 gfc_error ("Cray pointer at %C must be an integer");
5127 return MATCH_ERROR;
5128 }
5129 else if (cptr->ts.kind < gfc_index_integer_kind)
5130 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
5131 " memory addresses require %d bytes",
5132 cptr->ts.kind, gfc_index_integer_kind);
5133
5134 if (gfc_match_char (',') != MATCH_YES)
5135 {
5136 gfc_error ("Expected \",\" at %C");
5137 return MATCH_ERROR;
5138 }
5139
5140 /* Match Pointee. */
5141 var_locus = gfc_current_locus;
5142 gfc_clear_attr (&current_attr);
5143 gfc_add_cray_pointee (&current_attr, &var_locus);
5144 current_ts.type = BT_UNKNOWN;
5145 current_ts.kind = 0;
5146
5147 m = gfc_match_symbol (&cpte, 0);
5148 if (m != MATCH_YES)
5149 {
5150 gfc_error ("Expected variable name at %C");
5151 return m;
5152 }
5153
5154 /* Check for an optional array spec. */
5155 m = gfc_match_array_spec (&as);
5156 if (m == MATCH_ERROR)
5157 {
5158 gfc_free_array_spec (as);
5159 return m;
5160 }
5161 else if (m == MATCH_NO)
5162 {
5163 gfc_free_array_spec (as);
5164 as = NULL;
5165 }
5166
5167 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
5168 return MATCH_ERROR;
5169
5170 gfc_set_sym_referenced (cpte);
5171
5172 if (cpte->as == NULL)
5173 {
5174 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
5175 gfc_internal_error ("Couldn't set Cray pointee array spec.");
5176 }
5177 else if (as != NULL)
5178 {
5179 gfc_error ("Duplicate array spec for Cray pointee at %C");
5180 gfc_free_array_spec (as);
5181 return MATCH_ERROR;
5182 }
5183
5184 as = NULL;
5185
5186 if (cpte->as != NULL)
5187 {
5188 /* Fix array spec. */
5189 m = gfc_mod_pointee_as (cpte->as);
5190 if (m == MATCH_ERROR)
5191 return m;
5192 }
5193
5194 /* Point the Pointee at the Pointer. */
5195 cpte->cp_pointer = cptr;
5196
5197 if (gfc_match_char (')') != MATCH_YES)
5198 {
5199 gfc_error ("Expected \")\" at %C");
5200 return MATCH_ERROR;
5201 }
5202 m = gfc_match_char (',');
5203 if (m != MATCH_YES)
5204 done = true; /* Stop searching for more declarations. */
5205
5206 }
5207
5208 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
5209 || gfc_match_eos () != MATCH_YES)
5210 {
5211 gfc_error ("Expected \",\" or end of statement at %C");
5212 return MATCH_ERROR;
5213 }
5214 return MATCH_YES;
5215}
5216
5217
5218match
5219gfc_match_external (void)
5220{
5221
5222 gfc_clear_attr (&current_attr);
5223 current_attr.external = 1;
5224
5225 return attr_decl ();
5226}
5227
5228
5229match
5230gfc_match_intent (void)
5231{
5232 sym_intent intent;
5233
5234 intent = match_intent_spec ();
5235 if (intent == INTENT_UNKNOWN)
5236 return MATCH_ERROR;
5237
5238 gfc_clear_attr (&current_attr);
5239 current_attr.intent = intent;
5240
5241 return attr_decl ();
5242}
5243
5244
5245match
5246gfc_match_intrinsic (void)
5247{
5248
5249 gfc_clear_attr (&current_attr);
5250 current_attr.intrinsic = 1;
5251
5252 return attr_decl ();
5253}
5254
5255
5256match
5257gfc_match_optional (void)
5258{
5259
5260 gfc_clear_attr (&current_attr);
5261 current_attr.optional = 1;
5262
5263 return attr_decl ();
5264}
5265
5266
5267match
5268gfc_match_pointer (void)
5269{
5270 gfc_gobble_whitespace ();
5271 if (gfc_peek_char () == '(')
5272 {
5273 if (!gfc_option.flag_cray_pointer)
5274 {
5275 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
5276 "flag");
5277 return MATCH_ERROR;
5278 }
5279 return cray_pointer_decl ();
5280 }
5281 else
5282 {
5283 gfc_clear_attr (&current_attr);
5284 current_attr.pointer = 1;
5285
5286 return attr_decl ();
5287 }
5288}
5289
5290
5291match
5292gfc_match_allocatable (void)
5293{
5294 gfc_clear_attr (&current_attr);
5295 current_attr.allocatable = 1;
5296
5297 return attr_decl ();
5298}
5299
5300
5301match
5302gfc_match_dimension (void)
5303{
5304 gfc_clear_attr (&current_attr);
5305 current_attr.dimension = 1;
5306
5307 return attr_decl ();
5308}
5309
5310
5311match
5312gfc_match_target (void)
5313{
5314 gfc_clear_attr (&current_attr);
5315 current_attr.target = 1;
5316
5317 return attr_decl ();
5318}
5319
5320
5321/* Match the list of entities being specified in a PUBLIC or PRIVATE
5322 statement. */
5323
5324static match
5325access_attr_decl (gfc_statement st)
5326{
5327 char name[GFC_MAX_SYMBOL_LEN + 1];
5328 interface_type type;
5329 gfc_user_op *uop;
5330 gfc_symbol *sym;
5331 gfc_intrinsic_op operator;
5332 match m;
5333
5334 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5335 goto done;
5336
5337 for (;;)
5338 {
5339 m = gfc_match_generic_spec (&type, name, &operator);
5340 if (m == MATCH_NO)
5341 goto syntax;
5342 if (m == MATCH_ERROR)
5343 return MATCH_ERROR;
5344
5345 switch (type)
5346 {
5347 case INTERFACE_NAMELESS:
5348 case INTERFACE_ABSTRACT:
5349 goto syntax;
5350
5351 case INTERFACE_GENERIC:
5352 if (gfc_get_symbol (name, NULL, &sym))
5353 goto done;
5354
5355 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
5356 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
5357 sym->name, NULL) == FAILURE)
5358 return MATCH_ERROR;
5359
5360 break;
5361
5362 case INTERFACE_INTRINSIC_OP:
5363 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
5364 {
5365 gfc_current_ns->operator_access[operator] =
5366 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5367 }
5368 else
5369 {
5370 gfc_error ("Access specification of the %s operator at %C has "
5371 "already been specified", gfc_op2string (operator));
5372 goto done;
5373 }
5374
5375 break;
5376
5377 case INTERFACE_USER_OP:
5378 uop = gfc_get_uop (name);
5379
5380 if (uop->access == ACCESS_UNKNOWN)
5381 {
5382 uop->access = (st == ST_PUBLIC)
5383 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5384 }
5385 else
5386 {
5387 gfc_error ("Access specification of the .%s. operator at %C "
5388 "has already been specified", sym->name);
5389 goto done;
5390 }
5391
5392 break;
5393 }
5394
5395 if (gfc_match_char (',') == MATCH_NO)
5396 break;
5397 }
5398
5399 if (gfc_match_eos () != MATCH_YES)
5400 goto syntax;
5401 return MATCH_YES;
5402
5403syntax:
5404 gfc_syntax_error (st);
5405
5406done:
5407 return MATCH_ERROR;
5408}
5409
5410
5411match
5412gfc_match_protected (void)
5413{
5414 gfc_symbol *sym;
5415 match m;
5416
5417 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5418 {
5419 gfc_error ("PROTECTED at %C only allowed in specification "
5420 "part of a module");
5421 return MATCH_ERROR;
5422
5423 }
5424
5425 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
5426 == FAILURE)
5427 return MATCH_ERROR;
5428
5429 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5430 {
5431 return MATCH_ERROR;
5432 }
5433
5434 if (gfc_match_eos () == MATCH_YES)
5435 goto syntax;
5436
5437 for(;;)
5438 {
5439 m = gfc_match_symbol (&sym, 0);
5440 switch (m)
5441 {
5442 case MATCH_YES:
5443 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
5444 == FAILURE)
5445 return MATCH_ERROR;
5446 goto next_item;
5447
5448 case MATCH_NO:
5449 break;
5450
5451 case MATCH_ERROR:
5452 return MATCH_ERROR;
5453 }
5454
5455 next_item:
5456 if (gfc_match_eos () == MATCH_YES)
5457 break;
5458 if (gfc_match_char (',') != MATCH_YES)
5459 goto syntax;
5460 }
5461
5462 return MATCH_YES;
5463
5464syntax:
5465 gfc_error ("Syntax error in PROTECTED statement at %C");
5466 return MATCH_ERROR;
5467}
5468
5469
5470/* The PRIVATE statement is a bit weird in that it can be an attribute
5471 declaration, but also works as a standlone statement inside of a
5472 type declaration or a module. */
5473
5474match
5475gfc_match_private (gfc_statement *st)
5476{
5477
5478 if (gfc_match ("private") != MATCH_YES)
5479 return MATCH_NO;
5480
5481 if (gfc_current_state () != COMP_MODULE
5482 && (gfc_current_state () != COMP_DERIVED
5483 || !gfc_state_stack->previous
5484 || gfc_state_stack->previous->state != COMP_MODULE))
5485 {
5486 gfc_error ("PRIVATE statement at %C is only allowed in the "
5487 "specification part of a module");
5488 return MATCH_ERROR;
5489 }
5490
5491 if (gfc_current_state () == COMP_DERIVED)
5492 {
5493 if (gfc_match_eos () == MATCH_YES)
5494 {
5495 *st = ST_PRIVATE;
5496 return MATCH_YES;
5497 }
5498
5499 gfc_syntax_error (ST_PRIVATE);
5500 return MATCH_ERROR;
5501 }
5502
5503 if (gfc_match_eos () == MATCH_YES)
5504 {
5505 *st = ST_PRIVATE;
5506 return MATCH_YES;
5507 }
5508
5509 *st = ST_ATTR_DECL;
5510 return access_attr_decl (ST_PRIVATE);
5511}
5512
5513
5514match
5515gfc_match_public (gfc_statement *st)
5516{
5517
5518 if (gfc_match ("public") != MATCH_YES)
5519 return MATCH_NO;
5520
5521 if (gfc_current_state () != COMP_MODULE)
5522 {
5523 gfc_error ("PUBLIC statement at %C is only allowed in the "
5524 "specification part of a module");
5525 return MATCH_ERROR;
5526 }
5527
5528 if (gfc_match_eos () == MATCH_YES)
5529 {
5530 *st = ST_PUBLIC;
5531 return MATCH_YES;
5532 }
5533
5534 *st = ST_ATTR_DECL;
5535 return access_attr_decl (ST_PUBLIC);
5536}
5537
5538
5539/* Workhorse for gfc_match_parameter. */
5540
5541static match
5542do_parm (void)
5543{
5544 gfc_symbol *sym;
5545 gfc_expr *init;
5546 match m;
5547
5548 m = gfc_match_symbol (&sym, 0);
5549 if (m == MATCH_NO)
5550 gfc_error ("Expected variable name at %C in PARAMETER statement");
5551
5552 if (m != MATCH_YES)
5553 return m;
5554
5555 if (gfc_match_char ('=') == MATCH_NO)
5556 {
5557 gfc_error ("Expected = sign in PARAMETER statement at %C");
5558 return MATCH_ERROR;
5559 }
5560
5561 m = gfc_match_init_expr (&init);
5562 if (m == MATCH_NO)
5563 gfc_error ("Expected expression at %C in PARAMETER statement");
5564 if (m != MATCH_YES)
5565 return m;
5566
5567 if (sym->ts.type == BT_UNKNOWN
5568 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5569 {
5570 m = MATCH_ERROR;
5571 goto cleanup;
5572 }
5573
5574 if (gfc_check_assign_symbol (sym, init) == FAILURE
5575 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
5576 {
5577 m = MATCH_ERROR;
5578 goto cleanup;
5579 }
5580
5581 if (sym->ts.type == BT_CHARACTER
5582 && sym->ts.cl != NULL
5583 && sym->ts.cl->length != NULL
5584 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5585 && init->expr_type == EXPR_CONSTANT
5586 && init->ts.type == BT_CHARACTER
5587 && init->ts.kind == 1)
5588 gfc_set_constant_character_len (
5589 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
5590
5591 sym->value = init;
5592 return MATCH_YES;
5593
5594cleanup:
5595 gfc_free_expr (init);
5596 return m;
5597}
5598
5599
5600/* Match a parameter statement, with the weird syntax that these have. */
5601
5602match
5603gfc_match_parameter (void)
5604{
5605 match m;
5606
5607 if (gfc_match_char ('(') == MATCH_NO)
5608 return MATCH_NO;
5609
5610 for (;;)
5611 {
5612 m = do_parm ();
5613 if (m != MATCH_YES)
5614 break;
5615
5616 if (gfc_match (" )%t") == MATCH_YES)
5617 break;
5618
5619 if (gfc_match_char (',') != MATCH_YES)
5620 {
5621 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5622 m = MATCH_ERROR;
5623 break;
5624 }
5625 }
5626
5627 return m;
5628}
5629
5630
5631/* Save statements have a special syntax. */
5632
5633match
5634gfc_match_save (void)
5635{
5636 char n[GFC_MAX_SYMBOL_LEN+1];
5637 gfc_common_head *c;
5638 gfc_symbol *sym;
5639 match m;
5640
5641 if (gfc_match_eos () == MATCH_YES)
5642 {
5643 if (gfc_current_ns->seen_save)
5644 {
5645 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5646 "follows previous SAVE statement")
5647 == FAILURE)
5648 return MATCH_ERROR;
5649 }
5650
5651 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5652 return MATCH_YES;
5653 }
5654
5655 if (gfc_current_ns->save_all)
5656 {
5657 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5658 "blanket SAVE statement")
5659 == FAILURE)
5660 return MATCH_ERROR;
5661 }
5662
5663 gfc_match (" ::");
5664
5665 for (;;)
5666 {
5667 m = gfc_match_symbol (&sym, 0);
5668 switch (m)
5669 {
5670 case MATCH_YES:
5671 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
5672 == FAILURE)
5673 return MATCH_ERROR;
5674 goto next_item;
5675
5676 case MATCH_NO:
5677 break;
5678
5679 case MATCH_ERROR:
5680 return MATCH_ERROR;
5681 }
5682
5683 m = gfc_match (" / %n /", &n);
5684 if (m == MATCH_ERROR)
5685 return MATCH_ERROR;
5686 if (m == MATCH_NO)
5687 goto syntax;
5688
5689 c = gfc_get_common (n, 0);
5690 c->saved = 1;
5691
5692 gfc_current_ns->seen_save = 1;
5693
5694 next_item:
5695 if (gfc_match_eos () == MATCH_YES)
5696 break;
5697 if (gfc_match_char (',') != MATCH_YES)
5698 goto syntax;
5699 }
5700
5701 return MATCH_YES;
5702
5703syntax:
5704 gfc_error ("Syntax error in SAVE statement at %C");
5705 return MATCH_ERROR;
5706}
5707
5708
5709match
5710gfc_match_value (void)
5711{
5712 gfc_symbol *sym;
5713 match m;
5714
5715 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
5716 == FAILURE)
5717 return MATCH_ERROR;
5718
5719 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5720 {
5721 return MATCH_ERROR;
5722 }
5723
5724 if (gfc_match_eos () == MATCH_YES)
5725 goto syntax;
5726
5727 for(;;)
5728 {
5729 m = gfc_match_symbol (&sym, 0);
5730 switch (m)
5731 {
5732 case MATCH_YES:
5733 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
5734 == FAILURE)
5735 return MATCH_ERROR;
5736 goto next_item;
5737
5738 case MATCH_NO:
5739 break;
5740
5741 case MATCH_ERROR:
5742 return MATCH_ERROR;
5743 }
5744
5745 next_item:
5746 if (gfc_match_eos () == MATCH_YES)
5747 break;
5748 if (gfc_match_char (',') != MATCH_YES)
5749 goto syntax;
5750 }
5751
5752 return MATCH_YES;
5753
5754syntax:
5755 gfc_error ("Syntax error in VALUE statement at %C");
5756 return MATCH_ERROR;
5757}
5758
5759
5760match
5761gfc_match_volatile (void)
5762{
5763 gfc_symbol *sym;
5764 match m;
5765
5766 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
5767 == FAILURE)
5768 return MATCH_ERROR;
5769
5770 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5771 {
5772 return MATCH_ERROR;
5773 }
5774
5775 if (gfc_match_eos () == MATCH_YES)
5776 goto syntax;
5777
5778 for(;;)
5779 {
5780 /* VOLATILE is special because it can be added to host-associated
5781 symbols locally. */
5782 m = gfc_match_symbol (&sym, 1);
5783 switch (m)
5784 {
5785 case MATCH_YES:
5786 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
5787 == FAILURE)
5788 return MATCH_ERROR;
5789 goto next_item;
5790
5791 case MATCH_NO:
5792 break;
5793
5794 case MATCH_ERROR:
5795 return MATCH_ERROR;
5796 }
5797
5798 next_item:
5799 if (gfc_match_eos () == MATCH_YES)
5800 break;
5801 if (gfc_match_char (',') != MATCH_YES)
5802 goto syntax;
5803 }
5804
5805 return MATCH_YES;
5806
5807syntax:
5808 gfc_error ("Syntax error in VOLATILE statement at %C");
5809 return MATCH_ERROR;
5810}
5811
5812
5813/* Match a module procedure statement. Note that we have to modify
5814 symbols in the parent's namespace because the current one was there
5815 to receive symbols that are in an interface's formal argument list. */
5816
5817match
5818gfc_match_modproc (void)
5819{
5820 char name[GFC_MAX_SYMBOL_LEN + 1];
5821 gfc_symbol *sym;
5822 match m;
5823 gfc_namespace *module_ns;
5824
5825 if (gfc_state_stack->state != COMP_INTERFACE
5826 || gfc_state_stack->previous == NULL
5827 || current_interface.type == INTERFACE_NAMELESS
5828 || current_interface.type == INTERFACE_ABSTRACT)
5829 {
5830 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5831 "interface");
5832 return MATCH_ERROR;
5833 }
5834
5835 module_ns = gfc_current_ns->parent;
5836 for (; module_ns; module_ns = module_ns->parent)
5837 if (module_ns->proc_name->attr.flavor == FL_MODULE)
5838 break;
5839
5840 if (module_ns == NULL)
5841 return MATCH_ERROR;
5842
5843 for (;;)
5844 {
5845 m = gfc_match_name (name);
5846 if (m == MATCH_NO)
5847 goto syntax;
5848 if (m != MATCH_YES)
5849 return MATCH_ERROR;
5850
5851 if (gfc_get_symbol (name, module_ns, &sym))
5852 return MATCH_ERROR;
5853
5854 if (sym->attr.proc != PROC_MODULE
5855 && gfc_add_procedure (&sym->attr, PROC_MODULE,
5856 sym->name, NULL) == FAILURE)
5857 return MATCH_ERROR;
5858
5859 if (gfc_add_interface (sym) == FAILURE)
5860 return MATCH_ERROR;
5861
5862 sym->attr.mod_proc = 1;
5863
5864 if (gfc_match_eos () == MATCH_YES)
5865 break;
5866 if (gfc_match_char (',') != MATCH_YES)
5867 goto syntax;
5868 }
5869
5870 return MATCH_YES;
5871
5872syntax:
5873 gfc_syntax_error (ST_MODULE_PROC);
5874 return MATCH_ERROR;
5875}
5876
5877
5878/* Match the optional attribute specifiers for a type declaration.
5879 Return MATCH_ERROR if an error is encountered in one of the handled
5880 attributes (public, private, bind(c)), MATCH_NO if what's found is
5881 not a handled attribute, and MATCH_YES otherwise. TODO: More error
5882 checking on attribute conflicts needs to be done. */
5883
5884match
5885gfc_get_type_attr_spec (symbol_attribute *attr)
5886{
5887 /* See if the derived type is marked as private. */
5888 if (gfc_match (" , private") == MATCH_YES)
5889 {
5890 if (gfc_current_state () != COMP_MODULE)
5891 {
5892 gfc_error ("Derived type at %C can only be PRIVATE in the "
5893 "specification part of a module");
5894 return MATCH_ERROR;
5895 }
5896
5897 if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
5898 return MATCH_ERROR;
5899 }
5900 else if (gfc_match (" , public") == MATCH_YES)
5901 {
5902 if (gfc_current_state () != COMP_MODULE)
5903 {
5904 gfc_error ("Derived type at %C can only be PUBLIC in the "
5905 "specification part of a module");
5906 return MATCH_ERROR;
5907 }
5908
5909 if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
5910 return MATCH_ERROR;
5911 }
5912 else if (gfc_match(" , bind ( c )") == MATCH_YES)
5913 {
5914 /* If the type is defined to be bind(c) it then needs to make
5915 sure that all fields are interoperable. This will
5916 need to be a semantic check on the finished derived type.
5917 See 15.2.3 (lines 9-12) of F2003 draft. */
5918 if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
5919 return MATCH_ERROR;
5920
5921 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
5922 }
5923 else
5924 return MATCH_NO;
5925
5926 /* If we get here, something matched. */
5927 return MATCH_YES;
5928}
5929
5930
5931/* Match the beginning of a derived type declaration. If a type name
5932 was the result of a function, then it is possible to have a symbol
5933 already to be known as a derived type yet have no components. */
5934
5935match
5936gfc_match_derived_decl (void)
5937{
5938 char name[GFC_MAX_SYMBOL_LEN + 1];
5939 symbol_attribute attr;
5940 gfc_symbol *sym;
5941 match m;
5942 match is_type_attr_spec = MATCH_NO;
5943 bool seen_attr = false;
5944
5945 if (gfc_current_state () == COMP_DERIVED)
5946 return MATCH_NO;
5947
5948 gfc_clear_attr (&attr);
5949
5950 do
5951 {
5952 is_type_attr_spec = gfc_get_type_attr_spec (&attr);
5953 if (is_type_attr_spec == MATCH_ERROR)
5954 return MATCH_ERROR;
5955 if (is_type_attr_spec == MATCH_YES)
5956 seen_attr = true;
5957 } while (is_type_attr_spec == MATCH_YES);
5958
5959 if (gfc_match (" ::") != MATCH_YES && seen_attr)
5960 {
5961 gfc_error ("Expected :: in TYPE definition at %C");
5962 return MATCH_ERROR;
5963 }
5964
5965 m = gfc_match (" %n%t", name);
5966 if (m != MATCH_YES)
5967 return m;
5968
5969 /* Make sure the name is not the name of an intrinsic type. */
5970 if (gfc_is_intrinsic_typename (name))
5971 {
5972 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5973 "type", name);
5974 return MATCH_ERROR;
5975 }
5976
5977 if (gfc_get_symbol (name, NULL, &sym))
5978 return MATCH_ERROR;
5979
5980 if (sym->ts.type != BT_UNKNOWN)
5981 {
5982 gfc_error ("Derived type name '%s' at %C already has a basic type "
5983 "of %s", sym->name, gfc_typename (&sym->ts));
5984 return MATCH_ERROR;
5985 }
5986
5987 /* The symbol may already have the derived attribute without the
5988 components. The ways this can happen is via a function
5989 definition, an INTRINSIC statement or a subtype in another
5990 derived type that is a pointer. The first part of the AND clause
5991 is true if a the symbol is not the return value of a function. */
5992 if (sym->attr.flavor != FL_DERIVED
5993 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
5994 return MATCH_ERROR;
5995
5996 if (sym->components != NULL || sym->attr.zero_comp)
5997 {
5998 gfc_error ("Derived type definition of '%s' at %C has already been "
5999 "defined", sym->name);
6000 return MATCH_ERROR;
6001 }
6002
6003 if (attr.access != ACCESS_UNKNOWN
6004 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
6005 return MATCH_ERROR;
6006
6007 /* See if the derived type was labeled as bind(c). */
6008 if (attr.is_bind_c != 0)
6009 sym->attr.is_bind_c = attr.is_bind_c;
6010
6011 gfc_new_block = sym;
6012
6013 return MATCH_YES;
6014}
6015
6016
6017/* Cray Pointees can be declared as:
6018 pointer (ipt, a (n,m,...,*))
6019 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
6020 cheat and set a constant bound of 1 for the last dimension, if this
6021 is the case. Since there is no bounds-checking for Cray Pointees,
6022 this will be okay. */
6023
6024try
6025gfc_mod_pointee_as (gfc_array_spec *as)
6026{
6027 as->cray_pointee = true; /* This will be useful to know later. */
6028 if (as->type == AS_ASSUMED_SIZE)
6029 {
6030 as->type = AS_EXPLICIT;
6031 as->upper[as->rank - 1] = gfc_int_expr (1);
6032 as->cp_was_assumed = true;
6033 }
6034 else if (as->type == AS_ASSUMED_SHAPE)
6035 {
6036 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
6037 return MATCH_ERROR;
6038 }
6039 return MATCH_YES;
6040}
6041
6042
6043/* Match the enum definition statement, here we are trying to match
6044 the first line of enum definition statement.
6045 Returns MATCH_YES if match is found. */
6046
6047match
6048gfc_match_enum (void)
6049{
6050 match m;
6051
6052 m = gfc_match_eos ();
6053 if (m != MATCH_YES)
6054 return m;
6055
6056 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
6057 == FAILURE)
6058 return MATCH_ERROR;
6059
6060 return MATCH_YES;
6061}
6062
6063
6064/* Match a variable name with an optional initializer. When this
6065 subroutine is called, a variable is expected to be parsed next.
6066 Depending on what is happening at the moment, updates either the
6067 symbol table or the current interface. */
6068
6069static match
6070enumerator_decl (void)
6071{
6072 char name[GFC_MAX_SYMBOL_LEN + 1];
6073 gfc_expr *initializer;
6074 gfc_array_spec *as = NULL;
6075 gfc_symbol *sym;
6076 locus var_locus;
6077 match m;
6078 try t;
6079 locus old_locus;
6080
6081 initializer = NULL;
6082 old_locus = gfc_current_locus;
6083
6084 /* When we get here, we've just matched a list of attributes and
6085 maybe a type and a double colon. The next thing we expect to see
6086 is the name of the symbol. */
6087 m = gfc_match_name (name);
6088 if (m != MATCH_YES)
6089 goto cleanup;
6090
6091 var_locus = gfc_current_locus;
6092
6093 /* OK, we've successfully matched the declaration. Now put the
6094 symbol in the current namespace. If we fail to create the symbol,
6095 bail out. */
6096 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
6097 {
6098 m = MATCH_ERROR;
6099 goto cleanup;
6100 }
6101
6102 /* The double colon must be present in order to have initializers.
6103 Otherwise the statement is ambiguous with an assignment statement. */
6104 if (colon_seen)
6105 {
6106 if (gfc_match_char ('=') == MATCH_YES)
6107 {
6108 m = gfc_match_init_expr (&initializer);
6109 if (m == MATCH_NO)
6110 {
6111 gfc_error ("Expected an initialization expression at %C");
6112 m = MATCH_ERROR;
6113 }
6114
6115 if (m != MATCH_YES)
6116 goto cleanup;
6117 }
6118 }
6119
6120 /* If we do not have an initializer, the initialization value of the
6121 previous enumerator (stored in last_initializer) is incremented
6122 by 1 and is used to initialize the current enumerator. */
6123 if (initializer == NULL)
6124 initializer = gfc_enum_initializer (last_initializer, old_locus);
6125
6126 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
6127 {
6128 gfc_error("ENUMERATOR %L not initialized with integer expression",
6129 &var_locus);
6130 m = MATCH_ERROR;
6131 gfc_free_enum_history ();
6132 goto cleanup;
6133 }
6134
6135 /* Store this current initializer, for the next enumerator variable
6136 to be parsed. add_init_expr_to_sym() zeros initializer, so we
6137 use last_initializer below. */
6138 last_initializer = initializer;
6139 t = add_init_expr_to_sym (name, &initializer, &var_locus);
6140
6141 /* Maintain enumerator history. */
6142 gfc_find_symbol (name, NULL, 0, &sym);
6143 create_enum_history (sym, last_initializer);
6144
6145 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
6146
6147cleanup:
6148 /* Free stuff up and return. */
6149 gfc_free_expr (initializer);
6150
6151 return m;
6152}
6153
6154
6155/* Match the enumerator definition statement. */
6156
6157match
6158gfc_match_enumerator_def (void)
6159{
6160 match m;
6161 try t;
6162
6163 gfc_clear_ts (&current_ts);
6164
6165 m = gfc_match (" enumerator");
6166 if (m != MATCH_YES)
6167 return m;
6168
6169 m = gfc_match (" :: ");
6170 if (m == MATCH_ERROR)
6171 return m;
6172
6173 colon_seen = (m == MATCH_YES);
6174
6175 if (gfc_current_state () != COMP_ENUM)
6176 {
6177 gfc_error ("ENUM definition statement expected before %C");
6178 gfc_free_enum_history ();
6179 return MATCH_ERROR;
6180 }
6181
6182 (&current_ts)->type = BT_INTEGER;
6183 (&current_ts)->kind = gfc_c_int_kind;
6184
6185 gfc_clear_attr (&current_attr);
6186 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
6187 if (t == FAILURE)
6188 {
6189 m = MATCH_ERROR;
6190 goto cleanup;
6191 }
6192
6193 for (;;)
6194 {
6195 m = enumerator_decl ();
6196 if (m == MATCH_ERROR)
6197 goto cleanup;
6198 if (m == MATCH_NO)
6199 break;
6200
6201 if (gfc_match_eos () == MATCH_YES)
6202 goto cleanup;
6203 if (gfc_match_char (',') != MATCH_YES)
6204 break;
6205 }
6206
6207 if (gfc_current_state () == COMP_ENUM)
6208 {
6209 gfc_free_enum_history ();
6210 gfc_error ("Syntax error in ENUMERATOR definition at %C");
6211 m = MATCH_ERROR;
6212 }
6213
6214cleanup:
6215 gfc_free_array_spec (current_as);
6216 current_as = NULL;
6217 return m;
6218
6219}
6220
GNU Compiler Collection
This page took 0.070911 seconds and 5 git commands to generate.