1 /* Declaration statement matcher
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
58 /* The current binding label (if any). */
59 static const char* curr_binding_label
;
60 /* Need to know how many identifiers are on the current data declaration
61 line in case we're given the BIND(C) attribute with a NAME= specifier. */
62 static int num_idents_on_line
;
63 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
64 can supply a name if the curr_binding_label is nil and NAME= was not. */
65 static int has_name_equals
= 0;
67 /* Initializer of the previous enumerator. */
69 static gfc_expr
*last_initializer
;
71 /* History of all the enumerators is maintained, so that
72 kind values of all the enumerators could be updated depending
73 upon the maximum initialized value. */
75 typedef struct enumerator_history
78 gfc_expr
*initializer
;
79 struct enumerator_history
*next
;
83 /* Header of enum history chain. */
85 static enumerator_history
*enum_history
= NULL
;
87 /* Pointer of enum history node containing largest initializer. */
89 static enumerator_history
*max_enum
= NULL
;
91 /* gfc_new_block points to the symbol of a newly matched block. */
93 gfc_symbol
*gfc_new_block
;
95 bool gfc_matching_function
;
98 /********************* DATA statement subroutines *********************/
100 static bool in_match_data
= false;
103 gfc_in_match_data (void)
105 return in_match_data
;
109 set_in_match_data (bool set_value
)
111 in_match_data
= set_value
;
114 /* Free a gfc_data_variable structure and everything beneath it. */
117 free_variable (gfc_data_variable
*p
)
119 gfc_data_variable
*q
;
124 gfc_free_expr (p
->expr
);
125 gfc_free_iterator (&p
->iter
, 0);
126 free_variable (p
->list
);
132 /* Free a gfc_data_value structure and everything beneath it. */
135 free_value (gfc_data_value
*p
)
142 mpz_clear (p
->repeat
);
143 gfc_free_expr (p
->expr
);
149 /* Free a list of gfc_data structures. */
152 gfc_free_data (gfc_data
*p
)
159 free_variable (p
->var
);
160 free_value (p
->value
);
166 /* Free all data in a namespace. */
169 gfc_free_data_all (gfc_namespace
*ns
)
181 /* Reject data parsed since the last restore point was marked. */
184 gfc_reject_data (gfc_namespace
*ns
)
188 while (ns
->data
&& ns
->data
!= ns
->old_data
)
196 static match
var_element (gfc_data_variable
*);
198 /* Match a list of variables terminated by an iterator and a right
202 var_list (gfc_data_variable
*parent
)
204 gfc_data_variable
*tail
, var
;
207 m
= var_element (&var
);
208 if (m
== MATCH_ERROR
)
213 tail
= gfc_get_data_variable ();
220 if (gfc_match_char (',') != MATCH_YES
)
223 m
= gfc_match_iterator (&parent
->iter
, 1);
226 if (m
== MATCH_ERROR
)
229 m
= var_element (&var
);
230 if (m
== MATCH_ERROR
)
235 tail
->next
= gfc_get_data_variable ();
241 if (gfc_match_char (')') != MATCH_YES
)
246 gfc_syntax_error (ST_DATA
);
251 /* Match a single element in a data variable list, which can be a
252 variable-iterator list. */
255 var_element (gfc_data_variable
*new_var
)
260 memset (new_var
, 0, sizeof (gfc_data_variable
));
262 if (gfc_match_char ('(') == MATCH_YES
)
263 return var_list (new_var
);
265 m
= gfc_match_variable (&new_var
->expr
, 0);
269 sym
= new_var
->expr
->symtree
->n
.sym
;
271 /* Symbol should already have an associated type. */
272 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
275 if (!sym
->attr
.function
&& gfc_current_ns
->parent
276 && gfc_current_ns
->parent
== sym
->ns
)
278 gfc_error ("Host associated variable %qs may not be in the DATA "
279 "statement at %C", sym
->name
);
283 if (gfc_current_state () != COMP_BLOCK_DATA
284 && sym
->attr
.in_common
285 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
286 "common block variable %qs in DATA statement at %C",
290 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
297 /* Match the top-level list of data variables. */
300 top_var_list (gfc_data
*d
)
302 gfc_data_variable var
, *tail
, *new_var
;
309 m
= var_element (&var
);
312 if (m
== MATCH_ERROR
)
315 new_var
= gfc_get_data_variable ();
321 tail
->next
= new_var
;
325 if (gfc_match_char ('/') == MATCH_YES
)
327 if (gfc_match_char (',') != MATCH_YES
)
334 gfc_syntax_error (ST_DATA
);
335 gfc_free_data_all (gfc_current_ns
);
341 match_data_constant (gfc_expr
**result
)
343 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
344 gfc_symbol
*sym
, *dt_sym
= NULL
;
349 m
= gfc_match_literal_constant (&expr
, 1);
356 if (m
== MATCH_ERROR
)
359 m
= gfc_match_null (result
);
363 old_loc
= gfc_current_locus
;
365 /* Should this be a structure component, try to match it
366 before matching a name. */
367 m
= gfc_match_rvalue (result
);
368 if (m
== MATCH_ERROR
)
371 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
373 if (!gfc_simplify_expr (*result
, 0))
377 else if (m
== MATCH_YES
)
378 gfc_free_expr (*result
);
380 gfc_current_locus
= old_loc
;
382 m
= gfc_match_name (name
);
386 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
389 if (sym
&& sym
->attr
.generic
)
390 dt_sym
= gfc_find_dt_in_generic (sym
);
393 || (sym
->attr
.flavor
!= FL_PARAMETER
394 && (!dt_sym
|| dt_sym
->attr
.flavor
!= FL_DERIVED
)))
396 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
400 else if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
)
401 return gfc_match_structure_constructor (dt_sym
, result
);
403 /* Check to see if the value is an initialization array expression. */
404 if (sym
->value
->expr_type
== EXPR_ARRAY
)
406 gfc_current_locus
= old_loc
;
408 m
= gfc_match_init_expr (result
);
409 if (m
== MATCH_ERROR
)
414 if (!gfc_simplify_expr (*result
, 0))
417 if ((*result
)->expr_type
== EXPR_CONSTANT
)
421 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
427 *result
= gfc_copy_expr (sym
->value
);
432 /* Match a list of values in a DATA statement. The leading '/' has
433 already been seen at this point. */
436 top_val_list (gfc_data
*data
)
438 gfc_data_value
*new_val
, *tail
;
446 m
= match_data_constant (&expr
);
449 if (m
== MATCH_ERROR
)
452 new_val
= gfc_get_data_value ();
453 mpz_init (new_val
->repeat
);
456 data
->value
= new_val
;
458 tail
->next
= new_val
;
462 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
465 mpz_set_ui (tail
->repeat
, 1);
469 mpz_set (tail
->repeat
, expr
->value
.integer
);
470 gfc_free_expr (expr
);
472 m
= match_data_constant (&tail
->expr
);
475 if (m
== MATCH_ERROR
)
479 if (gfc_match_char ('/') == MATCH_YES
)
481 if (gfc_match_char (',') == MATCH_NO
)
488 gfc_syntax_error (ST_DATA
);
489 gfc_free_data_all (gfc_current_ns
);
494 /* Matches an old style initialization. */
497 match_old_style_init (const char *name
)
504 /* Set up data structure to hold initializers. */
505 gfc_find_sym_tree (name
, NULL
, 0, &st
);
508 newdata
= gfc_get_data ();
509 newdata
->var
= gfc_get_data_variable ();
510 newdata
->var
->expr
= gfc_get_variable_expr (st
);
511 newdata
->where
= gfc_current_locus
;
513 /* Match initial value list. This also eats the terminal '/'. */
514 m
= top_val_list (newdata
);
523 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
527 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
529 /* Mark the variable as having appeared in a data statement. */
530 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
536 /* Chain in namespace list of DATA initializers. */
537 newdata
->next
= gfc_current_ns
->data
;
538 gfc_current_ns
->data
= newdata
;
544 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
545 we are matching a DATA statement and are therefore issuing an error
546 if we encounter something unexpected, if not, we're trying to match
547 an old-style initialization expression of the form INTEGER I /2/. */
550 gfc_match_data (void)
555 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
556 if ((gfc_current_state () == COMP_FUNCTION
557 || gfc_current_state () == COMP_SUBROUTINE
)
558 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
560 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
564 set_in_match_data (true);
568 new_data
= gfc_get_data ();
569 new_data
->where
= gfc_current_locus
;
571 m
= top_var_list (new_data
);
575 m
= top_val_list (new_data
);
579 new_data
->next
= gfc_current_ns
->data
;
580 gfc_current_ns
->data
= new_data
;
582 if (gfc_match_eos () == MATCH_YES
)
585 gfc_match_char (','); /* Optional comma */
588 set_in_match_data (false);
592 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
595 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
600 set_in_match_data (false);
601 gfc_free_data (new_data
);
606 /************************ Declaration statements *********************/
609 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
612 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
616 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
617 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
619 gfc_error ("The assumed-rank array at %C shall not have a codimension");
623 if (to
->rank
== 0 && from
->rank
> 0)
625 to
->rank
= from
->rank
;
626 to
->type
= from
->type
;
627 to
->cray_pointee
= from
->cray_pointee
;
628 to
->cp_was_assumed
= from
->cp_was_assumed
;
630 for (i
= 0; i
< to
->corank
; i
++)
632 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
633 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
635 for (i
= 0; i
< from
->rank
; i
++)
639 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
640 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
644 to
->lower
[i
] = from
->lower
[i
];
645 to
->upper
[i
] = from
->upper
[i
];
649 else if (to
->corank
== 0 && from
->corank
> 0)
651 to
->corank
= from
->corank
;
652 to
->cotype
= from
->cotype
;
654 for (i
= 0; i
< from
->corank
; i
++)
658 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
659 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
663 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
664 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
673 /* Match an intent specification. Since this can only happen after an
674 INTENT word, a legal intent-spec must follow. */
677 match_intent_spec (void)
680 if (gfc_match (" ( in out )") == MATCH_YES
)
682 if (gfc_match (" ( in )") == MATCH_YES
)
684 if (gfc_match (" ( out )") == MATCH_YES
)
687 gfc_error ("Bad INTENT specification at %C");
688 return INTENT_UNKNOWN
;
692 /* Matches a character length specification, which is either a
693 specification expression, '*', or ':'. */
696 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
703 if (gfc_match_char ('*') == MATCH_YES
)
706 if (gfc_match_char (':') == MATCH_YES
)
708 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
716 m
= gfc_match_expr (expr
);
718 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
721 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
724 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
726 if ((*expr
)->ts
.type
== BT_INTEGER
727 || ((*expr
)->ts
.type
== BT_UNKNOWN
728 && strcmp((*expr
)->symtree
->name
, "null") != 0))
733 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
735 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
736 processor dependent and its value is greater than or equal to zero.
737 F2008, 4.4.3.2: If the character length parameter value evaluates
738 to a negative value, the length of character entities declared
741 if ((*expr
)->ts
.type
== BT_INTEGER
)
743 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
744 mpz_set_si ((*expr
)->value
.integer
, 0);
749 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
751 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
755 e
= gfc_copy_expr (*expr
);
757 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
758 which causes an ICE if gfc_reduce_init_expr() is called. */
759 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
760 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
761 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
764 gfc_reduce_init_expr (e
);
766 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
767 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
768 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
780 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
785 /* A character length is a '*' followed by a literal integer or a
786 char_len_param_value in parenthesis. */
789 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
795 m
= gfc_match_char ('*');
799 m
= gfc_match_small_literal_int (&length
, NULL
);
800 if (m
== MATCH_ERROR
)
805 if (obsolescent_check
806 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
808 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
812 if (gfc_match_char ('(') == MATCH_NO
)
815 m
= char_len_param_value (expr
, deferred
);
816 if (m
!= MATCH_YES
&& gfc_matching_function
)
822 if (m
== MATCH_ERROR
)
827 if (gfc_match_char (')') == MATCH_NO
)
829 gfc_free_expr (*expr
);
837 gfc_error ("Syntax error in character length specification at %C");
842 /* Special subroutine for finding a symbol. Check if the name is found
843 in the current name space. If not, and we're compiling a function or
844 subroutine and the parent compilation unit is an interface, then check
845 to see if the name we've been given is the name of the interface
846 (located in another namespace). */
849 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
855 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
858 *result
= st
? st
->n
.sym
: NULL
;
862 if (gfc_current_state () != COMP_SUBROUTINE
863 && gfc_current_state () != COMP_FUNCTION
)
866 s
= gfc_state_stack
->previous
;
870 if (s
->state
!= COMP_INTERFACE
)
873 goto end
; /* Nameless interface. */
875 if (strcmp (name
, s
->sym
->name
) == 0)
886 /* Special subroutine for getting a symbol node associated with a
887 procedure name, used in SUBROUTINE and FUNCTION statements. The
888 symbol is created in the parent using with symtree node in the
889 child unit pointing to the symbol. If the current namespace has no
890 parent, then the symbol is just created in the current unit. */
893 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
899 /* Module functions have to be left in their own namespace because
900 they have potentially (almost certainly!) already been referenced.
901 In this sense, they are rather like external functions. This is
902 fixed up in resolve.c(resolve_entries), where the symbol name-
903 space is set to point to the master function, so that the fake
904 result mechanism can work. */
905 if (module_fcn_entry
)
907 /* Present if entry is declared to be a module procedure. */
908 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
911 rc
= gfc_get_symbol (name
, NULL
, result
);
912 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
913 && (*result
)->ts
.type
== BT_UNKNOWN
914 && sym
->attr
.flavor
== FL_UNKNOWN
)
915 /* Pick up the typespec for the entry, if declared in the function
916 body. Note that this symbol is FL_UNKNOWN because it will
917 only have appeared in a type declaration. The local symtree
918 is set to point to the module symbol and a unique symtree
919 to the local version. This latter ensures a correct clearing
922 /* If the ENTRY proceeds its specification, we need to ensure
923 that this does not raise a "has no IMPLICIT type" error. */
924 if (sym
->ts
.type
== BT_UNKNOWN
)
925 sym
->attr
.untyped
= 1;
927 (*result
)->ts
= sym
->ts
;
929 /* Put the symbol in the procedure namespace so that, should
930 the ENTRY precede its specification, the specification
932 (*result
)->ns
= gfc_current_ns
;
934 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
936 st
= gfc_get_unique_symtree (gfc_current_ns
);
942 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
948 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
951 if (sym
->attr
.module_procedure
952 && sym
->attr
.if_source
== IFSRC_IFBODY
)
954 /* Create a partially populated interface symbol to carry the
955 characteristics of the procedure and the result. */
956 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
957 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
959 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
960 if (sym
->attr
.dimension
)
961 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
963 /* Ideally, at this point, a copy would be made of the formal
964 arguments and their namespace. However, this does not appear
965 to be necessary, albeit at the expense of not being able to
966 use gfc_compare_interfaces directly. */
968 if (sym
->result
&& sym
->result
!= sym
)
970 sym
->ts
.interface
->result
= sym
->result
;
973 else if (sym
->result
)
975 sym
->ts
.interface
->result
= sym
->ts
.interface
;
978 else if (sym
&& !sym
->gfc_new
979 && gfc_current_state () != COMP_INTERFACE
)
981 /* Trap another encompassed procedure with the same name. All
982 these conditions are necessary to avoid picking up an entry
983 whose name clashes with that of the encompassing procedure;
984 this is handled using gsymbols to register unique, globally
986 if (sym
->attr
.flavor
!= 0
987 && sym
->attr
.proc
!= 0
988 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
989 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
990 gfc_error_now ("Procedure %qs at %C is already defined at %L",
991 name
, &sym
->declared_at
);
993 /* Trap a procedure with a name the same as interface in the
994 encompassing scope. */
995 if (sym
->attr
.generic
!= 0
996 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
997 && !sym
->attr
.mod_proc
)
998 gfc_error_now ("Name %qs at %C is already defined"
999 " as a generic interface at %L",
1000 name
, &sym
->declared_at
);
1002 /* Trap declarations of attributes in encompassing scope. The
1003 signature for this is that ts.kind is set. Legitimate
1004 references only set ts.type. */
1005 if (sym
->ts
.kind
!= 0
1006 && !sym
->attr
.implicit_type
1007 && sym
->attr
.proc
== 0
1008 && gfc_current_ns
->parent
!= NULL
1009 && sym
->attr
.access
== 0
1010 && !module_fcn_entry
)
1011 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1012 "and must not have attributes declared at %L",
1013 name
, &sym
->declared_at
);
1016 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1019 /* Module function entries will already have a symtree in
1020 the current namespace but will need one at module level. */
1021 if (module_fcn_entry
)
1023 /* Present if entry is declared to be a module procedure. */
1024 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1026 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1029 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1034 /* See if the procedure should be a module procedure. */
1036 if (((sym
->ns
->proc_name
!= NULL
1037 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1038 && sym
->attr
.proc
!= PROC_MODULE
)
1039 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1040 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1047 /* Verify that the given symbol representing a parameter is C
1048 interoperable, by checking to see if it was marked as such after
1049 its declaration. If the given symbol is not interoperable, a
1050 warning is reported, thus removing the need to return the status to
1051 the calling function. The standard does not require the user use
1052 one of the iso_c_binding named constants to declare an
1053 interoperable parameter, but we can't be sure if the param is C
1054 interop or not if the user doesn't. For example, integer(4) may be
1055 legal Fortran, but doesn't have meaning in C. It may interop with
1056 a number of the C types, which causes a problem because the
1057 compiler can't know which one. This code is almost certainly not
1058 portable, and the user will get what they deserve if the C type
1059 across platforms isn't always interoperable with integer(4). If
1060 the user had used something like integer(c_int) or integer(c_long),
1061 the compiler could have automatically handled the varying sizes
1062 across platforms. */
1065 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1067 int is_c_interop
= 0;
1070 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1071 Don't repeat the checks here. */
1072 if (sym
->attr
.implicit_type
)
1075 /* For subroutines or functions that are passed to a BIND(C) procedure,
1076 they're interoperable if they're BIND(C) and their params are all
1078 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1080 if (sym
->attr
.is_bind_c
== 0)
1082 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1083 "attribute to be C interoperable", sym
->name
,
1084 &(sym
->declared_at
));
1089 if (sym
->attr
.is_c_interop
== 1)
1090 /* We've already checked this procedure; don't check it again. */
1093 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1098 /* See if we've stored a reference to a procedure that owns sym. */
1099 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1101 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1103 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1105 if (is_c_interop
!= 1)
1107 /* Make personalized messages to give better feedback. */
1108 if (sym
->ts
.type
== BT_DERIVED
)
1109 gfc_error ("Variable %qs at %L is a dummy argument to the "
1110 "BIND(C) procedure %qs but is not C interoperable "
1111 "because derived type %qs is not C interoperable",
1112 sym
->name
, &(sym
->declared_at
),
1113 sym
->ns
->proc_name
->name
,
1114 sym
->ts
.u
.derived
->name
);
1115 else if (sym
->ts
.type
== BT_CLASS
)
1116 gfc_error ("Variable %qs at %L is a dummy argument to the "
1117 "BIND(C) procedure %qs but is not C interoperable "
1118 "because it is polymorphic",
1119 sym
->name
, &(sym
->declared_at
),
1120 sym
->ns
->proc_name
->name
);
1121 else if (warn_c_binding_type
)
1122 gfc_warning (OPT_Wc_binding_type
,
1123 "Variable %qs at %L is a dummy argument of the "
1124 "BIND(C) procedure %qs but may not be C "
1126 sym
->name
, &(sym
->declared_at
),
1127 sym
->ns
->proc_name
->name
);
1130 /* Character strings are only C interoperable if they have a
1132 if (sym
->ts
.type
== BT_CHARACTER
)
1134 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1135 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1136 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1138 gfc_error ("Character argument %qs at %L "
1139 "must be length 1 because "
1140 "procedure %qs is BIND(C)",
1141 sym
->name
, &sym
->declared_at
,
1142 sym
->ns
->proc_name
->name
);
1147 /* We have to make sure that any param to a bind(c) routine does
1148 not have the allocatable, pointer, or optional attributes,
1149 according to J3/04-007, section 5.1. */
1150 if (sym
->attr
.allocatable
== 1
1151 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1152 "ALLOCATABLE attribute in procedure %qs "
1153 "with BIND(C)", sym
->name
,
1154 &(sym
->declared_at
),
1155 sym
->ns
->proc_name
->name
))
1158 if (sym
->attr
.pointer
== 1
1159 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1160 "POINTER attribute in procedure %qs "
1161 "with BIND(C)", sym
->name
,
1162 &(sym
->declared_at
),
1163 sym
->ns
->proc_name
->name
))
1166 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1168 gfc_error ("Scalar variable %qs at %L with POINTER or "
1169 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1170 " supported", sym
->name
, &(sym
->declared_at
),
1171 sym
->ns
->proc_name
->name
);
1175 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1177 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1178 "and the VALUE attribute because procedure %qs "
1179 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1180 sym
->ns
->proc_name
->name
);
1183 else if (sym
->attr
.optional
== 1
1184 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1185 "at %L with OPTIONAL attribute in "
1186 "procedure %qs which is BIND(C)",
1187 sym
->name
, &(sym
->declared_at
),
1188 sym
->ns
->proc_name
->name
))
1191 /* Make sure that if it has the dimension attribute, that it is
1192 either assumed size or explicit shape. Deferred shape is already
1193 covered by the pointer/allocatable attribute. */
1194 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1195 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1196 "at %L as dummy argument to the BIND(C) "
1197 "procedure %qs at %L", sym
->name
,
1198 &(sym
->declared_at
),
1199 sym
->ns
->proc_name
->name
,
1200 &(sym
->ns
->proc_name
->declared_at
)))
1210 /* Function called by variable_decl() that adds a name to the symbol table. */
1213 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1214 gfc_array_spec
**as
, locus
*var_locus
)
1216 symbol_attribute attr
;
1219 if (gfc_get_symbol (name
, NULL
, &sym
))
1222 /* Start updating the symbol table. Add basic type attribute if present. */
1223 if (current_ts
.type
!= BT_UNKNOWN
1224 && (sym
->attr
.implicit_type
== 0
1225 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1226 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1229 if (sym
->ts
.type
== BT_CHARACTER
)
1232 sym
->ts
.deferred
= cl_deferred
;
1235 /* Add dimension attribute if present. */
1236 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1240 /* Add attribute to symbol. The copy is so that we can reset the
1241 dimension attribute. */
1242 attr
= current_attr
;
1244 attr
.codimension
= 0;
1246 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1249 /* Finish any work that may need to be done for the binding label,
1250 if it's a bind(c). The bind(c) attr is found before the symbol
1251 is made, and before the symbol name (for data decls), so the
1252 current_ts is holding the binding label, or nothing if the
1253 name= attr wasn't given. Therefore, test here if we're dealing
1254 with a bind(c) and make sure the binding label is set correctly. */
1255 if (sym
->attr
.is_bind_c
== 1)
1257 if (!sym
->binding_label
)
1259 /* Set the binding label and verify that if a NAME= was specified
1260 then only one identifier was in the entity-decl-list. */
1261 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1262 num_idents_on_line
))
1267 /* See if we know we're in a common block, and if it's a bind(c)
1268 common then we need to make sure we're an interoperable type. */
1269 if (sym
->attr
.in_common
== 1)
1271 /* Test the common block object. */
1272 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1273 && sym
->ts
.is_c_interop
!= 1)
1275 gfc_error_now ("Variable %qs in common block %qs at %C "
1276 "must be declared with a C interoperable "
1277 "kind since common block %qs is BIND(C)",
1278 sym
->name
, sym
->common_block
->name
,
1279 sym
->common_block
->name
);
1284 sym
->attr
.implied_index
= 0;
1286 if (sym
->ts
.type
== BT_CLASS
)
1287 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1293 /* Set character constant to the given length. The constant will be padded or
1294 truncated. If we're inside an array constructor without a typespec, we
1295 additionally check that all elements have the same length; check_len -1
1296 means no checking. */
1299 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1304 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1306 if (expr
->ts
.type
!= BT_CHARACTER
)
1309 slen
= expr
->value
.character
.length
;
1312 s
= gfc_get_wide_string (len
+ 1);
1313 memcpy (s
, expr
->value
.character
.string
,
1314 MIN (len
, slen
) * sizeof (gfc_char_t
));
1316 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1318 if (warn_character_truncation
&& slen
> len
)
1319 gfc_warning_now (OPT_Wcharacter_truncation
,
1320 "CHARACTER expression at %L is being truncated "
1321 "(%d/%d)", &expr
->where
, slen
, len
);
1323 /* Apply the standard by 'hand' otherwise it gets cleared for
1325 if (check_len
!= -1 && slen
!= check_len
1326 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1327 gfc_error_now ("The CHARACTER elements of the array constructor "
1328 "at %L must have the same length (%d/%d)",
1329 &expr
->where
, slen
, check_len
);
1332 free (expr
->value
.character
.string
);
1333 expr
->value
.character
.string
= s
;
1334 expr
->value
.character
.length
= len
;
1339 /* Function to create and update the enumerator history
1340 using the information passed as arguments.
1341 Pointer "max_enum" is also updated, to point to
1342 enum history node containing largest initializer.
1344 SYM points to the symbol node of enumerator.
1345 INIT points to its enumerator value. */
1348 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1350 enumerator_history
*new_enum_history
;
1351 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1353 new_enum_history
= XCNEW (enumerator_history
);
1355 new_enum_history
->sym
= sym
;
1356 new_enum_history
->initializer
= init
;
1357 new_enum_history
->next
= NULL
;
1359 if (enum_history
== NULL
)
1361 enum_history
= new_enum_history
;
1362 max_enum
= enum_history
;
1366 new_enum_history
->next
= enum_history
;
1367 enum_history
= new_enum_history
;
1369 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1370 new_enum_history
->initializer
->value
.integer
) < 0)
1371 max_enum
= new_enum_history
;
1376 /* Function to free enum kind history. */
1379 gfc_free_enum_history (void)
1381 enumerator_history
*current
= enum_history
;
1382 enumerator_history
*next
;
1384 while (current
!= NULL
)
1386 next
= current
->next
;
1391 enum_history
= NULL
;
1395 /* Function called by variable_decl() that adds an initialization
1396 expression to a symbol. */
1399 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1401 symbol_attribute attr
;
1406 if (find_special (name
, &sym
, false))
1411 /* If this symbol is confirming an implicit parameter type,
1412 then an initialization expression is not allowed. */
1413 if (attr
.flavor
== FL_PARAMETER
1414 && sym
->value
!= NULL
1417 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1424 /* An initializer is required for PARAMETER declarations. */
1425 if (attr
.flavor
== FL_PARAMETER
)
1427 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1433 /* If a variable appears in a DATA block, it cannot have an
1437 gfc_error ("Variable %qs at %C with an initializer already "
1438 "appears in a DATA statement", sym
->name
);
1442 /* Check if the assignment can happen. This has to be put off
1443 until later for derived type variables and procedure pointers. */
1444 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1445 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1446 && !sym
->attr
.proc_pointer
1447 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1450 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1451 && init
->ts
.type
== BT_CHARACTER
)
1453 /* Update symbol character length according initializer. */
1454 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1457 if (sym
->ts
.u
.cl
->length
== NULL
)
1460 /* If there are multiple CHARACTER variables declared on the
1461 same line, we don't want them to share the same length. */
1462 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1464 if (sym
->attr
.flavor
== FL_PARAMETER
)
1466 if (init
->expr_type
== EXPR_CONSTANT
)
1468 clen
= init
->value
.character
.length
;
1469 sym
->ts
.u
.cl
->length
1470 = gfc_get_int_expr (gfc_default_integer_kind
,
1473 else if (init
->expr_type
== EXPR_ARRAY
)
1476 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1477 else if (init
->value
.constructor
)
1480 c
= gfc_constructor_first (init
->value
.constructor
);
1481 clen
= c
->expr
->value
.character
.length
;
1485 sym
->ts
.u
.cl
->length
1486 = gfc_get_int_expr (gfc_default_integer_kind
,
1489 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1490 sym
->ts
.u
.cl
->length
=
1491 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1494 /* Update initializer character length according symbol. */
1495 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1499 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1502 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1504 if (init
->expr_type
== EXPR_CONSTANT
)
1505 gfc_set_constant_character_len (len
, init
, -1);
1506 else if (init
->expr_type
== EXPR_ARRAY
)
1510 /* Build a new charlen to prevent simplification from
1511 deleting the length before it is resolved. */
1512 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1513 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1515 for (c
= gfc_constructor_first (init
->value
.constructor
);
1516 c
; c
= gfc_constructor_next (c
))
1517 gfc_set_constant_character_len (len
, c
->expr
, -1);
1522 /* If sym is implied-shape, set its upper bounds from init. */
1523 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1524 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1528 if (init
->rank
== 0)
1530 gfc_error ("Can't initialize implied-shape array at %L"
1531 " with scalar", &sym
->declared_at
);
1535 /* Shape should be present, we get an initialization expression. */
1536 gcc_assert (init
->shape
);
1538 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1541 gfc_expr
*e
, *lower
;
1543 lower
= sym
->as
->lower
[dim
];
1545 /* If the lower bound is an array element from another
1546 parameterized array, then it is marked with EXPR_VARIABLE and
1547 is an initialization expression. Try to reduce it. */
1548 if (lower
->expr_type
== EXPR_VARIABLE
)
1549 gfc_reduce_init_expr (lower
);
1551 if (lower
->expr_type
== EXPR_CONSTANT
)
1553 /* All dimensions must be without upper bound. */
1554 gcc_assert (!sym
->as
->upper
[dim
]);
1557 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1558 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1560 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1561 sym
->as
->upper
[dim
] = e
;
1565 gfc_error ("Non-constant lower bound in implied-shape"
1566 " declaration at %L", &lower
->where
);
1571 sym
->as
->type
= AS_EXPLICIT
;
1574 /* Need to check if the expression we initialized this
1575 to was one of the iso_c_binding named constants. If so,
1576 and we're a parameter (constant), let it be iso_c.
1578 integer(c_int), parameter :: my_int = c_int
1579 integer(my_int) :: my_int_2
1580 If we mark my_int as iso_c (since we can see it's value
1581 is equal to one of the named constants), then my_int_2
1582 will be considered C interoperable. */
1583 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1585 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1586 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1587 /* attr bits needed for module files. */
1588 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1589 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1590 if (init
->ts
.is_iso_c
)
1591 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1594 /* Add initializer. Make sure we keep the ranks sane. */
1595 if (sym
->attr
.dimension
&& init
->rank
== 0)
1600 if (sym
->attr
.flavor
== FL_PARAMETER
1601 && init
->expr_type
== EXPR_CONSTANT
1602 && spec_size (sym
->as
, &size
)
1603 && mpz_cmp_si (size
, 0) > 0)
1605 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1607 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1608 gfc_constructor_append_expr (&array
->value
.constructor
,
1611 : gfc_copy_expr (init
),
1614 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1615 for (n
= 0; n
< sym
->as
->rank
; n
++)
1616 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1621 init
->rank
= sym
->as
->rank
;
1625 if (sym
->attr
.save
== SAVE_NONE
)
1626 sym
->attr
.save
= SAVE_IMPLICIT
;
1634 /* Function called by variable_decl() that adds a name to a structure
1638 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1639 gfc_array_spec
**as
)
1644 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1645 constructing, it must have the pointer attribute. */
1646 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1647 && current_ts
.u
.derived
== gfc_current_block ()
1648 && current_attr
.pointer
== 0)
1650 gfc_error ("Component at %C must have the POINTER attribute");
1654 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1656 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1658 gfc_error ("Array component of structure at %C must have explicit "
1659 "or deferred shape");
1664 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1668 if (c
->ts
.type
== BT_CHARACTER
)
1670 c
->attr
= current_attr
;
1672 c
->initializer
= *init
;
1679 c
->attr
.codimension
= 1;
1681 c
->attr
.dimension
= 1;
1685 /* Should this ever get more complicated, combine with similar section
1686 in add_init_expr_to_sym into a separate function. */
1687 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1689 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1693 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1694 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1695 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1697 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1699 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1700 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1701 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1702 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1704 gfc_constructor
*ctor
;
1705 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1710 bool has_ts
= (c
->initializer
->ts
.u
.cl
1711 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1713 /* Remember the length of the first element for checking
1714 that all elements *in the constructor* have the same
1715 length. This need not be the length of the LHS! */
1716 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1717 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1718 first_len
= ctor
->expr
->value
.character
.length
;
1720 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1721 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1723 gfc_set_constant_character_len (len
, ctor
->expr
,
1724 has_ts
? -1 : first_len
);
1725 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1731 /* Check array components. */
1732 if (!c
->attr
.dimension
)
1735 if (c
->attr
.pointer
)
1737 if (c
->as
->type
!= AS_DEFERRED
)
1739 gfc_error ("Pointer array component of structure at %C must have a "
1744 else if (c
->attr
.allocatable
)
1746 if (c
->as
->type
!= AS_DEFERRED
)
1748 gfc_error ("Allocatable component of structure at %C must have a "
1755 if (c
->as
->type
!= AS_EXPLICIT
)
1757 gfc_error ("Array component of structure at %C must have an "
1764 if (c
->ts
.type
== BT_CLASS
)
1766 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1776 /* Match a 'NULL()', and possibly take care of some side effects. */
1779 gfc_match_null (gfc_expr
**result
)
1782 match m
, m2
= MATCH_NO
;
1784 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1790 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1792 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1795 old_loc
= gfc_current_locus
;
1796 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1799 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1803 gfc_current_locus
= old_loc
;
1808 /* The NULL symbol now has to be/become an intrinsic function. */
1809 if (gfc_get_symbol ("null", NULL
, &sym
))
1811 gfc_error ("NULL() initialization at %C is ambiguous");
1815 gfc_intrinsic_symbol (sym
);
1817 if (sym
->attr
.proc
!= PROC_INTRINSIC
1818 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1819 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1820 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1823 *result
= gfc_get_null_expr (&gfc_current_locus
);
1825 /* Invalid per F2008, C512. */
1826 if (m2
== MATCH_YES
)
1828 gfc_error ("NULL() initialization at %C may not have MOLD");
1836 /* Match the initialization expr for a data pointer or procedure pointer. */
1839 match_pointer_init (gfc_expr
**init
, int procptr
)
1843 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1845 gfc_error ("Initialization of pointer at %C is not allowed in "
1846 "a PURE procedure");
1849 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1851 /* Match NULL() initialization. */
1852 m
= gfc_match_null (init
);
1856 /* Match non-NULL initialization. */
1857 gfc_matching_ptr_assignment
= !procptr
;
1858 gfc_matching_procptr_assignment
= procptr
;
1859 m
= gfc_match_rvalue (init
);
1860 gfc_matching_ptr_assignment
= 0;
1861 gfc_matching_procptr_assignment
= 0;
1862 if (m
== MATCH_ERROR
)
1864 else if (m
== MATCH_NO
)
1866 gfc_error ("Error in pointer initialization at %C");
1870 if (!procptr
&& !gfc_resolve_expr (*init
))
1873 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1874 "initialization at %C"))
1882 check_function_name (char *name
)
1884 /* In functions that have a RESULT variable defined, the function name always
1885 refers to function calls. Therefore, the name is not allowed to appear in
1886 specification statements. When checking this, be careful about
1887 'hidden' procedure pointer results ('ppr@'). */
1889 if (gfc_current_state () == COMP_FUNCTION
)
1891 gfc_symbol
*block
= gfc_current_block ();
1892 if (block
&& block
->result
&& block
->result
!= block
1893 && strcmp (block
->result
->name
, "ppr@") != 0
1894 && strcmp (block
->name
, name
) == 0)
1896 gfc_error ("Function name %qs not allowed at %C", name
);
1905 /* Match a variable name with an optional initializer. When this
1906 subroutine is called, a variable is expected to be parsed next.
1907 Depending on what is happening at the moment, updates either the
1908 symbol table or the current interface. */
1911 variable_decl (int elem
)
1913 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1914 gfc_expr
*initializer
, *char_len
;
1916 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1928 /* When we get here, we've just matched a list of attributes and
1929 maybe a type and a double colon. The next thing we expect to see
1930 is the name of the symbol. */
1931 m
= gfc_match_name (name
);
1935 var_locus
= gfc_current_locus
;
1937 /* Now we could see the optional array spec. or character length. */
1938 m
= gfc_match_array_spec (&as
, true, true);
1939 if (m
== MATCH_ERROR
)
1943 as
= gfc_copy_array_spec (current_as
);
1945 && !merge_array_spec (current_as
, as
, true))
1951 if (flag_cray_pointer
)
1952 cp_as
= gfc_copy_array_spec (as
);
1954 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1955 determine (and check) whether it can be implied-shape. If it
1956 was parsed as assumed-size, change it because PARAMETERs can not
1960 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1963 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1968 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1969 && current_attr
.flavor
== FL_PARAMETER
)
1970 as
->type
= AS_IMPLIED_SHAPE
;
1972 if (as
->type
== AS_IMPLIED_SHAPE
1973 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1983 cl_deferred
= false;
1985 if (current_ts
.type
== BT_CHARACTER
)
1987 switch (match_char_length (&char_len
, &cl_deferred
, false))
1990 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1992 cl
->length
= char_len
;
1995 /* Non-constant lengths need to be copied after the first
1996 element. Also copy assumed lengths. */
1999 && (current_ts
.u
.cl
->length
== NULL
2000 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2002 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2003 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2006 cl
= current_ts
.u
.cl
;
2008 cl_deferred
= current_ts
.deferred
;
2017 /* The dummy arguments and result of the abreviated form of MODULE
2018 PROCEDUREs, used in SUBMODULES should not be redefined. */
2019 if (gfc_current_ns
->proc_name
2020 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2022 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2023 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2026 gfc_error ("%qs at %C is a redefinition of the declaration "
2027 "in the corresponding interface for MODULE "
2028 "PROCEDURE %qs", sym
->name
,
2029 gfc_current_ns
->proc_name
->name
);
2034 /* If this symbol has already shown up in a Cray Pointer declaration,
2035 and this is not a component declaration,
2036 then we want to set the type & bail out. */
2037 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
2039 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2040 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2042 sym
->ts
.type
= current_ts
.type
;
2043 sym
->ts
.kind
= current_ts
.kind
;
2045 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2046 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2047 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2050 /* Check to see if we have an array specification. */
2053 if (sym
->as
!= NULL
)
2055 gfc_error ("Duplicate array spec for Cray pointee at %C");
2056 gfc_free_array_spec (cp_as
);
2062 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2063 gfc_internal_error ("Couldn't set pointee array spec.");
2065 /* Fix the array spec. */
2066 m
= gfc_mod_pointee_as (sym
->as
);
2067 if (m
== MATCH_ERROR
)
2075 gfc_free_array_spec (cp_as
);
2079 /* Procedure pointer as function result. */
2080 if (gfc_current_state () == COMP_FUNCTION
2081 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2082 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2083 strcpy (name
, "ppr@");
2085 if (gfc_current_state () == COMP_FUNCTION
2086 && strcmp (name
, gfc_current_block ()->name
) == 0
2087 && gfc_current_block ()->result
2088 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2089 strcpy (name
, "ppr@");
2091 /* OK, we've successfully matched the declaration. Now put the
2092 symbol in the current namespace, because it might be used in the
2093 optional initialization expression for this symbol, e.g. this is
2096 integer, parameter :: i = huge(i)
2098 This is only true for parameters or variables of a basic type.
2099 For components of derived types, it is not true, so we don't
2100 create a symbol for those yet. If we fail to create the symbol,
2102 if (gfc_current_state () != COMP_DERIVED
2103 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2109 if (!check_function_name (name
))
2115 /* We allow old-style initializations of the form
2116 integer i /2/, j(4) /3*3, 1/
2117 (if no colon has been seen). These are different from data
2118 statements in that initializers are only allowed to apply to the
2119 variable immediately preceding, i.e.
2121 is not allowed. Therefore we have to do some work manually, that
2122 could otherwise be left to the matchers for DATA statements. */
2124 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2126 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2127 "initialization at %C"))
2129 else if (gfc_current_state () == COMP_DERIVED
)
2131 gfc_error ("Invalid old style initialization for derived type "
2137 return match_old_style_init (name
);
2140 /* The double colon must be present in order to have initializers.
2141 Otherwise the statement is ambiguous with an assignment statement. */
2144 if (gfc_match (" =>") == MATCH_YES
)
2146 if (!current_attr
.pointer
)
2148 gfc_error ("Initialization at %C isn't for a pointer variable");
2153 m
= match_pointer_init (&initializer
, 0);
2157 else if (gfc_match_char ('=') == MATCH_YES
)
2159 if (current_attr
.pointer
)
2161 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2167 m
= gfc_match_init_expr (&initializer
);
2170 gfc_error ("Expected an initialization expression at %C");
2174 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2175 && gfc_state_stack
->state
!= COMP_DERIVED
)
2177 gfc_error ("Initialization of variable at %C is not allowed in "
2178 "a PURE procedure");
2182 if (current_attr
.flavor
!= FL_PARAMETER
2183 && gfc_state_stack
->state
!= COMP_DERIVED
)
2184 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2191 if (initializer
!= NULL
&& current_attr
.allocatable
2192 && gfc_current_state () == COMP_DERIVED
)
2194 gfc_error ("Initialization of allocatable component at %C is not "
2200 /* Add the initializer. Note that it is fine if initializer is
2201 NULL here, because we sometimes also need to check if a
2202 declaration *must* have an initialization expression. */
2203 if (gfc_current_state () != COMP_DERIVED
)
2204 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2207 if (current_ts
.type
== BT_DERIVED
2208 && !current_attr
.pointer
&& !initializer
)
2209 initializer
= gfc_default_initializer (¤t_ts
);
2210 t
= build_struct (name
, cl
, &initializer
, &as
);
2213 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2216 /* Free stuff up and return. */
2217 gfc_free_expr (initializer
);
2218 gfc_free_array_spec (as
);
2224 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2225 This assumes that the byte size is equal to the kind number for
2226 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2229 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2234 if (gfc_match_char ('*') != MATCH_YES
)
2237 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2241 original_kind
= ts
->kind
;
2243 /* Massage the kind numbers for complex types. */
2244 if (ts
->type
== BT_COMPLEX
)
2248 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2249 gfc_basic_typename (ts
->type
), original_kind
);
2256 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2259 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2263 if (flag_real4_kind
== 8)
2265 if (flag_real4_kind
== 10)
2267 if (flag_real4_kind
== 16)
2273 if (flag_real8_kind
== 4)
2275 if (flag_real8_kind
== 10)
2277 if (flag_real8_kind
== 16)
2282 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2284 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2285 gfc_basic_typename (ts
->type
), original_kind
);
2289 if (!gfc_notify_std (GFC_STD_GNU
,
2290 "Nonstandard type declaration %s*%d at %C",
2291 gfc_basic_typename(ts
->type
), original_kind
))
2298 /* Match a kind specification. Since kinds are generally optional, we
2299 usually return MATCH_NO if something goes wrong. If a "kind="
2300 string is found, then we know we have an error. */
2303 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2315 where
= loc
= gfc_current_locus
;
2320 if (gfc_match_char ('(') == MATCH_NO
)
2323 /* Also gobbles optional text. */
2324 if (gfc_match (" kind = ") == MATCH_YES
)
2327 loc
= gfc_current_locus
;
2330 n
= gfc_match_init_expr (&e
);
2334 if (gfc_matching_function
)
2336 /* The function kind expression might include use associated or
2337 imported parameters and try again after the specification
2339 if (gfc_match_char (')') != MATCH_YES
)
2341 gfc_error ("Missing right parenthesis at %C");
2347 gfc_undo_symbols ();
2352 /* ....or else, the match is real. */
2354 gfc_error ("Expected initialization expression at %C");
2362 gfc_error ("Expected scalar initialization expression at %C");
2367 msg
= gfc_extract_int (e
, &ts
->kind
);
2376 /* Before throwing away the expression, let's see if we had a
2377 C interoperable kind (and store the fact). */
2378 if (e
->ts
.is_c_interop
== 1)
2380 /* Mark this as C interoperable if being declared with one
2381 of the named constants from iso_c_binding. */
2382 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2383 ts
->f90_type
= e
->ts
.f90_type
;
2389 /* Ignore errors to this point, if we've gotten here. This means
2390 we ignore the m=MATCH_ERROR from above. */
2391 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2393 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2394 gfc_basic_typename (ts
->type
));
2395 gfc_current_locus
= where
;
2399 /* Warn if, e.g., c_int is used for a REAL variable, but not
2400 if, e.g., c_double is used for COMPLEX as the standard
2401 explicitly says that the kind type parameter for complex and real
2402 variable is the same, i.e. c_float == c_float_complex. */
2403 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2404 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2405 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2406 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2407 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2408 gfc_basic_typename (ts
->type
));
2410 gfc_gobble_whitespace ();
2411 if ((c
= gfc_next_ascii_char ()) != ')'
2412 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2414 if (ts
->type
== BT_CHARACTER
)
2415 gfc_error ("Missing right parenthesis or comma at %C");
2417 gfc_error ("Missing right parenthesis at %C");
2421 /* All tests passed. */
2424 if(m
== MATCH_ERROR
)
2425 gfc_current_locus
= where
;
2427 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2430 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2434 if (flag_real4_kind
== 8)
2436 if (flag_real4_kind
== 10)
2438 if (flag_real4_kind
== 16)
2444 if (flag_real8_kind
== 4)
2446 if (flag_real8_kind
== 10)
2448 if (flag_real8_kind
== 16)
2453 /* Return what we know from the test(s). */
2458 gfc_current_locus
= where
;
2464 match_char_kind (int * kind
, int * is_iso_c
)
2473 where
= gfc_current_locus
;
2475 n
= gfc_match_init_expr (&e
);
2477 if (n
!= MATCH_YES
&& gfc_matching_function
)
2479 /* The expression might include use-associated or imported
2480 parameters and try again after the specification
2483 gfc_undo_symbols ();
2488 gfc_error ("Expected initialization expression at %C");
2494 gfc_error ("Expected scalar initialization expression at %C");
2499 msg
= gfc_extract_int (e
, kind
);
2500 *is_iso_c
= e
->ts
.is_iso_c
;
2510 /* Ignore errors to this point, if we've gotten here. This means
2511 we ignore the m=MATCH_ERROR from above. */
2512 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2514 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2518 /* All tests passed. */
2521 if (m
== MATCH_ERROR
)
2522 gfc_current_locus
= where
;
2524 /* Return what we know from the test(s). */
2529 gfc_current_locus
= where
;
2534 /* Match the various kind/length specifications in a CHARACTER
2535 declaration. We don't return MATCH_NO. */
2538 gfc_match_char_spec (gfc_typespec
*ts
)
2540 int kind
, seen_length
, is_iso_c
;
2552 /* Try the old-style specification first. */
2553 old_char_selector
= 0;
2555 m
= match_char_length (&len
, &deferred
, true);
2559 old_char_selector
= 1;
2564 m
= gfc_match_char ('(');
2567 m
= MATCH_YES
; /* Character without length is a single char. */
2571 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2572 if (gfc_match (" kind =") == MATCH_YES
)
2574 m
= match_char_kind (&kind
, &is_iso_c
);
2576 if (m
== MATCH_ERROR
)
2581 if (gfc_match (" , len =") == MATCH_NO
)
2584 m
= char_len_param_value (&len
, &deferred
);
2587 if (m
== MATCH_ERROR
)
2594 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2595 if (gfc_match (" len =") == MATCH_YES
)
2597 m
= char_len_param_value (&len
, &deferred
);
2600 if (m
== MATCH_ERROR
)
2604 if (gfc_match_char (')') == MATCH_YES
)
2607 if (gfc_match (" , kind =") != MATCH_YES
)
2610 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2616 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2617 m
= char_len_param_value (&len
, &deferred
);
2620 if (m
== MATCH_ERROR
)
2624 m
= gfc_match_char (')');
2628 if (gfc_match_char (',') != MATCH_YES
)
2631 gfc_match (" kind ="); /* Gobble optional text. */
2633 m
= match_char_kind (&kind
, &is_iso_c
);
2634 if (m
== MATCH_ERROR
)
2640 /* Require a right-paren at this point. */
2641 m
= gfc_match_char (')');
2646 gfc_error ("Syntax error in CHARACTER declaration at %C");
2648 gfc_free_expr (len
);
2652 /* Deal with character functions after USE and IMPORT statements. */
2653 if (gfc_matching_function
)
2655 gfc_free_expr (len
);
2656 gfc_undo_symbols ();
2662 gfc_free_expr (len
);
2666 /* Do some final massaging of the length values. */
2667 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2669 if (seen_length
== 0)
2670 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2675 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2676 ts
->deferred
= deferred
;
2678 /* We have to know if it was a C interoperable kind so we can
2679 do accurate type checking of bind(c) procs, etc. */
2681 /* Mark this as C interoperable if being declared with one
2682 of the named constants from iso_c_binding. */
2683 ts
->is_c_interop
= is_iso_c
;
2684 else if (len
!= NULL
)
2685 /* Here, we might have parsed something such as: character(c_char)
2686 In this case, the parsing code above grabs the c_char when
2687 looking for the length (line 1690, roughly). it's the last
2688 testcase for parsing the kind params of a character variable.
2689 However, it's not actually the length. this seems like it
2691 To see if the user used a C interop kind, test the expr
2692 of the so called length, and see if it's C interoperable. */
2693 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2699 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2700 structure to the matched specification. This is necessary for FUNCTION and
2701 IMPLICIT statements.
2703 If implicit_flag is nonzero, then we don't check for the optional
2704 kind specification. Not doing so is needed for matching an IMPLICIT
2705 statement correctly. */
2708 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2710 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2711 gfc_symbol
*sym
, *dt_sym
;
2714 bool seen_deferred_kind
, matched_type
;
2715 const char *dt_name
;
2717 /* A belt and braces check that the typespec is correctly being treated
2718 as a deferred characteristic association. */
2719 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2720 && (gfc_current_block ()->result
->ts
.kind
== -1)
2721 && (ts
->kind
== -1);
2723 if (seen_deferred_kind
)
2726 /* Clear the current binding label, in case one is given. */
2727 curr_binding_label
= NULL
;
2729 if (gfc_match (" byte") == MATCH_YES
)
2731 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2734 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2736 gfc_error ("BYTE type used at %C "
2737 "is not available on the target machine");
2741 ts
->type
= BT_INTEGER
;
2747 m
= gfc_match (" type (");
2748 matched_type
= (m
== MATCH_YES
);
2751 gfc_gobble_whitespace ();
2752 if (gfc_peek_ascii_char () == '*')
2754 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2756 if (gfc_current_state () == COMP_DERIVED
)
2758 gfc_error ("Assumed type at %C is not allowed for components");
2761 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2764 ts
->type
= BT_ASSUMED
;
2768 m
= gfc_match ("%n", name
);
2769 matched_type
= (m
== MATCH_YES
);
2772 if ((matched_type
&& strcmp ("integer", name
) == 0)
2773 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2775 ts
->type
= BT_INTEGER
;
2776 ts
->kind
= gfc_default_integer_kind
;
2780 if ((matched_type
&& strcmp ("character", name
) == 0)
2781 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2784 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2785 "intrinsic-type-spec at %C"))
2788 ts
->type
= BT_CHARACTER
;
2789 if (implicit_flag
== 0)
2790 m
= gfc_match_char_spec (ts
);
2794 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2800 if ((matched_type
&& strcmp ("real", name
) == 0)
2801 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2804 ts
->kind
= gfc_default_real_kind
;
2809 && (strcmp ("doubleprecision", name
) == 0
2810 || (strcmp ("double", name
) == 0
2811 && gfc_match (" precision") == MATCH_YES
)))
2812 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2815 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2816 "intrinsic-type-spec at %C"))
2818 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2822 ts
->kind
= gfc_default_double_kind
;
2826 if ((matched_type
&& strcmp ("complex", name
) == 0)
2827 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2829 ts
->type
= BT_COMPLEX
;
2830 ts
->kind
= gfc_default_complex_kind
;
2835 && (strcmp ("doublecomplex", name
) == 0
2836 || (strcmp ("double", name
) == 0
2837 && gfc_match (" complex") == MATCH_YES
)))
2838 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2840 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2844 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2845 "intrinsic-type-spec at %C"))
2848 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2851 ts
->type
= BT_COMPLEX
;
2852 ts
->kind
= gfc_default_double_kind
;
2856 if ((matched_type
&& strcmp ("logical", name
) == 0)
2857 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2859 ts
->type
= BT_LOGICAL
;
2860 ts
->kind
= gfc_default_logical_kind
;
2865 m
= gfc_match_char (')');
2868 ts
->type
= BT_DERIVED
;
2871 /* Match CLASS declarations. */
2872 m
= gfc_match (" class ( * )");
2873 if (m
== MATCH_ERROR
)
2875 else if (m
== MATCH_YES
)
2879 ts
->type
= BT_CLASS
;
2880 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2883 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2884 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2886 gfc_set_sym_referenced (upe
);
2888 upe
->ts
.type
= BT_VOID
;
2889 upe
->attr
.unlimited_polymorphic
= 1;
2890 /* This is essential to force the construction of
2891 unlimited polymorphic component class containers. */
2892 upe
->attr
.zero_comp
= 1;
2893 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2894 &gfc_current_locus
))
2899 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2901 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2905 ts
->u
.derived
= upe
;
2909 m
= gfc_match (" class ( %n )", name
);
2912 ts
->type
= BT_CLASS
;
2914 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2918 /* Defer association of the derived type until the end of the
2919 specification block. However, if the derived type can be
2920 found, add it to the typespec. */
2921 if (gfc_matching_function
)
2923 ts
->u
.derived
= NULL
;
2924 if (gfc_current_state () != COMP_INTERFACE
2925 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2927 sym
= gfc_find_dt_in_generic (sym
);
2928 ts
->u
.derived
= sym
;
2933 /* Search for the name but allow the components to be defined later. If
2934 type = -1, this typespec has been seen in a function declaration but
2935 the type could not be accessed at that point. The actual derived type is
2936 stored in a symtree with the first letter of the name capitalized; the
2937 symtree with the all lower-case name contains the associated
2938 generic function. */
2939 dt_name
= gfc_get_string ("%c%s",
2940 (char) TOUPPER ((unsigned char) name
[0]),
2941 (const char*)&name
[1]);
2946 gfc_get_ha_symbol (name
, &sym
);
2947 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2949 gfc_error ("Type name %qs at %C is ambiguous", name
);
2952 if (sym
->generic
&& !dt_sym
)
2953 dt_sym
= gfc_find_dt_in_generic (sym
);
2955 else if (ts
->kind
== -1)
2957 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2958 || gfc_current_ns
->has_import_set
;
2959 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2960 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2962 gfc_error ("Type name %qs at %C is ambiguous", name
);
2965 if (sym
&& sym
->generic
&& !dt_sym
)
2966 dt_sym
= gfc_find_dt_in_generic (sym
);
2973 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2974 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2975 || sym
->attr
.subroutine
)
2977 gfc_error ("Type name %qs at %C conflicts with previously declared "
2978 "entity at %L, which has the same name", name
,
2983 gfc_save_symbol_data (sym
);
2984 gfc_set_sym_referenced (sym
);
2985 if (!sym
->attr
.generic
2986 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2989 if (!sym
->attr
.function
2990 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2995 gfc_interface
*intr
, *head
;
2997 /* Use upper case to save the actual derived-type symbol. */
2998 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2999 dt_sym
->name
= gfc_get_string (sym
->name
);
3000 head
= sym
->generic
;
3001 intr
= gfc_get_interface ();
3003 intr
->where
= gfc_current_locus
;
3005 sym
->generic
= intr
;
3006 sym
->attr
.if_source
= IFSRC_DECL
;
3009 gfc_save_symbol_data (dt_sym
);
3011 gfc_set_sym_referenced (dt_sym
);
3013 if (dt_sym
->attr
.flavor
!= FL_DERIVED
3014 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
3017 ts
->u
.derived
= dt_sym
;
3023 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3024 "intrinsic-type-spec at %C"))
3027 /* For all types except double, derived and character, look for an
3028 optional kind specifier. MATCH_NO is actually OK at this point. */
3029 if (implicit_flag
== 1)
3031 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3037 if (gfc_current_form
== FORM_FREE
)
3039 c
= gfc_peek_ascii_char ();
3040 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
3041 && c
!= ':' && c
!= ',')
3043 if (matched_type
&& c
== ')')
3045 gfc_next_ascii_char ();
3052 m
= gfc_match_kind_spec (ts
, false);
3053 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3055 m
= gfc_match_old_kind_spec (ts
);
3056 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
3060 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3063 /* Defer association of the KIND expression of function results
3064 until after USE and IMPORT statements. */
3065 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3066 || gfc_matching_function
)
3070 m
= MATCH_YES
; /* No kind specifier found. */
3076 /* Match an IMPLICIT NONE statement. Actually, this statement is
3077 already matched in parse.c, or we would not end up here in the
3078 first place. So the only thing we need to check, is if there is
3079 trailing garbage. If not, the match is successful. */
3082 gfc_match_implicit_none (void)
3086 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3088 bool external
= false;
3089 locus cur_loc
= gfc_current_locus
;
3091 if (gfc_current_ns
->seen_implicit_none
3092 || gfc_current_ns
->has_implicit_none_export
)
3094 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3098 gfc_gobble_whitespace ();
3099 c
= gfc_peek_ascii_char ();
3102 (void) gfc_next_ascii_char ();
3103 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3106 gfc_gobble_whitespace ();
3107 if (gfc_peek_ascii_char () == ')')
3109 (void) gfc_next_ascii_char ();
3115 m
= gfc_match (" %n", name
);
3119 if (strcmp (name
, "type") == 0)
3121 else if (strcmp (name
, "external") == 0)
3126 gfc_gobble_whitespace ();
3127 c
= gfc_next_ascii_char ();
3138 if (gfc_match_eos () != MATCH_YES
)
3141 gfc_set_implicit_none (type
, external
, &cur_loc
);
3147 /* Match the letter range(s) of an IMPLICIT statement. */
3150 match_implicit_range (void)
3156 cur_loc
= gfc_current_locus
;
3158 gfc_gobble_whitespace ();
3159 c
= gfc_next_ascii_char ();
3162 gfc_error ("Missing character range in IMPLICIT at %C");
3169 gfc_gobble_whitespace ();
3170 c1
= gfc_next_ascii_char ();
3174 gfc_gobble_whitespace ();
3175 c
= gfc_next_ascii_char ();
3180 inner
= 0; /* Fall through. */
3187 gfc_gobble_whitespace ();
3188 c2
= gfc_next_ascii_char ();
3192 gfc_gobble_whitespace ();
3193 c
= gfc_next_ascii_char ();
3195 if ((c
!= ',') && (c
!= ')'))
3208 gfc_error ("Letters must be in alphabetic order in "
3209 "IMPLICIT statement at %C");
3213 /* See if we can add the newly matched range to the pending
3214 implicits from this IMPLICIT statement. We do not check for
3215 conflicts with whatever earlier IMPLICIT statements may have
3216 set. This is done when we've successfully finished matching
3218 if (!gfc_add_new_implicit_range (c1
, c2
))
3225 gfc_syntax_error (ST_IMPLICIT
);
3227 gfc_current_locus
= cur_loc
;
3232 /* Match an IMPLICIT statement, storing the types for
3233 gfc_set_implicit() if the statement is accepted by the parser.
3234 There is a strange looking, but legal syntactic construction
3235 possible. It looks like:
3237 IMPLICIT INTEGER (a-b) (c-d)
3239 This is legal if "a-b" is a constant expression that happens to
3240 equal one of the legal kinds for integers. The real problem
3241 happens with an implicit specification that looks like:
3243 IMPLICIT INTEGER (a-b)
3245 In this case, a typespec matcher that is "greedy" (as most of the
3246 matchers are) gobbles the character range as a kindspec, leaving
3247 nothing left. We therefore have to go a bit more slowly in the
3248 matching process by inhibiting the kindspec checking during
3249 typespec matching and checking for a kind later. */
3252 gfc_match_implicit (void)
3259 if (gfc_current_ns
->seen_implicit_none
)
3261 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3268 /* We don't allow empty implicit statements. */
3269 if (gfc_match_eos () == MATCH_YES
)
3271 gfc_error ("Empty IMPLICIT statement at %C");
3277 /* First cleanup. */
3278 gfc_clear_new_implicit ();
3280 /* A basic type is mandatory here. */
3281 m
= gfc_match_decl_type_spec (&ts
, 1);
3282 if (m
== MATCH_ERROR
)
3287 cur_loc
= gfc_current_locus
;
3288 m
= match_implicit_range ();
3292 /* We may have <TYPE> (<RANGE>). */
3293 gfc_gobble_whitespace ();
3294 c
= gfc_peek_ascii_char ();
3295 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3297 /* Check for CHARACTER with no length parameter. */
3298 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3300 ts
.kind
= gfc_default_character_kind
;
3301 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3302 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3306 /* Record the Successful match. */
3307 if (!gfc_merge_new_implicit (&ts
))
3310 c
= gfc_next_ascii_char ();
3311 else if (gfc_match_eos () == MATCH_ERROR
)
3316 gfc_current_locus
= cur_loc
;
3319 /* Discard the (incorrectly) matched range. */
3320 gfc_clear_new_implicit ();
3322 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3323 if (ts
.type
== BT_CHARACTER
)
3324 m
= gfc_match_char_spec (&ts
);
3327 m
= gfc_match_kind_spec (&ts
, false);
3330 m
= gfc_match_old_kind_spec (&ts
);
3331 if (m
== MATCH_ERROR
)
3337 if (m
== MATCH_ERROR
)
3340 m
= match_implicit_range ();
3341 if (m
== MATCH_ERROR
)
3346 gfc_gobble_whitespace ();
3347 c
= gfc_next_ascii_char ();
3348 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3351 if (!gfc_merge_new_implicit (&ts
))
3359 gfc_syntax_error (ST_IMPLICIT
);
3367 gfc_match_import (void)
3369 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3374 if (gfc_current_ns
->proc_name
== NULL
3375 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3377 gfc_error ("IMPORT statement at %C only permitted in "
3378 "an INTERFACE body");
3382 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3384 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3385 "in a module procedure interface body");
3389 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3392 if (gfc_match_eos () == MATCH_YES
)
3394 /* All host variables should be imported. */
3395 gfc_current_ns
->has_import_set
= 1;
3399 if (gfc_match (" ::") == MATCH_YES
)
3401 if (gfc_match_eos () == MATCH_YES
)
3403 gfc_error ("Expecting list of named entities at %C");
3411 m
= gfc_match (" %n", name
);
3415 if (gfc_current_ns
->parent
!= NULL
3416 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3418 gfc_error ("Type name %qs at %C is ambiguous", name
);
3421 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3422 && gfc_find_symbol (name
,
3423 gfc_current_ns
->proc_name
->ns
->parent
,
3426 gfc_error ("Type name %qs at %C is ambiguous", name
);
3432 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3433 "at %C - does not exist.", name
);
3437 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3439 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3444 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3447 sym
->attr
.imported
= 1;
3449 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3451 /* The actual derived type is stored in a symtree with the first
3452 letter of the name capitalized; the symtree with the all
3453 lower-case name contains the associated generic function. */
3454 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3455 gfc_get_string ("%c%s",
3456 (char) TOUPPER ((unsigned char) name
[0]),
3460 sym
->attr
.imported
= 1;
3473 if (gfc_match_eos () == MATCH_YES
)
3475 if (gfc_match_char (',') != MATCH_YES
)
3482 gfc_error ("Syntax error in IMPORT statement at %C");
3487 /* A minimal implementation of gfc_match without whitespace, escape
3488 characters or variable arguments. Returns true if the next
3489 characters match the TARGET template exactly. */
3492 match_string_p (const char *target
)
3496 for (p
= target
; *p
; p
++)
3497 if ((char) gfc_next_ascii_char () != *p
)
3502 /* Matches an attribute specification including array specs. If
3503 successful, leaves the variables current_attr and current_as
3504 holding the specification. Also sets the colon_seen variable for
3505 later use by matchers associated with initializations.
3507 This subroutine is a little tricky in the sense that we don't know
3508 if we really have an attr-spec until we hit the double colon.
3509 Until that time, we can only return MATCH_NO. This forces us to
3510 check for duplicate specification at this level. */
3513 match_attr_spec (void)
3515 /* Modifiers that can exist in a type statement. */
3517 { GFC_DECL_BEGIN
= 0,
3518 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3519 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3520 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3521 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3522 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3523 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3526 /* GFC_DECL_END is the sentinel, index starts at 0. */
3527 #define NUM_DECL GFC_DECL_END
3529 locus start
, seen_at
[NUM_DECL
];
3536 gfc_clear_attr (¤t_attr
);
3537 start
= gfc_current_locus
;
3542 /* See if we get all of the keywords up to the final double colon. */
3543 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3551 gfc_gobble_whitespace ();
3553 ch
= gfc_next_ascii_char ();
3556 /* This is the successful exit condition for the loop. */
3557 if (gfc_next_ascii_char () == ':')
3562 gfc_gobble_whitespace ();
3563 switch (gfc_peek_ascii_char ())
3566 gfc_next_ascii_char ();
3567 switch (gfc_next_ascii_char ())
3570 if (match_string_p ("locatable"))
3572 /* Matched "allocatable". */
3573 d
= DECL_ALLOCATABLE
;
3578 if (match_string_p ("ynchronous"))
3580 /* Matched "asynchronous". */
3581 d
= DECL_ASYNCHRONOUS
;
3588 /* Try and match the bind(c). */
3589 m
= gfc_match_bind_c (NULL
, true);
3592 else if (m
== MATCH_ERROR
)
3597 gfc_next_ascii_char ();
3598 if ('o' != gfc_next_ascii_char ())
3600 switch (gfc_next_ascii_char ())
3603 if (match_string_p ("imension"))
3605 d
= DECL_CODIMENSION
;
3609 if (match_string_p ("tiguous"))
3611 d
= DECL_CONTIGUOUS
;
3618 if (match_string_p ("dimension"))
3623 if (match_string_p ("external"))
3628 if (match_string_p ("int"))
3630 ch
= gfc_next_ascii_char ();
3633 if (match_string_p ("nt"))
3635 /* Matched "intent". */
3636 /* TODO: Call match_intent_spec from here. */
3637 if (gfc_match (" ( in out )") == MATCH_YES
)
3639 else if (gfc_match (" ( in )") == MATCH_YES
)
3641 else if (gfc_match (" ( out )") == MATCH_YES
)
3647 if (match_string_p ("insic"))
3649 /* Matched "intrinsic". */
3657 if (match_string_p ("optional"))
3662 gfc_next_ascii_char ();
3663 switch (gfc_next_ascii_char ())
3666 if (match_string_p ("rameter"))
3668 /* Matched "parameter". */
3674 if (match_string_p ("inter"))
3676 /* Matched "pointer". */
3682 ch
= gfc_next_ascii_char ();
3685 if (match_string_p ("vate"))
3687 /* Matched "private". */
3693 if (match_string_p ("tected"))
3695 /* Matched "protected". */
3702 if (match_string_p ("blic"))
3704 /* Matched "public". */
3712 if (match_string_p ("save"))
3717 if (match_string_p ("target"))
3722 gfc_next_ascii_char ();
3723 ch
= gfc_next_ascii_char ();
3726 if (match_string_p ("lue"))
3728 /* Matched "value". */
3734 if (match_string_p ("latile"))
3736 /* Matched "volatile". */
3744 /* No double colon and no recognizable decl_type, so assume that
3745 we've been looking at something else the whole time. */
3752 /* Check to make sure any parens are paired up correctly. */
3753 if (gfc_match_parens () == MATCH_ERROR
)
3760 seen_at
[d
] = gfc_current_locus
;
3762 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3764 gfc_array_spec
*as
= NULL
;
3766 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3767 d
== DECL_CODIMENSION
);
3769 if (current_as
== NULL
)
3771 else if (m
== MATCH_YES
)
3773 if (!merge_array_spec (as
, current_as
, false))
3780 if (d
== DECL_CODIMENSION
)
3781 gfc_error ("Missing codimension specification at %C");
3783 gfc_error ("Missing dimension specification at %C");
3787 if (m
== MATCH_ERROR
)
3792 /* Since we've seen a double colon, we have to be looking at an
3793 attr-spec. This means that we can now issue errors. */
3794 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3799 case DECL_ALLOCATABLE
:
3800 attr
= "ALLOCATABLE";
3802 case DECL_ASYNCHRONOUS
:
3803 attr
= "ASYNCHRONOUS";
3805 case DECL_CODIMENSION
:
3806 attr
= "CODIMENSION";
3808 case DECL_CONTIGUOUS
:
3809 attr
= "CONTIGUOUS";
3811 case DECL_DIMENSION
:
3818 attr
= "INTENT (IN)";
3821 attr
= "INTENT (OUT)";
3824 attr
= "INTENT (IN OUT)";
3826 case DECL_INTRINSIC
:
3832 case DECL_PARAMETER
:
3838 case DECL_PROTECTED
:
3853 case DECL_IS_BIND_C
:
3863 attr
= NULL
; /* This shouldn't happen. */
3866 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3871 /* Now that we've dealt with duplicate attributes, add the attributes
3872 to the current attribute. */
3873 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3878 if (gfc_current_state () == COMP_DERIVED
3879 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3880 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3881 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3883 if (d
== DECL_ALLOCATABLE
)
3885 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3886 "attribute at %C in a TYPE definition"))
3894 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3901 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3902 && gfc_current_state () != COMP_MODULE
)
3904 if (d
== DECL_PRIVATE
)
3908 if (gfc_current_state () == COMP_DERIVED
3909 && gfc_state_stack
->previous
3910 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3912 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3913 "at %L in a TYPE definition", attr
,
3922 gfc_error ("%s attribute at %L is not allowed outside of the "
3923 "specification part of a module", attr
, &seen_at
[d
]);
3931 case DECL_ALLOCATABLE
:
3932 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3935 case DECL_ASYNCHRONOUS
:
3936 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3939 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3942 case DECL_CODIMENSION
:
3943 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3946 case DECL_CONTIGUOUS
:
3947 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3950 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3953 case DECL_DIMENSION
:
3954 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3958 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3962 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3966 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3970 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3973 case DECL_INTRINSIC
:
3974 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3978 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3981 case DECL_PARAMETER
:
3982 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3986 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3989 case DECL_PROTECTED
:
3990 if (gfc_current_state () != COMP_MODULE
3991 || (gfc_current_ns
->proc_name
3992 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
3994 gfc_error ("PROTECTED at %C only allowed in specification "
3995 "part of a module");
4000 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
4003 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
4007 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
4012 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
4017 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
4021 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
4024 case DECL_IS_BIND_C
:
4025 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
4029 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
4032 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
4036 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
4039 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
4043 gfc_internal_error ("match_attr_spec(): Bad attribute");
4053 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4054 if ((gfc_current_state () == COMP_MODULE
4055 || gfc_current_state () == COMP_SUBMODULE
)
4056 && !current_attr
.save
4057 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4058 current_attr
.save
= SAVE_IMPLICIT
;
4064 gfc_current_locus
= start
;
4065 gfc_free_array_spec (current_as
);
4071 /* Set the binding label, dest_label, either with the binding label
4072 stored in the given gfc_typespec, ts, or if none was provided, it
4073 will be the symbol name in all lower case, as required by the draft
4074 (J3/04-007, section 15.4.1). If a binding label was given and
4075 there is more than one argument (num_idents), it is an error. */
4078 set_binding_label (const char **dest_label
, const char *sym_name
,
4081 if (num_idents
> 1 && has_name_equals
)
4083 gfc_error ("Multiple identifiers provided with "
4084 "single NAME= specifier at %C");
4088 if (curr_binding_label
)
4089 /* Binding label given; store in temp holder till have sym. */
4090 *dest_label
= curr_binding_label
;
4093 /* No binding label given, and the NAME= specifier did not exist,
4094 which means there was no NAME="". */
4095 if (sym_name
!= NULL
&& has_name_equals
== 0)
4096 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4103 /* Set the status of the given common block as being BIND(C) or not,
4104 depending on the given parameter, is_bind_c. */
4107 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4109 com_block
->is_bind_c
= is_bind_c
;
4114 /* Verify that the given gfc_typespec is for a C interoperable type. */
4117 gfc_verify_c_interop (gfc_typespec
*ts
)
4119 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4120 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4122 else if (ts
->type
== BT_CLASS
)
4124 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4131 /* Verify that the variables of a given common block, which has been
4132 defined with the attribute specifier bind(c), to be of a C
4133 interoperable type. Errors will be reported here, if
4137 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4139 gfc_symbol
*curr_sym
= NULL
;
4142 curr_sym
= com_block
->head
;
4144 /* Make sure we have at least one symbol. */
4145 if (curr_sym
== NULL
)
4148 /* Here we know we have a symbol, so we'll execute this loop
4152 /* The second to last param, 1, says this is in a common block. */
4153 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4154 curr_sym
= curr_sym
->common_next
;
4155 } while (curr_sym
!= NULL
);
4161 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4162 an appropriate error message is reported. */
4165 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4166 int is_in_common
, gfc_common_head
*com_block
)
4168 bool bind_c_function
= false;
4171 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4172 bind_c_function
= true;
4174 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4176 tmp_sym
= tmp_sym
->result
;
4177 /* Make sure it wasn't an implicitly typed result. */
4178 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4180 gfc_warning (OPT_Wc_binding_type
,
4181 "Implicitly declared BIND(C) function %qs at "
4182 "%L may not be C interoperable", tmp_sym
->name
,
4183 &tmp_sym
->declared_at
);
4184 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4185 /* Mark it as C interoperable to prevent duplicate warnings. */
4186 tmp_sym
->ts
.is_c_interop
= 1;
4187 tmp_sym
->attr
.is_c_interop
= 1;
4191 /* Here, we know we have the bind(c) attribute, so if we have
4192 enough type info, then verify that it's a C interop kind.
4193 The info could be in the symbol already, or possibly still in
4194 the given ts (current_ts), so look in both. */
4195 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4197 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4199 /* See if we're dealing with a sym in a common block or not. */
4200 if (is_in_common
== 1 && warn_c_binding_type
)
4202 gfc_warning (OPT_Wc_binding_type
,
4203 "Variable %qs in common block %qs at %L "
4204 "may not be a C interoperable "
4205 "kind though common block %qs is BIND(C)",
4206 tmp_sym
->name
, com_block
->name
,
4207 &(tmp_sym
->declared_at
), com_block
->name
);
4211 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4212 gfc_error ("Type declaration %qs at %L is not C "
4213 "interoperable but it is BIND(C)",
4214 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4215 else if (warn_c_binding_type
)
4216 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4217 "may not be a C interoperable "
4218 "kind but it is BIND(C)",
4219 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4223 /* Variables declared w/in a common block can't be bind(c)
4224 since there's no way for C to see these variables, so there's
4225 semantically no reason for the attribute. */
4226 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4228 gfc_error ("Variable %qs in common block %qs at "
4229 "%L cannot be declared with BIND(C) "
4230 "since it is not a global",
4231 tmp_sym
->name
, com_block
->name
,
4232 &(tmp_sym
->declared_at
));
4236 /* Scalar variables that are bind(c) can not have the pointer
4237 or allocatable attributes. */
4238 if (tmp_sym
->attr
.is_bind_c
== 1)
4240 if (tmp_sym
->attr
.pointer
== 1)
4242 gfc_error ("Variable %qs at %L cannot have both the "
4243 "POINTER and BIND(C) attributes",
4244 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4248 if (tmp_sym
->attr
.allocatable
== 1)
4250 gfc_error ("Variable %qs at %L cannot have both the "
4251 "ALLOCATABLE and BIND(C) attributes",
4252 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4258 /* If it is a BIND(C) function, make sure the return value is a
4259 scalar value. The previous tests in this function made sure
4260 the type is interoperable. */
4261 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4262 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4263 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4265 /* BIND(C) functions can not return a character string. */
4266 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4267 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4268 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4269 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4270 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4271 "be a character string", tmp_sym
->name
,
4272 &(tmp_sym
->declared_at
));
4275 /* See if the symbol has been marked as private. If it has, make sure
4276 there is no binding label and warn the user if there is one. */
4277 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4278 && tmp_sym
->binding_label
)
4279 /* Use gfc_warning_now because we won't say that the symbol fails
4280 just because of this. */
4281 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4282 "given the binding label %qs", tmp_sym
->name
,
4283 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4289 /* Set the appropriate fields for a symbol that's been declared as
4290 BIND(C) (the is_bind_c flag and the binding label), and verify that
4291 the type is C interoperable. Errors are reported by the functions
4292 used to set/test these fields. */
4295 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4299 /* TODO: Do we need to make sure the vars aren't marked private? */
4301 /* Set the is_bind_c bit in symbol_attribute. */
4302 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4304 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4311 /* Set the fields marking the given common block as BIND(C), including
4312 a binding label, and report any errors encountered. */
4315 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4319 /* destLabel, common name, typespec (which may have binding label). */
4320 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4324 /* Set the given common block (com_block) to being bind(c) (1). */
4325 set_com_block_bind_c (com_block
, 1);
4331 /* Retrieve the list of one or more identifiers that the given bind(c)
4332 attribute applies to. */
4335 get_bind_c_idents (void)
4337 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4339 gfc_symbol
*tmp_sym
= NULL
;
4341 gfc_common_head
*com_block
= NULL
;
4343 if (gfc_match_name (name
) == MATCH_YES
)
4345 found_id
= MATCH_YES
;
4346 gfc_get_ha_symbol (name
, &tmp_sym
);
4348 else if (match_common_name (name
) == MATCH_YES
)
4350 found_id
= MATCH_YES
;
4351 com_block
= gfc_get_common (name
, 0);
4355 gfc_error ("Need either entity or common block name for "
4356 "attribute specification statement at %C");
4360 /* Save the current identifier and look for more. */
4363 /* Increment the number of identifiers found for this spec stmt. */
4366 /* Make sure we have a sym or com block, and verify that it can
4367 be bind(c). Set the appropriate field(s) and look for more
4369 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4371 if (tmp_sym
!= NULL
)
4373 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4378 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4382 /* Look to see if we have another identifier. */
4384 if (gfc_match_eos () == MATCH_YES
)
4385 found_id
= MATCH_NO
;
4386 else if (gfc_match_char (',') != MATCH_YES
)
4387 found_id
= MATCH_NO
;
4388 else if (gfc_match_name (name
) == MATCH_YES
)
4390 found_id
= MATCH_YES
;
4391 gfc_get_ha_symbol (name
, &tmp_sym
);
4393 else if (match_common_name (name
) == MATCH_YES
)
4395 found_id
= MATCH_YES
;
4396 com_block
= gfc_get_common (name
, 0);
4400 gfc_error ("Missing entity or common block name for "
4401 "attribute specification statement at %C");
4407 gfc_internal_error ("Missing symbol");
4409 } while (found_id
== MATCH_YES
);
4411 /* if we get here we were successful */
4416 /* Try and match a BIND(C) attribute specification statement. */
4419 gfc_match_bind_c_stmt (void)
4421 match found_match
= MATCH_NO
;
4426 /* This may not be necessary. */
4428 /* Clear the temporary binding label holder. */
4429 curr_binding_label
= NULL
;
4431 /* Look for the bind(c). */
4432 found_match
= gfc_match_bind_c (NULL
, true);
4434 if (found_match
== MATCH_YES
)
4436 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4439 /* Look for the :: now, but it is not required. */
4442 /* Get the identifier(s) that needs to be updated. This may need to
4443 change to hand the flag(s) for the attr specified so all identifiers
4444 found can have all appropriate parts updated (assuming that the same
4445 spec stmt can have multiple attrs, such as both bind(c) and
4447 if (!get_bind_c_idents ())
4448 /* Error message should have printed already. */
4456 /* Match a data declaration statement. */
4459 gfc_match_data_decl (void)
4465 num_idents_on_line
= 0;
4467 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4471 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4472 && gfc_current_state () != COMP_DERIVED
)
4474 sym
= gfc_use_derived (current_ts
.u
.derived
);
4482 current_ts
.u
.derived
= sym
;
4485 m
= match_attr_spec ();
4486 if (m
== MATCH_ERROR
)
4492 if (current_ts
.type
== BT_CLASS
4493 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4496 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4497 && current_ts
.u
.derived
->components
== NULL
4498 && !current_ts
.u
.derived
->attr
.zero_comp
)
4501 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4504 gfc_find_symbol (current_ts
.u
.derived
->name
,
4505 current_ts
.u
.derived
->ns
, 1, &sym
);
4507 /* Any symbol that we find had better be a type definition
4508 which has its components defined. */
4509 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4510 && (current_ts
.u
.derived
->components
!= NULL
4511 || current_ts
.u
.derived
->attr
.zero_comp
))
4514 gfc_error ("Derived type at %C has not been previously defined "
4515 "and so cannot appear in a derived type definition");
4521 /* If we have an old-style character declaration, and no new-style
4522 attribute specifications, then there a comma is optional between
4523 the type specification and the variable list. */
4524 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4525 gfc_match_char (',');
4527 /* Give the types/attributes to symbols that follow. Give the element
4528 a number so that repeat character length expressions can be copied. */
4532 num_idents_on_line
++;
4533 m
= variable_decl (elem
++);
4534 if (m
== MATCH_ERROR
)
4539 if (gfc_match_eos () == MATCH_YES
)
4541 if (gfc_match_char (',') != MATCH_YES
)
4545 if (!gfc_error_flag_test ())
4546 gfc_error ("Syntax error in data declaration at %C");
4549 gfc_free_data_all (gfc_current_ns
);
4552 gfc_free_array_spec (current_as
);
4558 /* Match a prefix associated with a function or subroutine
4559 declaration. If the typespec pointer is nonnull, then a typespec
4560 can be matched. Note that if nothing matches, MATCH_YES is
4561 returned (the null string was matched). */
4564 gfc_match_prefix (gfc_typespec
*ts
)
4570 gfc_clear_attr (¤t_attr
);
4572 seen_impure
= false;
4574 gcc_assert (!gfc_matching_prefix
);
4575 gfc_matching_prefix
= true;
4579 found_prefix
= false;
4581 if (!seen_type
&& ts
!= NULL
4582 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4583 && gfc_match_space () == MATCH_YES
)
4587 found_prefix
= true;
4590 if (gfc_match ("elemental% ") == MATCH_YES
)
4592 if (!gfc_add_elemental (¤t_attr
, NULL
))
4595 found_prefix
= true;
4598 if (gfc_match ("pure% ") == MATCH_YES
)
4600 if (!gfc_add_pure (¤t_attr
, NULL
))
4603 found_prefix
= true;
4606 if (gfc_match ("recursive% ") == MATCH_YES
)
4608 if (!gfc_add_recursive (¤t_attr
, NULL
))
4611 found_prefix
= true;
4614 /* IMPURE is a somewhat special case, as it needs not set an actual
4615 attribute but rather only prevents ELEMENTAL routines from being
4616 automatically PURE. */
4617 if (gfc_match ("impure% ") == MATCH_YES
)
4619 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4623 found_prefix
= true;
4626 while (found_prefix
);
4628 /* IMPURE and PURE must not both appear, of course. */
4629 if (seen_impure
&& current_attr
.pure
)
4631 gfc_error ("PURE and IMPURE must not appear both at %C");
4635 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4636 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4638 if (!gfc_add_pure (¤t_attr
, NULL
))
4642 /* At this point, the next item is not a prefix. */
4643 gcc_assert (gfc_matching_prefix
);
4645 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4646 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4647 corresponding attribute seems natural and distinguishes these
4648 procedures from procedure types of PROC_MODULE, which these are
4650 if ((gfc_current_state () == COMP_INTERFACE
4651 || gfc_current_state () == COMP_CONTAINS
)
4652 && gfc_match ("module% ") == MATCH_YES
)
4654 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4657 current_attr
.module_procedure
= 1;
4660 gfc_matching_prefix
= false;
4664 gcc_assert (gfc_matching_prefix
);
4665 gfc_matching_prefix
= false;
4670 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4673 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4675 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4678 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4681 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4688 /* Match a formal argument list. */
4691 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4693 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4694 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4697 gfc_formal_arglist
*formal
= NULL
;
4701 /* Keep the interface formal argument list and null it so that the
4702 matching for the new declaration can be done. The numbers and
4703 names of the arguments are checked here. The interface formal
4704 arguments are retained in formal_arglist and the characteristics
4705 are compared in resolve.c(resolve_fl_procedure). See the remark
4706 in get_proc_name about the eventual need to copy the formal_arglist
4707 and populate the formal namespace of the interface symbol. */
4708 if (progname
->attr
.module_procedure
4709 && progname
->attr
.host_assoc
)
4711 formal
= progname
->formal
;
4712 progname
->formal
= NULL
;
4715 if (gfc_match_char ('(') != MATCH_YES
)
4722 if (gfc_match_char (')') == MATCH_YES
)
4727 if (gfc_match_char ('*') == MATCH_YES
)
4730 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4739 m
= gfc_match_name (name
);
4743 if (gfc_get_symbol (name
, NULL
, &sym
))
4747 p
= gfc_get_formal_arglist ();
4759 /* We don't add the VARIABLE flavor because the name could be a
4760 dummy procedure. We don't apply these attributes to formal
4761 arguments of statement functions. */
4762 if (sym
!= NULL
&& !st_flag
4763 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4764 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4770 /* The name of a program unit can be in a different namespace,
4771 so check for it explicitly. After the statement is accepted,
4772 the name is checked for especially in gfc_get_symbol(). */
4773 if (gfc_new_block
!= NULL
&& sym
!= NULL
4774 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4776 gfc_error ("Name %qs at %C is the name of the procedure",
4782 if (gfc_match_char (')') == MATCH_YES
)
4785 m
= gfc_match_char (',');
4788 gfc_error ("Unexpected junk in formal argument list at %C");
4794 /* Check for duplicate symbols in the formal argument list. */
4797 for (p
= head
; p
->next
; p
= p
->next
)
4802 for (q
= p
->next
; q
; q
= q
->next
)
4803 if (p
->sym
== q
->sym
)
4805 gfc_error ("Duplicate symbol %qs in formal argument list "
4806 "at %C", p
->sym
->name
);
4814 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4820 /* gfc_error_now used in following and return with MATCH_YES because
4821 doing otherwise results in a cascade of extraneous errors and in
4822 some cases an ICE in symbol.c(gfc_release_symbol). */
4823 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
4825 bool arg_count_mismatch
= false;
4827 if (!formal
&& head
)
4828 arg_count_mismatch
= true;
4830 /* Abbreviated module procedure declaration is not meant to have any
4831 formal arguments! */
4832 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
4833 arg_count_mismatch
= true;
4835 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4837 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4838 || (p
->next
== NULL
&& q
->next
!= NULL
))
4839 arg_count_mismatch
= true;
4840 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4841 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4844 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4845 "argument names (%s/%s) at %C",
4846 p
->sym
->name
, q
->sym
->name
);
4849 if (arg_count_mismatch
)
4850 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4851 "formal arguments at %C");
4857 gfc_free_formal_arglist (head
);
4862 /* Match a RESULT specification following a function declaration or
4863 ENTRY statement. Also matches the end-of-statement. */
4866 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4868 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4872 if (gfc_match (" result (") != MATCH_YES
)
4875 m
= gfc_match_name (name
);
4879 /* Get the right paren, and that's it because there could be the
4880 bind(c) attribute after the result clause. */
4881 if (gfc_match_char (')') != MATCH_YES
)
4883 /* TODO: should report the missing right paren here. */
4887 if (strcmp (function
->name
, name
) == 0)
4889 gfc_error ("RESULT variable at %C must be different than function name");
4893 if (gfc_get_symbol (name
, NULL
, &r
))
4896 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4905 /* Match a function suffix, which could be a combination of a result
4906 clause and BIND(C), either one, or neither. The draft does not
4907 require them to come in a specific order. */
4910 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4912 match is_bind_c
; /* Found bind(c). */
4913 match is_result
; /* Found result clause. */
4914 match found_match
; /* Status of whether we've found a good match. */
4915 char peek_char
; /* Character we're going to peek at. */
4916 bool allow_binding_name
;
4918 /* Initialize to having found nothing. */
4919 found_match
= MATCH_NO
;
4920 is_bind_c
= MATCH_NO
;
4921 is_result
= MATCH_NO
;
4923 /* Get the next char to narrow between result and bind(c). */
4924 gfc_gobble_whitespace ();
4925 peek_char
= gfc_peek_ascii_char ();
4927 /* C binding names are not allowed for internal procedures. */
4928 if (gfc_current_state () == COMP_CONTAINS
4929 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4930 allow_binding_name
= false;
4932 allow_binding_name
= true;
4937 /* Look for result clause. */
4938 is_result
= match_result (sym
, result
);
4939 if (is_result
== MATCH_YES
)
4941 /* Now see if there is a bind(c) after it. */
4942 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4943 /* We've found the result clause and possibly bind(c). */
4944 found_match
= MATCH_YES
;
4947 /* This should only be MATCH_ERROR. */
4948 found_match
= is_result
;
4951 /* Look for bind(c) first. */
4952 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4953 if (is_bind_c
== MATCH_YES
)
4955 /* Now see if a result clause followed it. */
4956 is_result
= match_result (sym
, result
);
4957 found_match
= MATCH_YES
;
4961 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4962 found_match
= MATCH_ERROR
;
4966 gfc_error ("Unexpected junk after function declaration at %C");
4967 found_match
= MATCH_ERROR
;
4971 if (is_bind_c
== MATCH_YES
)
4973 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4974 if (gfc_current_state () == COMP_CONTAINS
4975 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4976 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4977 "at %L may not be specified for an internal "
4978 "procedure", &gfc_current_locus
))
4981 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4989 /* Procedure pointer return value without RESULT statement:
4990 Add "hidden" result variable named "ppr@". */
4993 add_hidden_procptr_result (gfc_symbol
*sym
)
4997 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
5000 /* First usage case: PROCEDURE and EXTERNAL statements. */
5001 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
5002 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
5003 && sym
->attr
.external
;
5004 /* Second usage case: INTERFACE statements. */
5005 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
5006 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
5007 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
5013 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
5017 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
5018 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
5019 st2
->n
.sym
= stree
->n
.sym
;
5021 sym
->result
= stree
->n
.sym
;
5023 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
5024 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
5025 sym
->result
->attr
.external
= sym
->attr
.external
;
5026 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
5027 sym
->result
->ts
= sym
->ts
;
5028 sym
->attr
.proc_pointer
= 0;
5029 sym
->attr
.pointer
= 0;
5030 sym
->attr
.external
= 0;
5031 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
5033 sym
->result
->attr
.pointer
= 0;
5034 sym
->result
->attr
.proc_pointer
= 1;
5037 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5039 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5040 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5041 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5042 && sym
== gfc_current_ns
->proc_name
5043 && sym
== sym
->result
->ns
->proc_name
5044 && strcmp ("ppr@", sym
->result
->name
) == 0)
5046 sym
->result
->attr
.proc_pointer
= 1;
5047 sym
->attr
.pointer
= 0;
5055 /* Match the interface for a PROCEDURE declaration,
5056 including brackets (R1212). */
5059 match_procedure_interface (gfc_symbol
**proc_if
)
5063 locus old_loc
, entry_loc
;
5064 gfc_namespace
*old_ns
= gfc_current_ns
;
5065 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5067 old_loc
= entry_loc
= gfc_current_locus
;
5068 gfc_clear_ts (¤t_ts
);
5070 if (gfc_match (" (") != MATCH_YES
)
5072 gfc_current_locus
= entry_loc
;
5076 /* Get the type spec. for the procedure interface. */
5077 old_loc
= gfc_current_locus
;
5078 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5079 gfc_gobble_whitespace ();
5080 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5083 if (m
== MATCH_ERROR
)
5086 /* Procedure interface is itself a procedure. */
5087 gfc_current_locus
= old_loc
;
5088 m
= gfc_match_name (name
);
5090 /* First look to see if it is already accessible in the current
5091 namespace because it is use associated or contained. */
5093 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5096 /* If it is still not found, then try the parent namespace, if it
5097 exists and create the symbol there if it is still not found. */
5098 if (gfc_current_ns
->parent
)
5099 gfc_current_ns
= gfc_current_ns
->parent
;
5100 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5103 gfc_current_ns
= old_ns
;
5104 *proc_if
= st
->n
.sym
;
5109 /* Resolve interface if possible. That way, attr.procedure is only set
5110 if it is declared by a later procedure-declaration-stmt, which is
5111 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5112 while ((*proc_if
)->ts
.interface
)
5113 *proc_if
= (*proc_if
)->ts
.interface
;
5115 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5116 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5117 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5118 (*proc_if
)->name
, NULL
))
5123 if (gfc_match (" )") != MATCH_YES
)
5125 gfc_current_locus
= entry_loc
;
5133 /* Match a PROCEDURE declaration (R1211). */
5136 match_procedure_decl (void)
5139 gfc_symbol
*sym
, *proc_if
= NULL
;
5141 gfc_expr
*initializer
= NULL
;
5143 /* Parse interface (with brackets). */
5144 m
= match_procedure_interface (&proc_if
);
5148 /* Parse attributes (with colons). */
5149 m
= match_attr_spec();
5150 if (m
== MATCH_ERROR
)
5153 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5155 current_attr
.is_bind_c
= 1;
5156 has_name_equals
= 0;
5157 curr_binding_label
= NULL
;
5160 /* Get procedure symbols. */
5163 m
= gfc_match_symbol (&sym
, 0);
5166 else if (m
== MATCH_ERROR
)
5169 /* Add current_attr to the symbol attributes. */
5170 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5173 if (sym
->attr
.is_bind_c
)
5175 /* Check for C1218. */
5176 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5178 gfc_error ("BIND(C) attribute at %C requires "
5179 "an interface with BIND(C)");
5182 /* Check for C1217. */
5183 if (has_name_equals
&& sym
->attr
.pointer
)
5185 gfc_error ("BIND(C) procedure with NAME may not have "
5186 "POINTER attribute at %C");
5189 if (has_name_equals
&& sym
->attr
.dummy
)
5191 gfc_error ("Dummy procedure at %C may not have "
5192 "BIND(C) attribute with NAME");
5195 /* Set binding label for BIND(C). */
5196 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5200 if (!gfc_add_external (&sym
->attr
, NULL
))
5203 if (add_hidden_procptr_result (sym
))
5206 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5209 /* Set interface. */
5210 if (proc_if
!= NULL
)
5212 if (sym
->ts
.type
!= BT_UNKNOWN
)
5214 gfc_error ("Procedure %qs at %L already has basic type of %s",
5215 sym
->name
, &gfc_current_locus
,
5216 gfc_basic_typename (sym
->ts
.type
));
5219 sym
->ts
.interface
= proc_if
;
5220 sym
->attr
.untyped
= 1;
5221 sym
->attr
.if_source
= IFSRC_IFBODY
;
5223 else if (current_ts
.type
!= BT_UNKNOWN
)
5225 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5227 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5228 sym
->ts
.interface
->ts
= current_ts
;
5229 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5230 sym
->ts
.interface
->attr
.function
= 1;
5231 sym
->attr
.function
= 1;
5232 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5235 if (gfc_match (" =>") == MATCH_YES
)
5237 if (!current_attr
.pointer
)
5239 gfc_error ("Initialization at %C isn't for a pointer variable");
5244 m
= match_pointer_init (&initializer
, 1);
5248 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5253 if (gfc_match_eos () == MATCH_YES
)
5255 if (gfc_match_char (',') != MATCH_YES
)
5260 gfc_error ("Syntax error in PROCEDURE statement at %C");
5264 /* Free stuff up and return. */
5265 gfc_free_expr (initializer
);
5271 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5274 /* Match a procedure pointer component declaration (R445). */
5277 match_ppc_decl (void)
5280 gfc_symbol
*proc_if
= NULL
;
5284 gfc_expr
*initializer
= NULL
;
5285 gfc_typebound_proc
* tb
;
5286 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5288 /* Parse interface (with brackets). */
5289 m
= match_procedure_interface (&proc_if
);
5293 /* Parse attributes. */
5294 tb
= XCNEW (gfc_typebound_proc
);
5295 tb
->where
= gfc_current_locus
;
5296 m
= match_binding_attributes (tb
, false, true);
5297 if (m
== MATCH_ERROR
)
5300 gfc_clear_attr (¤t_attr
);
5301 current_attr
.procedure
= 1;
5302 current_attr
.proc_pointer
= 1;
5303 current_attr
.access
= tb
->access
;
5304 current_attr
.flavor
= FL_PROCEDURE
;
5306 /* Match the colons (required). */
5307 if (gfc_match (" ::") != MATCH_YES
)
5309 gfc_error ("Expected %<::%> after binding-attributes at %C");
5313 /* Check for C450. */
5314 if (!tb
->nopass
&& proc_if
== NULL
)
5316 gfc_error("NOPASS or explicit interface required at %C");
5320 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5323 /* Match PPC names. */
5327 m
= gfc_match_name (name
);
5330 else if (m
== MATCH_ERROR
)
5333 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5336 /* Add current_attr to the symbol attributes. */
5337 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5340 if (!gfc_add_external (&c
->attr
, NULL
))
5343 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5350 c
->tb
= XCNEW (gfc_typebound_proc
);
5351 c
->tb
->where
= gfc_current_locus
;
5355 /* Set interface. */
5356 if (proc_if
!= NULL
)
5358 c
->ts
.interface
= proc_if
;
5359 c
->attr
.untyped
= 1;
5360 c
->attr
.if_source
= IFSRC_IFBODY
;
5362 else if (ts
.type
!= BT_UNKNOWN
)
5365 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5366 c
->ts
.interface
->result
= c
->ts
.interface
;
5367 c
->ts
.interface
->ts
= ts
;
5368 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5369 c
->ts
.interface
->attr
.function
= 1;
5370 c
->attr
.function
= 1;
5371 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5374 if (gfc_match (" =>") == MATCH_YES
)
5376 m
= match_pointer_init (&initializer
, 1);
5379 gfc_free_expr (initializer
);
5382 c
->initializer
= initializer
;
5385 if (gfc_match_eos () == MATCH_YES
)
5387 if (gfc_match_char (',') != MATCH_YES
)
5392 gfc_error ("Syntax error in procedure pointer component at %C");
5397 /* Match a PROCEDURE declaration inside an interface (R1206). */
5400 match_procedure_in_interface (void)
5404 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5407 if (current_interface
.type
== INTERFACE_NAMELESS
5408 || current_interface
.type
== INTERFACE_ABSTRACT
)
5410 gfc_error ("PROCEDURE at %C must be in a generic interface");
5414 /* Check if the F2008 optional double colon appears. */
5415 gfc_gobble_whitespace ();
5416 old_locus
= gfc_current_locus
;
5417 if (gfc_match ("::") == MATCH_YES
)
5419 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5420 "MODULE PROCEDURE statement at %L", &old_locus
))
5424 gfc_current_locus
= old_locus
;
5428 m
= gfc_match_name (name
);
5431 else if (m
== MATCH_ERROR
)
5433 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5436 if (!gfc_add_interface (sym
))
5439 if (gfc_match_eos () == MATCH_YES
)
5441 if (gfc_match_char (',') != MATCH_YES
)
5448 gfc_error ("Syntax error in PROCEDURE statement at %C");
5453 /* General matcher for PROCEDURE declarations. */
5455 static match
match_procedure_in_type (void);
5458 gfc_match_procedure (void)
5462 switch (gfc_current_state ())
5467 case COMP_SUBMODULE
:
5468 case COMP_SUBROUTINE
:
5471 m
= match_procedure_decl ();
5473 case COMP_INTERFACE
:
5474 m
= match_procedure_in_interface ();
5477 m
= match_ppc_decl ();
5479 case COMP_DERIVED_CONTAINS
:
5480 m
= match_procedure_in_type ();
5489 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5496 /* Warn if a matched procedure has the same name as an intrinsic; this is
5497 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5498 parser-state-stack to find out whether we're in a module. */
5501 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5505 in_module
= (gfc_state_stack
->previous
5506 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5507 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5509 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5513 /* Match a function declaration. */
5516 gfc_match_function_decl (void)
5518 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5519 gfc_symbol
*sym
, *result
;
5523 match found_match
; /* Status returned by match func. */
5525 if (gfc_current_state () != COMP_NONE
5526 && gfc_current_state () != COMP_INTERFACE
5527 && gfc_current_state () != COMP_CONTAINS
)
5530 gfc_clear_ts (¤t_ts
);
5532 old_loc
= gfc_current_locus
;
5534 m
= gfc_match_prefix (¤t_ts
);
5537 gfc_current_locus
= old_loc
;
5541 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5543 gfc_current_locus
= old_loc
;
5547 if (get_proc_name (name
, &sym
, false))
5550 if (add_hidden_procptr_result (sym
))
5553 if (current_attr
.module_procedure
)
5554 sym
->attr
.module_procedure
= 1;
5556 gfc_new_block
= sym
;
5558 m
= gfc_match_formal_arglist (sym
, 0, 0);
5561 gfc_error ("Expected formal argument list in function "
5562 "definition at %C");
5566 else if (m
== MATCH_ERROR
)
5571 /* According to the draft, the bind(c) and result clause can
5572 come in either order after the formal_arg_list (i.e., either
5573 can be first, both can exist together or by themselves or neither
5574 one). Therefore, the match_result can't match the end of the
5575 string, and check for the bind(c) or result clause in either order. */
5576 found_match
= gfc_match_eos ();
5578 /* Make sure that it isn't already declared as BIND(C). If it is, it
5579 must have been marked BIND(C) with a BIND(C) attribute and that is
5580 not allowed for procedures. */
5581 if (sym
->attr
.is_bind_c
== 1)
5583 sym
->attr
.is_bind_c
= 0;
5584 if (sym
->old_symbol
!= NULL
)
5585 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5586 "variables or common blocks",
5587 &(sym
->old_symbol
->declared_at
));
5589 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5590 "variables or common blocks", &gfc_current_locus
);
5593 if (found_match
!= MATCH_YES
)
5595 /* If we haven't found the end-of-statement, look for a suffix. */
5596 suffix_match
= gfc_match_suffix (sym
, &result
);
5597 if (suffix_match
== MATCH_YES
)
5598 /* Need to get the eos now. */
5599 found_match
= gfc_match_eos ();
5601 found_match
= suffix_match
;
5604 if(found_match
!= MATCH_YES
)
5608 /* Make changes to the symbol. */
5611 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5614 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5615 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5618 /* Delay matching the function characteristics until after the
5619 specification block by signalling kind=-1. */
5620 sym
->declared_at
= old_loc
;
5621 if (current_ts
.type
!= BT_UNKNOWN
)
5622 current_ts
.kind
= -1;
5624 current_ts
.kind
= 0;
5628 if (current_ts
.type
!= BT_UNKNOWN
5629 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5635 if (current_ts
.type
!= BT_UNKNOWN
5636 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5638 sym
->result
= result
;
5641 /* Warn if this procedure has the same name as an intrinsic. */
5642 do_warn_intrinsic_shadow (sym
, true);
5648 gfc_current_locus
= old_loc
;
5653 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5654 pass the name of the entry, rather than the gfc_current_block name, and
5655 to return false upon finding an existing global entry. */
5658 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5662 enum gfc_symbol_type type
;
5664 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5666 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5667 name is a global identifier. */
5668 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5670 s
= gfc_get_gsymbol (name
);
5672 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5674 gfc_global_used (s
, where
);
5683 s
->ns
= gfc_current_ns
;
5687 /* Don't add the symbol multiple times. */
5689 && (!gfc_notification_std (GFC_STD_F2008
)
5690 || strcmp (name
, binding_label
) != 0))
5692 s
= gfc_get_gsymbol (binding_label
);
5694 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5696 gfc_global_used (s
, where
);
5703 s
->binding_label
= binding_label
;
5706 s
->ns
= gfc_current_ns
;
5714 /* Match an ENTRY statement. */
5717 gfc_match_entry (void)
5722 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5723 gfc_compile_state state
;
5727 bool module_procedure
;
5731 m
= gfc_match_name (name
);
5735 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5738 state
= gfc_current_state ();
5739 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5744 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5747 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5749 case COMP_SUBMODULE
:
5750 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5752 case COMP_BLOCK_DATA
:
5753 gfc_error ("ENTRY statement at %C cannot appear within "
5756 case COMP_INTERFACE
:
5757 gfc_error ("ENTRY statement at %C cannot appear within "
5761 gfc_error ("ENTRY statement at %C cannot appear within "
5762 "a DERIVED TYPE block");
5765 gfc_error ("ENTRY statement at %C cannot appear within "
5766 "an IF-THEN block");
5769 case COMP_DO_CONCURRENT
:
5770 gfc_error ("ENTRY statement at %C cannot appear within "
5774 gfc_error ("ENTRY statement at %C cannot appear within "
5778 gfc_error ("ENTRY statement at %C cannot appear within "
5782 gfc_error ("ENTRY statement at %C cannot appear within "
5786 gfc_error ("ENTRY statement at %C cannot appear within "
5787 "a contained subprogram");
5790 gfc_error ("Unexpected ENTRY statement at %C");
5795 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
5796 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5798 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
5802 module_procedure
= gfc_current_ns
->parent
!= NULL
5803 && gfc_current_ns
->parent
->proc_name
5804 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5807 if (gfc_current_ns
->parent
!= NULL
5808 && gfc_current_ns
->parent
->proc_name
5809 && !module_procedure
)
5811 gfc_error("ENTRY statement at %C cannot appear in a "
5812 "contained procedure");
5816 /* Module function entries need special care in get_proc_name
5817 because previous references within the function will have
5818 created symbols attached to the current namespace. */
5819 if (get_proc_name (name
, &entry
,
5820 gfc_current_ns
->parent
!= NULL
5821 && module_procedure
))
5824 proc
= gfc_current_block ();
5826 /* Make sure that it isn't already declared as BIND(C). If it is, it
5827 must have been marked BIND(C) with a BIND(C) attribute and that is
5828 not allowed for procedures. */
5829 if (entry
->attr
.is_bind_c
== 1)
5831 entry
->attr
.is_bind_c
= 0;
5832 if (entry
->old_symbol
!= NULL
)
5833 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5834 "variables or common blocks",
5835 &(entry
->old_symbol
->declared_at
));
5837 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5838 "variables or common blocks", &gfc_current_locus
);
5841 /* Check what next non-whitespace character is so we can tell if there
5842 is the required parens if we have a BIND(C). */
5843 old_loc
= gfc_current_locus
;
5844 gfc_gobble_whitespace ();
5845 peek_char
= gfc_peek_ascii_char ();
5847 if (state
== COMP_SUBROUTINE
)
5849 m
= gfc_match_formal_arglist (entry
, 0, 1);
5853 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5854 never be an internal procedure. */
5855 is_bind_c
= gfc_match_bind_c (entry
, true);
5856 if (is_bind_c
== MATCH_ERROR
)
5858 if (is_bind_c
== MATCH_YES
)
5860 if (peek_char
!= '(')
5862 gfc_error ("Missing required parentheses before BIND(C) at %C");
5865 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5866 &(entry
->declared_at
), 1))
5870 if (!gfc_current_ns
->parent
5871 && !add_global_entry (name
, entry
->binding_label
, true,
5875 /* An entry in a subroutine. */
5876 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5877 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5882 /* An entry in a function.
5883 We need to take special care because writing
5888 ENTRY f() RESULT (r)
5890 ENTRY f RESULT (r). */
5891 if (gfc_match_eos () == MATCH_YES
)
5893 gfc_current_locus
= old_loc
;
5894 /* Match the empty argument list, and add the interface to
5896 m
= gfc_match_formal_arglist (entry
, 0, 1);
5899 m
= gfc_match_formal_arglist (entry
, 0, 0);
5906 if (gfc_match_eos () == MATCH_YES
)
5908 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5909 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5912 entry
->result
= entry
;
5916 m
= gfc_match_suffix (entry
, &result
);
5918 gfc_syntax_error (ST_ENTRY
);
5924 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5925 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5926 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5928 entry
->result
= result
;
5932 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5933 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5935 entry
->result
= entry
;
5939 if (!gfc_current_ns
->parent
5940 && !add_global_entry (name
, entry
->binding_label
, false,
5945 if (gfc_match_eos () != MATCH_YES
)
5947 gfc_syntax_error (ST_ENTRY
);
5951 entry
->attr
.recursive
= proc
->attr
.recursive
;
5952 entry
->attr
.elemental
= proc
->attr
.elemental
;
5953 entry
->attr
.pure
= proc
->attr
.pure
;
5955 el
= gfc_get_entry_list ();
5957 el
->next
= gfc_current_ns
->entries
;
5958 gfc_current_ns
->entries
= el
;
5960 el
->id
= el
->next
->id
+ 1;
5964 new_st
.op
= EXEC_ENTRY
;
5965 new_st
.ext
.entry
= el
;
5971 /* Match a subroutine statement, including optional prefixes. */
5974 gfc_match_subroutine (void)
5976 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5981 bool allow_binding_name
;
5983 if (gfc_current_state () != COMP_NONE
5984 && gfc_current_state () != COMP_INTERFACE
5985 && gfc_current_state () != COMP_CONTAINS
)
5988 m
= gfc_match_prefix (NULL
);
5992 m
= gfc_match ("subroutine% %n", name
);
5996 if (get_proc_name (name
, &sym
, false))
5999 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6000 the symbol existed before. */
6001 sym
->declared_at
= gfc_current_locus
;
6003 if (current_attr
.module_procedure
)
6004 sym
->attr
.module_procedure
= 1;
6006 if (add_hidden_procptr_result (sym
))
6009 gfc_new_block
= sym
;
6011 /* Check what next non-whitespace character is so we can tell if there
6012 is the required parens if we have a BIND(C). */
6013 gfc_gobble_whitespace ();
6014 peek_char
= gfc_peek_ascii_char ();
6016 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
6019 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
6022 /* Make sure that it isn't already declared as BIND(C). If it is, it
6023 must have been marked BIND(C) with a BIND(C) attribute and that is
6024 not allowed for procedures. */
6025 if (sym
->attr
.is_bind_c
== 1)
6027 sym
->attr
.is_bind_c
= 0;
6028 if (sym
->old_symbol
!= NULL
)
6029 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6030 "variables or common blocks",
6031 &(sym
->old_symbol
->declared_at
));
6033 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6034 "variables or common blocks", &gfc_current_locus
);
6037 /* C binding names are not allowed for internal procedures. */
6038 if (gfc_current_state () == COMP_CONTAINS
6039 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6040 allow_binding_name
= false;
6042 allow_binding_name
= true;
6044 /* Here, we are just checking if it has the bind(c) attribute, and if
6045 so, then we need to make sure it's all correct. If it doesn't,
6046 we still need to continue matching the rest of the subroutine line. */
6047 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6048 if (is_bind_c
== MATCH_ERROR
)
6050 /* There was an attempt at the bind(c), but it was wrong. An
6051 error message should have been printed w/in the gfc_match_bind_c
6052 so here we'll just return the MATCH_ERROR. */
6056 if (is_bind_c
== MATCH_YES
)
6058 /* The following is allowed in the Fortran 2008 draft. */
6059 if (gfc_current_state () == COMP_CONTAINS
6060 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6061 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6062 "at %L may not be specified for an internal "
6063 "procedure", &gfc_current_locus
))
6066 if (peek_char
!= '(')
6068 gfc_error ("Missing required parentheses before BIND(C) at %C");
6071 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6072 &(sym
->declared_at
), 1))
6076 if (gfc_match_eos () != MATCH_YES
)
6078 gfc_syntax_error (ST_SUBROUTINE
);
6082 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6085 /* Warn if it has the same name as an intrinsic. */
6086 do_warn_intrinsic_shadow (sym
, false);
6092 /* Check that the NAME identifier in a BIND attribute or statement
6093 is conform to C identifier rules. */
6096 check_bind_name_identifier (char **name
)
6098 char *n
= *name
, *p
;
6100 /* Remove leading spaces. */
6104 /* On an empty string, free memory and set name to NULL. */
6112 /* Remove trailing spaces. */
6113 p
= n
+ strlen(n
) - 1;
6117 /* Insert the identifier into the symbol table. */
6122 /* Now check that identifier is valid under C rules. */
6125 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6130 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6132 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6140 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6141 given, and set the binding label in either the given symbol (if not
6142 NULL), or in the current_ts. The symbol may be NULL because we may
6143 encounter the BIND(C) before the declaration itself. Return
6144 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6145 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6146 or MATCH_YES if the specifier was correct and the binding label and
6147 bind(c) fields were set correctly for the given symbol or the
6148 current_ts. If allow_binding_name is false, no binding name may be
6152 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6154 char *binding_label
= NULL
;
6157 /* Initialize the flag that specifies whether we encountered a NAME=
6158 specifier or not. */
6159 has_name_equals
= 0;
6161 /* This much we have to be able to match, in this order, if
6162 there is a bind(c) label. */
6163 if (gfc_match (" bind ( c ") != MATCH_YES
)
6166 /* Now see if there is a binding label, or if we've reached the
6167 end of the bind(c) attribute without one. */
6168 if (gfc_match_char (',') == MATCH_YES
)
6170 if (gfc_match (" name = ") != MATCH_YES
)
6172 gfc_error ("Syntax error in NAME= specifier for binding label "
6174 /* should give an error message here */
6178 has_name_equals
= 1;
6180 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6186 if (!gfc_simplify_expr(e
, 0))
6188 gfc_error ("NAME= specifier at %C should be a constant expression");
6193 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6194 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6196 gfc_error ("NAME= specifier at %C should be a scalar of "
6197 "default character kind");
6202 // Get a C string from the Fortran string constant
6203 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6204 e
->value
.character
.length
);
6207 // Check that it is valid (old gfc_match_name_C)
6208 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6212 /* Get the required right paren. */
6213 if (gfc_match_char (')') != MATCH_YES
)
6215 gfc_error ("Missing closing paren for binding label at %C");
6219 if (has_name_equals
&& !allow_binding_name
)
6221 gfc_error ("No binding name is allowed in BIND(C) at %C");
6225 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6227 gfc_error ("For dummy procedure %s, no binding name is "
6228 "allowed in BIND(C) at %C", sym
->name
);
6233 /* Save the binding label to the symbol. If sym is null, we're
6234 probably matching the typespec attributes of a declaration and
6235 haven't gotten the name yet, and therefore, no symbol yet. */
6239 sym
->binding_label
= binding_label
;
6241 curr_binding_label
= binding_label
;
6243 else if (allow_binding_name
)
6245 /* No binding label, but if symbol isn't null, we
6246 can set the label for it here.
6247 If name="" or allow_binding_name is false, no C binding name is
6249 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6250 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6253 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6254 && current_interface
.type
== INTERFACE_ABSTRACT
)
6256 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6264 /* Return nonzero if we're currently compiling a contained procedure. */
6267 contained_procedure (void)
6269 gfc_state_data
*s
= gfc_state_stack
;
6271 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6272 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6278 /* Set the kind of each enumerator. The kind is selected such that it is
6279 interoperable with the corresponding C enumeration type, making
6280 sure that -fshort-enums is honored. */
6285 enumerator_history
*current_history
= NULL
;
6289 if (max_enum
== NULL
|| enum_history
== NULL
)
6292 if (!flag_short_enums
)
6298 kind
= gfc_integer_kinds
[i
++].kind
;
6300 while (kind
< gfc_c_int_kind
6301 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6304 current_history
= enum_history
;
6305 while (current_history
!= NULL
)
6307 current_history
->sym
->ts
.kind
= kind
;
6308 current_history
= current_history
->next
;
6313 /* Match any of the various end-block statements. Returns the type of
6314 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6315 and END BLOCK statements cannot be replaced by a single END statement. */
6318 gfc_match_end (gfc_statement
*st
)
6320 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6321 gfc_compile_state state
;
6323 const char *block_name
;
6327 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6328 gfc_namespace
**nsp
;
6329 bool abreviated_modproc_decl
;
6331 old_loc
= gfc_current_locus
;
6332 if (gfc_match ("end") != MATCH_YES
)
6335 state
= gfc_current_state ();
6336 block_name
= gfc_current_block () == NULL
6337 ? NULL
: gfc_current_block ()->name
;
6341 case COMP_ASSOCIATE
:
6343 if (!strncmp (block_name
, "block@", strlen("block@")))
6348 case COMP_DERIVED_CONTAINS
:
6349 state
= gfc_state_stack
->previous
->state
;
6350 block_name
= gfc_state_stack
->previous
->sym
== NULL
6351 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6358 abreviated_modproc_decl
6359 = gfc_current_block ()
6360 && gfc_current_block ()->abr_modproc_decl
;
6366 *st
= ST_END_PROGRAM
;
6367 target
= " program";
6371 case COMP_SUBROUTINE
:
6372 *st
= ST_END_SUBROUTINE
;
6373 if (!abreviated_modproc_decl
)
6374 target
= " subroutine";
6376 target
= " procedure";
6377 eos_ok
= !contained_procedure ();
6381 *st
= ST_END_FUNCTION
;
6382 if (!abreviated_modproc_decl
)
6383 target
= " function";
6385 target
= " procedure";
6386 eos_ok
= !contained_procedure ();
6389 case COMP_BLOCK_DATA
:
6390 *st
= ST_END_BLOCK_DATA
;
6391 target
= " block data";
6396 *st
= ST_END_MODULE
;
6401 case COMP_SUBMODULE
:
6402 *st
= ST_END_SUBMODULE
;
6403 target
= " submodule";
6407 case COMP_INTERFACE
:
6408 *st
= ST_END_INTERFACE
;
6409 target
= " interface";
6414 case COMP_DERIVED_CONTAINS
:
6420 case COMP_ASSOCIATE
:
6421 *st
= ST_END_ASSOCIATE
;
6422 target
= " associate";
6439 case COMP_DO_CONCURRENT
:
6446 *st
= ST_END_CRITICAL
;
6447 target
= " critical";
6452 case COMP_SELECT_TYPE
:
6453 *st
= ST_END_SELECT
;
6459 *st
= ST_END_FORALL
;
6474 last_initializer
= NULL
;
6476 gfc_free_enum_history ();
6480 gfc_error ("Unexpected END statement at %C");
6484 old_loc
= gfc_current_locus
;
6485 if (gfc_match_eos () == MATCH_YES
)
6487 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6489 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6490 "instead of %s statement at %L",
6491 abreviated_modproc_decl
? "END PROCEDURE"
6492 : gfc_ascii_statement(*st
), &old_loc
))
6497 /* We would have required END [something]. */
6498 gfc_error ("%s statement expected at %L",
6499 gfc_ascii_statement (*st
), &old_loc
);
6506 /* Verify that we've got the sort of end-block that we're expecting. */
6507 if (gfc_match (target
) != MATCH_YES
)
6509 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6510 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6514 old_loc
= gfc_current_locus
;
6515 /* If we're at the end, make sure a block name wasn't required. */
6516 if (gfc_match_eos () == MATCH_YES
)
6519 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6520 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6521 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6527 gfc_error ("Expected block name of %qs in %s statement at %L",
6528 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6533 /* END INTERFACE has a special handler for its several possible endings. */
6534 if (*st
== ST_END_INTERFACE
)
6535 return gfc_match_end_interface ();
6537 /* We haven't hit the end of statement, so what is left must be an
6539 m
= gfc_match_space ();
6541 m
= gfc_match_name (name
);
6544 gfc_error ("Expected terminating name at %C");
6548 if (block_name
== NULL
)
6551 /* We have to pick out the declared submodule name from the composite
6552 required by F2008:11.2.3 para 2, which ends in the declared name. */
6553 if (state
== COMP_SUBMODULE
)
6554 block_name
= strchr (block_name
, '.') + 1;
6556 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6558 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6559 gfc_ascii_statement (*st
));
6562 /* Procedure pointer as function result. */
6563 else if (strcmp (block_name
, "ppr@") == 0
6564 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6566 gfc_error ("Expected label %qs for %s statement at %C",
6567 gfc_current_block ()->ns
->proc_name
->name
,
6568 gfc_ascii_statement (*st
));
6572 if (gfc_match_eos () == MATCH_YES
)
6576 gfc_syntax_error (*st
);
6579 gfc_current_locus
= old_loc
;
6581 /* If we are missing an END BLOCK, we created a half-ready namespace.
6582 Remove it from the parent namespace's sibling list. */
6584 while (state
== COMP_BLOCK
)
6586 parent_ns
= gfc_current_ns
->parent
;
6588 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6594 if (ns
== gfc_current_ns
)
6596 if (prev_ns
== NULL
)
6599 prev_ns
->sibling
= ns
->sibling
;
6605 gfc_free_namespace (gfc_current_ns
);
6606 gfc_current_ns
= parent_ns
;
6607 gfc_state_stack
= gfc_state_stack
->previous
;
6608 state
= gfc_current_state ();
6616 /***************** Attribute declaration statements ****************/
6618 /* Set the attribute of a single variable. */
6623 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6626 /* Workaround -Wmaybe-uninitialized false positive during
6627 profiledbootstrap by initializing them. */
6628 gfc_symbol
*sym
= NULL
;
6634 m
= gfc_match_name (name
);
6638 if (find_special (name
, &sym
, false))
6641 if (!check_function_name (name
))
6647 var_locus
= gfc_current_locus
;
6649 /* Deal with possible array specification for certain attributes. */
6650 if (current_attr
.dimension
6651 || current_attr
.codimension
6652 || current_attr
.allocatable
6653 || current_attr
.pointer
6654 || current_attr
.target
)
6656 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6657 !current_attr
.dimension
6658 && !current_attr
.pointer
6659 && !current_attr
.target
);
6660 if (m
== MATCH_ERROR
)
6663 if (current_attr
.dimension
&& m
== MATCH_NO
)
6665 gfc_error ("Missing array specification at %L in DIMENSION "
6666 "statement", &var_locus
);
6671 if (current_attr
.dimension
&& sym
->value
)
6673 gfc_error ("Dimensions specified for %s at %L after its "
6674 "initialisation", sym
->name
, &var_locus
);
6679 if (current_attr
.codimension
&& m
== MATCH_NO
)
6681 gfc_error ("Missing array specification at %L in CODIMENSION "
6682 "statement", &var_locus
);
6687 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6688 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6690 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6696 /* Update symbol table. DIMENSION attribute is set in
6697 gfc_set_array_spec(). For CLASS variables, this must be applied
6698 to the first component, or '_data' field. */
6699 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6701 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6709 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6710 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6717 if (sym
->ts
.type
== BT_CLASS
6718 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6724 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6730 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6732 /* Fix the array spec. */
6733 m
= gfc_mod_pointee_as (sym
->as
);
6734 if (m
== MATCH_ERROR
)
6738 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6744 if ((current_attr
.external
|| current_attr
.intrinsic
)
6745 && sym
->attr
.flavor
!= FL_PROCEDURE
6746 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6752 add_hidden_procptr_result (sym
);
6757 gfc_free_array_spec (as
);
6762 /* Generic attribute declaration subroutine. Used for attributes that
6763 just have a list of names. */
6770 /* Gobble the optional double colon, by simply ignoring the result
6780 if (gfc_match_eos () == MATCH_YES
)
6786 if (gfc_match_char (',') != MATCH_YES
)
6788 gfc_error ("Unexpected character in variable list at %C");
6798 /* This routine matches Cray Pointer declarations of the form:
6799 pointer ( <pointer>, <pointee> )
6801 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6802 The pointer, if already declared, should be an integer. Otherwise, we
6803 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6804 be either a scalar, or an array declaration. No space is allocated for
6805 the pointee. For the statement
6806 pointer (ipt, ar(10))
6807 any subsequent uses of ar will be translated (in C-notation) as
6808 ar(i) => ((<type> *) ipt)(i)
6809 After gimplification, pointee variable will disappear in the code. */
6812 cray_pointer_decl (void)
6815 gfc_array_spec
*as
= NULL
;
6816 gfc_symbol
*cptr
; /* Pointer symbol. */
6817 gfc_symbol
*cpte
; /* Pointee symbol. */
6823 if (gfc_match_char ('(') != MATCH_YES
)
6825 gfc_error ("Expected %<(%> at %C");
6829 /* Match pointer. */
6830 var_locus
= gfc_current_locus
;
6831 gfc_clear_attr (¤t_attr
);
6832 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6833 current_ts
.type
= BT_INTEGER
;
6834 current_ts
.kind
= gfc_index_integer_kind
;
6836 m
= gfc_match_symbol (&cptr
, 0);
6839 gfc_error ("Expected variable name at %C");
6843 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6846 gfc_set_sym_referenced (cptr
);
6848 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6850 cptr
->ts
.type
= BT_INTEGER
;
6851 cptr
->ts
.kind
= gfc_index_integer_kind
;
6853 else if (cptr
->ts
.type
!= BT_INTEGER
)
6855 gfc_error ("Cray pointer at %C must be an integer");
6858 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6859 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6860 " memory addresses require %d bytes",
6861 cptr
->ts
.kind
, gfc_index_integer_kind
);
6863 if (gfc_match_char (',') != MATCH_YES
)
6865 gfc_error ("Expected \",\" at %C");
6869 /* Match Pointee. */
6870 var_locus
= gfc_current_locus
;
6871 gfc_clear_attr (¤t_attr
);
6872 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6873 current_ts
.type
= BT_UNKNOWN
;
6874 current_ts
.kind
= 0;
6876 m
= gfc_match_symbol (&cpte
, 0);
6879 gfc_error ("Expected variable name at %C");
6883 /* Check for an optional array spec. */
6884 m
= gfc_match_array_spec (&as
, true, false);
6885 if (m
== MATCH_ERROR
)
6887 gfc_free_array_spec (as
);
6890 else if (m
== MATCH_NO
)
6892 gfc_free_array_spec (as
);
6896 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6899 gfc_set_sym_referenced (cpte
);
6901 if (cpte
->as
== NULL
)
6903 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6904 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6906 else if (as
!= NULL
)
6908 gfc_error ("Duplicate array spec for Cray pointee at %C");
6909 gfc_free_array_spec (as
);
6915 if (cpte
->as
!= NULL
)
6917 /* Fix array spec. */
6918 m
= gfc_mod_pointee_as (cpte
->as
);
6919 if (m
== MATCH_ERROR
)
6923 /* Point the Pointee at the Pointer. */
6924 cpte
->cp_pointer
= cptr
;
6926 if (gfc_match_char (')') != MATCH_YES
)
6928 gfc_error ("Expected \")\" at %C");
6931 m
= gfc_match_char (',');
6933 done
= true; /* Stop searching for more declarations. */
6937 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6938 || gfc_match_eos () != MATCH_YES
)
6940 gfc_error ("Expected %<,%> or end of statement at %C");
6948 gfc_match_external (void)
6951 gfc_clear_attr (¤t_attr
);
6952 current_attr
.external
= 1;
6954 return attr_decl ();
6959 gfc_match_intent (void)
6963 /* This is not allowed within a BLOCK construct! */
6964 if (gfc_current_state () == COMP_BLOCK
)
6966 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6970 intent
= match_intent_spec ();
6971 if (intent
== INTENT_UNKNOWN
)
6974 gfc_clear_attr (¤t_attr
);
6975 current_attr
.intent
= intent
;
6977 return attr_decl ();
6982 gfc_match_intrinsic (void)
6985 gfc_clear_attr (¤t_attr
);
6986 current_attr
.intrinsic
= 1;
6988 return attr_decl ();
6993 gfc_match_optional (void)
6995 /* This is not allowed within a BLOCK construct! */
6996 if (gfc_current_state () == COMP_BLOCK
)
6998 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7002 gfc_clear_attr (¤t_attr
);
7003 current_attr
.optional
= 1;
7005 return attr_decl ();
7010 gfc_match_pointer (void)
7012 gfc_gobble_whitespace ();
7013 if (gfc_peek_ascii_char () == '(')
7015 if (!flag_cray_pointer
)
7017 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7021 return cray_pointer_decl ();
7025 gfc_clear_attr (¤t_attr
);
7026 current_attr
.pointer
= 1;
7028 return attr_decl ();
7034 gfc_match_allocatable (void)
7036 gfc_clear_attr (¤t_attr
);
7037 current_attr
.allocatable
= 1;
7039 return attr_decl ();
7044 gfc_match_codimension (void)
7046 gfc_clear_attr (¤t_attr
);
7047 current_attr
.codimension
= 1;
7049 return attr_decl ();
7054 gfc_match_contiguous (void)
7056 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7059 gfc_clear_attr (¤t_attr
);
7060 current_attr
.contiguous
= 1;
7062 return attr_decl ();
7067 gfc_match_dimension (void)
7069 gfc_clear_attr (¤t_attr
);
7070 current_attr
.dimension
= 1;
7072 return attr_decl ();
7077 gfc_match_target (void)
7079 gfc_clear_attr (¤t_attr
);
7080 current_attr
.target
= 1;
7082 return attr_decl ();
7086 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7090 access_attr_decl (gfc_statement st
)
7092 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7093 interface_type type
;
7095 gfc_symbol
*sym
, *dt_sym
;
7096 gfc_intrinsic_op op
;
7099 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7104 m
= gfc_match_generic_spec (&type
, name
, &op
);
7107 if (m
== MATCH_ERROR
)
7112 case INTERFACE_NAMELESS
:
7113 case INTERFACE_ABSTRACT
:
7116 case INTERFACE_GENERIC
:
7117 if (gfc_get_symbol (name
, NULL
, &sym
))
7120 if (!gfc_add_access (&sym
->attr
,
7122 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7126 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7127 && !gfc_add_access (&dt_sym
->attr
,
7129 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7135 case INTERFACE_INTRINSIC_OP
:
7136 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7138 gfc_intrinsic_op other_op
;
7140 gfc_current_ns
->operator_access
[op
] =
7141 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7143 /* Handle the case if there is another op with the same
7144 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7145 other_op
= gfc_equivalent_op (op
);
7147 if (other_op
!= INTRINSIC_NONE
)
7148 gfc_current_ns
->operator_access
[other_op
] =
7149 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7154 gfc_error ("Access specification of the %s operator at %C has "
7155 "already been specified", gfc_op2string (op
));
7161 case INTERFACE_USER_OP
:
7162 uop
= gfc_get_uop (name
);
7164 if (uop
->access
== ACCESS_UNKNOWN
)
7166 uop
->access
= (st
== ST_PUBLIC
)
7167 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7171 gfc_error ("Access specification of the .%s. operator at %C "
7172 "has already been specified", sym
->name
);
7179 if (gfc_match_char (',') == MATCH_NO
)
7183 if (gfc_match_eos () != MATCH_YES
)
7188 gfc_syntax_error (st
);
7196 gfc_match_protected (void)
7201 if (!gfc_current_ns
->proc_name
7202 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7204 gfc_error ("PROTECTED at %C only allowed in specification "
7205 "part of a module");
7210 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7213 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7218 if (gfc_match_eos () == MATCH_YES
)
7223 m
= gfc_match_symbol (&sym
, 0);
7227 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7239 if (gfc_match_eos () == MATCH_YES
)
7241 if (gfc_match_char (',') != MATCH_YES
)
7248 gfc_error ("Syntax error in PROTECTED statement at %C");
7253 /* The PRIVATE statement is a bit weird in that it can be an attribute
7254 declaration, but also works as a standalone statement inside of a
7255 type declaration or a module. */
7258 gfc_match_private (gfc_statement
*st
)
7261 if (gfc_match ("private") != MATCH_YES
)
7264 if (gfc_current_state () != COMP_MODULE
7265 && !(gfc_current_state () == COMP_DERIVED
7266 && gfc_state_stack
->previous
7267 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7268 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7269 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7270 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7272 gfc_error ("PRIVATE statement at %C is only allowed in the "
7273 "specification part of a module");
7277 if (gfc_current_state () == COMP_DERIVED
)
7279 if (gfc_match_eos () == MATCH_YES
)
7285 gfc_syntax_error (ST_PRIVATE
);
7289 if (gfc_match_eos () == MATCH_YES
)
7296 return access_attr_decl (ST_PRIVATE
);
7301 gfc_match_public (gfc_statement
*st
)
7304 if (gfc_match ("public") != MATCH_YES
)
7307 if (gfc_current_state () != COMP_MODULE
)
7309 gfc_error ("PUBLIC statement at %C is only allowed in the "
7310 "specification part of a module");
7314 if (gfc_match_eos () == MATCH_YES
)
7321 return access_attr_decl (ST_PUBLIC
);
7325 /* Workhorse for gfc_match_parameter. */
7335 m
= gfc_match_symbol (&sym
, 0);
7337 gfc_error ("Expected variable name at %C in PARAMETER statement");
7342 if (gfc_match_char ('=') == MATCH_NO
)
7344 gfc_error ("Expected = sign in PARAMETER statement at %C");
7348 m
= gfc_match_init_expr (&init
);
7350 gfc_error ("Expected expression at %C in PARAMETER statement");
7354 if (sym
->ts
.type
== BT_UNKNOWN
7355 && !gfc_set_default_type (sym
, 1, NULL
))
7361 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7362 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7370 gfc_error ("Initializing already initialized variable at %C");
7375 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7376 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7379 gfc_free_expr (init
);
7384 /* Match a parameter statement, with the weird syntax that these have. */
7387 gfc_match_parameter (void)
7391 if (gfc_match_char ('(') == MATCH_NO
)
7400 if (gfc_match (" )%t") == MATCH_YES
)
7403 if (gfc_match_char (',') != MATCH_YES
)
7405 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7415 /* Save statements have a special syntax. */
7418 gfc_match_save (void)
7420 char n
[GFC_MAX_SYMBOL_LEN
+1];
7425 if (gfc_match_eos () == MATCH_YES
)
7427 if (gfc_current_ns
->seen_save
)
7429 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7430 "follows previous SAVE statement"))
7434 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7438 if (gfc_current_ns
->save_all
)
7440 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7441 "blanket SAVE statement"))
7449 m
= gfc_match_symbol (&sym
, 0);
7453 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7454 &gfc_current_locus
))
7465 m
= gfc_match (" / %n /", &n
);
7466 if (m
== MATCH_ERROR
)
7471 c
= gfc_get_common (n
, 0);
7474 gfc_current_ns
->seen_save
= 1;
7477 if (gfc_match_eos () == MATCH_YES
)
7479 if (gfc_match_char (',') != MATCH_YES
)
7486 gfc_error ("Syntax error in SAVE statement at %C");
7492 gfc_match_value (void)
7497 /* This is not allowed within a BLOCK construct! */
7498 if (gfc_current_state () == COMP_BLOCK
)
7500 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7504 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7507 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7512 if (gfc_match_eos () == MATCH_YES
)
7517 m
= gfc_match_symbol (&sym
, 0);
7521 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7533 if (gfc_match_eos () == MATCH_YES
)
7535 if (gfc_match_char (',') != MATCH_YES
)
7542 gfc_error ("Syntax error in VALUE statement at %C");
7548 gfc_match_volatile (void)
7553 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7556 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7561 if (gfc_match_eos () == MATCH_YES
)
7566 /* VOLATILE is special because it can be added to host-associated
7567 symbols locally. Except for coarrays. */
7568 m
= gfc_match_symbol (&sym
, 1);
7572 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7573 for variable in a BLOCK which is defined outside of the BLOCK. */
7574 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7576 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7577 "%C, which is use-/host-associated", sym
->name
);
7580 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7592 if (gfc_match_eos () == MATCH_YES
)
7594 if (gfc_match_char (',') != MATCH_YES
)
7601 gfc_error ("Syntax error in VOLATILE statement at %C");
7607 gfc_match_asynchronous (void)
7612 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7615 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7620 if (gfc_match_eos () == MATCH_YES
)
7625 /* ASYNCHRONOUS is special because it can be added to host-associated
7627 m
= gfc_match_symbol (&sym
, 1);
7631 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7643 if (gfc_match_eos () == MATCH_YES
)
7645 if (gfc_match_char (',') != MATCH_YES
)
7652 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7657 /* Match a module procedure statement in a submodule. */
7660 gfc_match_submod_proc (void)
7662 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7663 gfc_symbol
*sym
, *fsym
;
7665 gfc_formal_arglist
*formal
, *head
, *tail
;
7667 if (gfc_current_state () != COMP_CONTAINS
7668 || !(gfc_state_stack
->previous
7669 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7672 m
= gfc_match (" module% procedure% %n", name
);
7676 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7680 if (get_proc_name (name
, &sym
, false))
7683 /* Make sure that the result field is appropriately filled, even though
7684 the result symbol will be replaced later on. */
7685 if (sym
->ts
.interface
&& sym
->ts
.interface
->attr
.function
)
7687 if (sym
->ts
.interface
->result
7688 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7689 sym
->result
= sym
->ts
.interface
->result
;
7694 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7695 the symbol existed before. */
7696 sym
->declared_at
= gfc_current_locus
;
7698 if (!sym
->attr
.module_procedure
)
7701 /* Signal match_end to expect "end procedure". */
7702 sym
->abr_modproc_decl
= 1;
7704 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7705 sym
->attr
.if_source
= IFSRC_DECL
;
7707 gfc_new_block
= sym
;
7709 /* Make a new formal arglist with the symbols in the procedure
7712 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7714 if (formal
== sym
->formal
)
7715 head
= tail
= gfc_get_formal_arglist ();
7718 tail
->next
= gfc_get_formal_arglist ();
7722 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7726 gfc_set_sym_referenced (fsym
);
7729 /* The dummy symbols get cleaned up, when the formal_namespace of the
7730 interface declaration is cleared. This allows us to add the
7731 explicit interface as is done for other type of procedure. */
7732 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7733 &gfc_current_locus
))
7736 if (gfc_match_eos () != MATCH_YES
)
7738 gfc_syntax_error (ST_MODULE_PROC
);
7745 gfc_free_formal_arglist (head
);
7750 /* Match a module procedure statement. Note that we have to modify
7751 symbols in the parent's namespace because the current one was there
7752 to receive symbols that are in an interface's formal argument list. */
7755 gfc_match_modproc (void)
7757 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7761 gfc_namespace
*module_ns
;
7762 gfc_interface
*old_interface_head
, *interface
;
7764 if (gfc_state_stack
->state
!= COMP_INTERFACE
7765 || gfc_state_stack
->previous
== NULL
7766 || current_interface
.type
== INTERFACE_NAMELESS
7767 || current_interface
.type
== INTERFACE_ABSTRACT
)
7769 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7774 module_ns
= gfc_current_ns
->parent
;
7775 for (; module_ns
; module_ns
= module_ns
->parent
)
7776 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7777 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7778 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7779 && !module_ns
->proc_name
->attr
.contained
))
7782 if (module_ns
== NULL
)
7785 /* Store the current state of the interface. We will need it if we
7786 end up with a syntax error and need to recover. */
7787 old_interface_head
= gfc_current_interface_head ();
7789 /* Check if the F2008 optional double colon appears. */
7790 gfc_gobble_whitespace ();
7791 old_locus
= gfc_current_locus
;
7792 if (gfc_match ("::") == MATCH_YES
)
7794 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7795 "MODULE PROCEDURE statement at %L", &old_locus
))
7799 gfc_current_locus
= old_locus
;
7804 old_locus
= gfc_current_locus
;
7806 m
= gfc_match_name (name
);
7812 /* Check for syntax error before starting to add symbols to the
7813 current namespace. */
7814 if (gfc_match_eos () == MATCH_YES
)
7817 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7820 /* Now we're sure the syntax is valid, we process this item
7822 if (gfc_get_symbol (name
, module_ns
, &sym
))
7825 if (sym
->attr
.intrinsic
)
7827 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7828 "PROCEDURE", &old_locus
);
7832 if (sym
->attr
.proc
!= PROC_MODULE
7833 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7836 if (!gfc_add_interface (sym
))
7839 sym
->attr
.mod_proc
= 1;
7840 sym
->declared_at
= old_locus
;
7849 /* Restore the previous state of the interface. */
7850 interface
= gfc_current_interface_head ();
7851 gfc_set_current_interface_head (old_interface_head
);
7853 /* Free the new interfaces. */
7854 while (interface
!= old_interface_head
)
7856 gfc_interface
*i
= interface
->next
;
7861 /* And issue a syntax error. */
7862 gfc_syntax_error (ST_MODULE_PROC
);
7867 /* Check a derived type that is being extended. */
7870 check_extended_derived_type (char *name
)
7872 gfc_symbol
*extended
;
7874 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7876 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7880 extended
= gfc_find_dt_in_generic (extended
);
7885 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7889 if (extended
->attr
.flavor
!= FL_DERIVED
)
7891 gfc_error ("%qs in EXTENDS expression at %C is not a "
7892 "derived type", name
);
7896 if (extended
->attr
.is_bind_c
)
7898 gfc_error ("%qs cannot be extended at %C because it "
7899 "is BIND(C)", extended
->name
);
7903 if (extended
->attr
.sequence
)
7905 gfc_error ("%qs cannot be extended at %C because it "
7906 "is a SEQUENCE type", extended
->name
);
7914 /* Match the optional attribute specifiers for a type declaration.
7915 Return MATCH_ERROR if an error is encountered in one of the handled
7916 attributes (public, private, bind(c)), MATCH_NO if what's found is
7917 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7918 checking on attribute conflicts needs to be done. */
7921 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7923 /* See if the derived type is marked as private. */
7924 if (gfc_match (" , private") == MATCH_YES
)
7926 if (gfc_current_state () != COMP_MODULE
)
7928 gfc_error ("Derived type at %C can only be PRIVATE in the "
7929 "specification part of a module");
7933 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7936 else if (gfc_match (" , public") == MATCH_YES
)
7938 if (gfc_current_state () != COMP_MODULE
)
7940 gfc_error ("Derived type at %C can only be PUBLIC in the "
7941 "specification part of a module");
7945 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7948 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7950 /* If the type is defined to be bind(c) it then needs to make
7951 sure that all fields are interoperable. This will
7952 need to be a semantic check on the finished derived type.
7953 See 15.2.3 (lines 9-12) of F2003 draft. */
7954 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7957 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7959 else if (gfc_match (" , abstract") == MATCH_YES
)
7961 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7964 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7967 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7969 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7975 /* If we get here, something matched. */
7980 /* Match the beginning of a derived type declaration. If a type name
7981 was the result of a function, then it is possible to have a symbol
7982 already to be known as a derived type yet have no components. */
7985 gfc_match_derived_decl (void)
7987 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7988 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7989 symbol_attribute attr
;
7990 gfc_symbol
*sym
, *gensym
;
7991 gfc_symbol
*extended
;
7993 match is_type_attr_spec
= MATCH_NO
;
7994 bool seen_attr
= false;
7995 gfc_interface
*intr
= NULL
, *head
;
7997 if (gfc_current_state () == COMP_DERIVED
)
8002 gfc_clear_attr (&attr
);
8007 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
8008 if (is_type_attr_spec
== MATCH_ERROR
)
8010 if (is_type_attr_spec
== MATCH_YES
)
8012 } while (is_type_attr_spec
== MATCH_YES
);
8014 /* Deal with derived type extensions. The extension attribute has
8015 been added to 'attr' but now the parent type must be found and
8018 extended
= check_extended_derived_type (parent
);
8020 if (parent
[0] && !extended
)
8023 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
8025 gfc_error ("Expected :: in TYPE definition at %C");
8029 m
= gfc_match (" %n%t", name
);
8033 /* Make sure the name is not the name of an intrinsic type. */
8034 if (gfc_is_intrinsic_typename (name
))
8036 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8041 if (gfc_get_symbol (name
, NULL
, &gensym
))
8044 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8046 gfc_error ("Derived type name %qs at %C already has a basic type "
8047 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8051 if (!gensym
->attr
.generic
8052 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8055 if (!gensym
->attr
.function
8056 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8059 sym
= gfc_find_dt_in_generic (gensym
);
8061 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8063 gfc_error ("Derived type definition of %qs at %C has already been "
8064 "defined", sym
->name
);
8070 /* Use upper case to save the actual derived-type symbol. */
8071 gfc_get_symbol (gfc_get_string ("%c%s",
8072 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
8073 &gensym
->name
[1]), NULL
, &sym
);
8074 sym
->name
= gfc_get_string (gensym
->name
);
8075 head
= gensym
->generic
;
8076 intr
= gfc_get_interface ();
8078 intr
->where
= gfc_current_locus
;
8079 intr
->sym
->declared_at
= gfc_current_locus
;
8081 gensym
->generic
= intr
;
8082 gensym
->attr
.if_source
= IFSRC_DECL
;
8085 /* The symbol may already have the derived attribute without the
8086 components. The ways this can happen is via a function
8087 definition, an INTRINSIC statement or a subtype in another
8088 derived type that is a pointer. The first part of the AND clause
8089 is true if the symbol is not the return value of a function. */
8090 if (sym
->attr
.flavor
!= FL_DERIVED
8091 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8094 if (attr
.access
!= ACCESS_UNKNOWN
8095 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8097 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8098 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8099 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8103 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8104 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8105 gensym
->attr
.access
= sym
->attr
.access
;
8107 /* See if the derived type was labeled as bind(c). */
8108 if (attr
.is_bind_c
!= 0)
8109 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8111 /* Construct the f2k_derived namespace if it is not yet there. */
8112 if (!sym
->f2k_derived
)
8113 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8115 if (extended
&& !sym
->components
)
8119 /* Add the extended derived type as the first component. */
8120 gfc_add_component (sym
, parent
, &p
);
8122 gfc_set_sym_referenced (extended
);
8124 p
->ts
.type
= BT_DERIVED
;
8125 p
->ts
.u
.derived
= extended
;
8126 p
->initializer
= gfc_default_initializer (&p
->ts
);
8128 /* Set extension level. */
8129 if (extended
->attr
.extension
== 255)
8131 /* Since the extension field is 8 bit wide, we can only have
8132 up to 255 extension levels. */
8133 gfc_error ("Maximum extension level reached with type %qs at %L",
8134 extended
->name
, &extended
->declared_at
);
8137 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8139 /* Provide the links between the extended type and its extension. */
8140 if (!extended
->f2k_derived
)
8141 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8144 if (!sym
->hash_value
)
8145 /* Set the hash for the compound name for this type. */
8146 sym
->hash_value
= gfc_hash_value (sym
);
8148 /* Take over the ABSTRACT attribute. */
8149 sym
->attr
.abstract
= attr
.abstract
;
8151 gfc_new_block
= sym
;
8157 /* Cray Pointees can be declared as:
8158 pointer (ipt, a (n,m,...,*)) */
8161 gfc_mod_pointee_as (gfc_array_spec
*as
)
8163 as
->cray_pointee
= true; /* This will be useful to know later. */
8164 if (as
->type
== AS_ASSUMED_SIZE
)
8165 as
->cp_was_assumed
= true;
8166 else if (as
->type
== AS_ASSUMED_SHAPE
)
8168 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8175 /* Match the enum definition statement, here we are trying to match
8176 the first line of enum definition statement.
8177 Returns MATCH_YES if match is found. */
8180 gfc_match_enum (void)
8184 m
= gfc_match_eos ();
8188 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8195 /* Returns an initializer whose value is one higher than the value of the
8196 LAST_INITIALIZER argument. If the argument is NULL, the
8197 initializers value will be set to zero. The initializer's kind
8198 will be set to gfc_c_int_kind.
8200 If -fshort-enums is given, the appropriate kind will be selected
8201 later after all enumerators have been parsed. A warning is issued
8202 here if an initializer exceeds gfc_c_int_kind. */
8205 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8208 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8210 mpz_init (result
->value
.integer
);
8212 if (last_initializer
!= NULL
)
8214 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8215 result
->where
= last_initializer
->where
;
8217 if (gfc_check_integer_range (result
->value
.integer
,
8218 gfc_c_int_kind
) != ARITH_OK
)
8220 gfc_error ("Enumerator exceeds the C integer type at %C");
8226 /* Control comes here, if it's the very first enumerator and no
8227 initializer has been given. It will be initialized to zero. */
8228 mpz_set_si (result
->value
.integer
, 0);
8235 /* Match a variable name with an optional initializer. When this
8236 subroutine is called, a variable is expected to be parsed next.
8237 Depending on what is happening at the moment, updates either the
8238 symbol table or the current interface. */
8241 enumerator_decl (void)
8243 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8244 gfc_expr
*initializer
;
8245 gfc_array_spec
*as
= NULL
;
8253 old_locus
= gfc_current_locus
;
8255 /* When we get here, we've just matched a list of attributes and
8256 maybe a type and a double colon. The next thing we expect to see
8257 is the name of the symbol. */
8258 m
= gfc_match_name (name
);
8262 var_locus
= gfc_current_locus
;
8264 /* OK, we've successfully matched the declaration. Now put the
8265 symbol in the current namespace. If we fail to create the symbol,
8267 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8273 /* The double colon must be present in order to have initializers.
8274 Otherwise the statement is ambiguous with an assignment statement. */
8277 if (gfc_match_char ('=') == MATCH_YES
)
8279 m
= gfc_match_init_expr (&initializer
);
8282 gfc_error ("Expected an initialization expression at %C");
8291 /* If we do not have an initializer, the initialization value of the
8292 previous enumerator (stored in last_initializer) is incremented
8293 by 1 and is used to initialize the current enumerator. */
8294 if (initializer
== NULL
)
8295 initializer
= enum_initializer (last_initializer
, old_locus
);
8297 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8299 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8305 /* Store this current initializer, for the next enumerator variable
8306 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8307 use last_initializer below. */
8308 last_initializer
= initializer
;
8309 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8311 /* Maintain enumerator history. */
8312 gfc_find_symbol (name
, NULL
, 0, &sym
);
8313 create_enum_history (sym
, last_initializer
);
8315 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8318 /* Free stuff up and return. */
8319 gfc_free_expr (initializer
);
8325 /* Match the enumerator definition statement. */
8328 gfc_match_enumerator_def (void)
8333 gfc_clear_ts (¤t_ts
);
8335 m
= gfc_match (" enumerator");
8339 m
= gfc_match (" :: ");
8340 if (m
== MATCH_ERROR
)
8343 colon_seen
= (m
== MATCH_YES
);
8345 if (gfc_current_state () != COMP_ENUM
)
8347 gfc_error ("ENUM definition statement expected before %C");
8348 gfc_free_enum_history ();
8352 (¤t_ts
)->type
= BT_INTEGER
;
8353 (¤t_ts
)->kind
= gfc_c_int_kind
;
8355 gfc_clear_attr (¤t_attr
);
8356 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8365 m
= enumerator_decl ();
8366 if (m
== MATCH_ERROR
)
8368 gfc_free_enum_history ();
8374 if (gfc_match_eos () == MATCH_YES
)
8376 if (gfc_match_char (',') != MATCH_YES
)
8380 if (gfc_current_state () == COMP_ENUM
)
8382 gfc_free_enum_history ();
8383 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8388 gfc_free_array_spec (current_as
);
8395 /* Match binding attributes. */
8398 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8400 bool found_passing
= false;
8401 bool seen_ptr
= false;
8402 match m
= MATCH_YES
;
8404 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8405 this case the defaults are in there. */
8406 ba
->access
= ACCESS_UNKNOWN
;
8407 ba
->pass_arg
= NULL
;
8408 ba
->pass_arg_num
= 0;
8410 ba
->non_overridable
= 0;
8414 /* If we find a comma, we believe there are binding attributes. */
8415 m
= gfc_match_char (',');
8421 /* Access specifier. */
8423 m
= gfc_match (" public");
8424 if (m
== MATCH_ERROR
)
8428 if (ba
->access
!= ACCESS_UNKNOWN
)
8430 gfc_error ("Duplicate access-specifier at %C");
8434 ba
->access
= ACCESS_PUBLIC
;
8438 m
= gfc_match (" private");
8439 if (m
== MATCH_ERROR
)
8443 if (ba
->access
!= ACCESS_UNKNOWN
)
8445 gfc_error ("Duplicate access-specifier at %C");
8449 ba
->access
= ACCESS_PRIVATE
;
8453 /* If inside GENERIC, the following is not allowed. */
8458 m
= gfc_match (" nopass");
8459 if (m
== MATCH_ERROR
)
8465 gfc_error ("Binding attributes already specify passing,"
8466 " illegal NOPASS at %C");
8470 found_passing
= true;
8475 /* PASS possibly including argument. */
8476 m
= gfc_match (" pass");
8477 if (m
== MATCH_ERROR
)
8481 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8485 gfc_error ("Binding attributes already specify passing,"
8486 " illegal PASS at %C");
8490 m
= gfc_match (" ( %n )", arg
);
8491 if (m
== MATCH_ERROR
)
8494 ba
->pass_arg
= gfc_get_string (arg
);
8495 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8497 found_passing
= true;
8505 m
= gfc_match (" pointer");
8506 if (m
== MATCH_ERROR
)
8512 gfc_error ("Duplicate POINTER attribute at %C");
8522 /* NON_OVERRIDABLE flag. */
8523 m
= gfc_match (" non_overridable");
8524 if (m
== MATCH_ERROR
)
8528 if (ba
->non_overridable
)
8530 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8534 ba
->non_overridable
= 1;
8538 /* DEFERRED flag. */
8539 m
= gfc_match (" deferred");
8540 if (m
== MATCH_ERROR
)
8546 gfc_error ("Duplicate DEFERRED at %C");
8557 /* Nothing matching found. */
8559 gfc_error ("Expected access-specifier at %C");
8561 gfc_error ("Expected binding attribute at %C");
8564 while (gfc_match_char (',') == MATCH_YES
);
8566 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8567 if (ba
->non_overridable
&& ba
->deferred
)
8569 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8576 if (ba
->access
== ACCESS_UNKNOWN
)
8577 ba
->access
= gfc_typebound_default_access
;
8579 if (ppc
&& !seen_ptr
)
8581 gfc_error ("POINTER attribute is required for procedure pointer component"
8593 /* Match a PROCEDURE specific binding inside a derived type. */
8596 match_procedure_in_type (void)
8598 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8599 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8600 char* target
= NULL
, *ifc
= NULL
;
8601 gfc_typebound_proc tb
;
8610 /* Check current state. */
8611 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8612 block
= gfc_state_stack
->previous
->sym
;
8615 /* Try to match PROCEDURE(interface). */
8616 if (gfc_match (" (") == MATCH_YES
)
8618 m
= gfc_match_name (target_buf
);
8619 if (m
== MATCH_ERROR
)
8623 gfc_error ("Interface-name expected after %<(%> at %C");
8627 if (gfc_match (" )") != MATCH_YES
)
8629 gfc_error ("%<)%> expected at %C");
8636 /* Construct the data structure. */
8637 memset (&tb
, 0, sizeof (tb
));
8638 tb
.where
= gfc_current_locus
;
8640 /* Match binding attributes. */
8641 m
= match_binding_attributes (&tb
, false, false);
8642 if (m
== MATCH_ERROR
)
8644 seen_attrs
= (m
== MATCH_YES
);
8646 /* Check that attribute DEFERRED is given if an interface is specified. */
8647 if (tb
.deferred
&& !ifc
)
8649 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8652 if (ifc
&& !tb
.deferred
)
8654 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8658 /* Match the colons. */
8659 m
= gfc_match (" ::");
8660 if (m
== MATCH_ERROR
)
8662 seen_colons
= (m
== MATCH_YES
);
8663 if (seen_attrs
&& !seen_colons
)
8665 gfc_error ("Expected %<::%> after binding-attributes at %C");
8669 /* Match the binding names. */
8672 m
= gfc_match_name (name
);
8673 if (m
== MATCH_ERROR
)
8677 gfc_error ("Expected binding name at %C");
8681 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8684 /* Try to match the '=> target', if it's there. */
8686 m
= gfc_match (" =>");
8687 if (m
== MATCH_ERROR
)
8693 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8699 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8704 m
= gfc_match_name (target_buf
);
8705 if (m
== MATCH_ERROR
)
8709 gfc_error ("Expected binding target after %<=>%> at %C");
8712 target
= target_buf
;
8715 /* If no target was found, it has the same name as the binding. */
8719 /* Get the namespace to insert the symbols into. */
8720 ns
= block
->f2k_derived
;
8723 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8724 if (tb
.deferred
&& !block
->attr
.abstract
)
8726 gfc_error ("Type %qs containing DEFERRED binding at %C "
8727 "is not ABSTRACT", block
->name
);
8731 /* See if we already have a binding with this name in the symtree which
8732 would be an error. If a GENERIC already targeted this binding, it may
8733 be already there but then typebound is still NULL. */
8734 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8735 if (stree
&& stree
->n
.tb
)
8737 gfc_error ("There is already a procedure with binding name %qs for "
8738 "the derived type %qs at %C", name
, block
->name
);
8742 /* Insert it and set attributes. */
8746 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8749 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8751 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8754 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8756 if (gfc_match_eos () == MATCH_YES
)
8758 if (gfc_match_char (',') != MATCH_YES
)
8763 gfc_error ("Syntax error in PROCEDURE statement at %C");
8768 /* Match a GENERIC procedure binding inside a derived type. */
8771 gfc_match_generic (void)
8773 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8774 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8776 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8777 gfc_typebound_proc
* tb
;
8779 interface_type op_type
;
8780 gfc_intrinsic_op op
;
8783 /* Check current state. */
8784 if (gfc_current_state () == COMP_DERIVED
)
8786 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8789 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8791 block
= gfc_state_stack
->previous
->sym
;
8792 ns
= block
->f2k_derived
;
8793 gcc_assert (block
&& ns
);
8795 memset (&tbattr
, 0, sizeof (tbattr
));
8796 tbattr
.where
= gfc_current_locus
;
8798 /* See if we get an access-specifier. */
8799 m
= match_binding_attributes (&tbattr
, true, false);
8800 if (m
== MATCH_ERROR
)
8803 /* Now the colons, those are required. */
8804 if (gfc_match (" ::") != MATCH_YES
)
8806 gfc_error ("Expected %<::%> at %C");
8810 /* Match the binding name; depending on type (operator / generic) format
8811 it for future error messages into bind_name. */
8813 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8814 if (m
== MATCH_ERROR
)
8818 gfc_error ("Expected generic name or operator descriptor at %C");
8824 case INTERFACE_GENERIC
:
8825 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8828 case INTERFACE_USER_OP
:
8829 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8832 case INTERFACE_INTRINSIC_OP
:
8833 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8834 gfc_op2string (op
));
8837 case INTERFACE_NAMELESS
:
8838 gfc_error ("Malformed GENERIC statement at %C");
8846 /* Match the required =>. */
8847 if (gfc_match (" =>") != MATCH_YES
)
8849 gfc_error ("Expected %<=>%> at %C");
8853 /* Try to find existing GENERIC binding with this name / for this operator;
8854 if there is something, check that it is another GENERIC and then extend
8855 it rather than building a new node. Otherwise, create it and put it
8856 at the right position. */
8860 case INTERFACE_USER_OP
:
8861 case INTERFACE_GENERIC
:
8863 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8866 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8878 case INTERFACE_INTRINSIC_OP
:
8888 if (!tb
->is_generic
)
8890 gcc_assert (op_type
== INTERFACE_GENERIC
);
8891 gfc_error ("There's already a non-generic procedure with binding name"
8892 " %qs for the derived type %qs at %C",
8893 bind_name
, block
->name
);
8897 if (tb
->access
!= tbattr
.access
)
8899 gfc_error ("Binding at %C must have the same access as already"
8900 " defined binding %qs", bind_name
);
8906 tb
= gfc_get_typebound_proc (NULL
);
8907 tb
->where
= gfc_current_locus
;
8908 tb
->access
= tbattr
.access
;
8910 tb
->u
.generic
= NULL
;
8914 case INTERFACE_GENERIC
:
8915 case INTERFACE_USER_OP
:
8917 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8920 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8928 case INTERFACE_INTRINSIC_OP
:
8937 /* Now, match all following names as specific targets. */
8940 gfc_symtree
* target_st
;
8941 gfc_tbp_generic
* target
;
8943 m
= gfc_match_name (name
);
8944 if (m
== MATCH_ERROR
)
8948 gfc_error ("Expected specific binding name at %C");
8952 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8954 /* See if this is a duplicate specification. */
8955 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8956 if (target_st
== target
->specific_st
)
8958 gfc_error ("%qs already defined as specific binding for the"
8959 " generic %qs at %C", name
, bind_name
);
8963 target
= gfc_get_tbp_generic ();
8964 target
->specific_st
= target_st
;
8965 target
->specific
= NULL
;
8966 target
->next
= tb
->u
.generic
;
8967 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8968 || (op_type
== INTERFACE_INTRINSIC_OP
));
8969 tb
->u
.generic
= target
;
8971 while (gfc_match (" ,") == MATCH_YES
);
8973 /* Here should be the end. */
8974 if (gfc_match_eos () != MATCH_YES
)
8976 gfc_error ("Junk after GENERIC binding at %C");
8987 /* Match a FINAL declaration inside a derived type. */
8990 gfc_match_final_decl (void)
8992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8995 gfc_namespace
* module_ns
;
8999 if (gfc_current_form
== FORM_FREE
)
9001 char c
= gfc_peek_ascii_char ();
9002 if (!gfc_is_whitespace (c
) && c
!= ':')
9006 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
9008 if (gfc_current_form
== FORM_FIXED
)
9011 gfc_error ("FINAL declaration at %C must be inside a derived type "
9012 "CONTAINS section");
9016 block
= gfc_state_stack
->previous
->sym
;
9019 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
9020 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
9022 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9023 " specification part of a MODULE");
9027 module_ns
= gfc_current_ns
;
9028 gcc_assert (module_ns
);
9029 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
9031 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9032 if (gfc_match (" ::") == MATCH_ERROR
)
9035 /* Match the sequence of procedure names. */
9042 if (first
&& gfc_match_eos () == MATCH_YES
)
9044 gfc_error ("Empty FINAL at %C");
9048 m
= gfc_match_name (name
);
9051 gfc_error ("Expected module procedure name at %C");
9054 else if (m
!= MATCH_YES
)
9057 if (gfc_match_eos () == MATCH_YES
)
9059 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9061 gfc_error ("Expected %<,%> at %C");
9065 if (gfc_get_symbol (name
, module_ns
, &sym
))
9067 gfc_error ("Unknown procedure name %qs at %C", name
);
9071 /* Mark the symbol as module procedure. */
9072 if (sym
->attr
.proc
!= PROC_MODULE
9073 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9076 /* Check if we already have this symbol in the list, this is an error. */
9077 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9078 if (f
->proc_sym
== sym
)
9080 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9085 /* Add this symbol to the list of finalizers. */
9086 gcc_assert (block
->f2k_derived
);
9088 f
= XCNEW (gfc_finalizer
);
9090 f
->proc_tree
= NULL
;
9091 f
->where
= gfc_current_locus
;
9092 f
->next
= block
->f2k_derived
->finalizers
;
9093 block
->f2k_derived
->finalizers
= f
;
9103 const ext_attr_t ext_attr_list
[] = {
9104 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9105 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9106 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9107 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9108 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9109 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9110 { NULL
, EXT_ATTR_LAST
, NULL
}
9113 /* Match a !GCC$ ATTRIBUTES statement of the form:
9114 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9115 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9117 TODO: We should support all GCC attributes using the same syntax for
9118 the attribute list, i.e. the list in C
9119 __attributes(( attribute-list ))
9121 !GCC$ ATTRIBUTES attribute-list ::
9122 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9125 As there is absolutely no risk of confusion, we should never return
9128 gfc_match_gcc_attributes (void)
9130 symbol_attribute attr
;
9131 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9136 gfc_clear_attr (&attr
);
9141 if (gfc_match_name (name
) != MATCH_YES
)
9144 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9145 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9148 if (id
== EXT_ATTR_LAST
)
9150 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9154 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9157 gfc_gobble_whitespace ();
9158 ch
= gfc_next_ascii_char ();
9161 /* This is the successful exit condition for the loop. */
9162 if (gfc_next_ascii_char () == ':')
9172 if (gfc_match_eos () == MATCH_YES
)
9177 m
= gfc_match_name (name
);
9181 if (find_special (name
, &sym
, true))
9184 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9186 if (gfc_match_eos () == MATCH_YES
)
9189 if (gfc_match_char (',') != MATCH_YES
)
9196 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");