1 /* Declaration statement matcher
2 Copyright (C) 2002-2014 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"
28 #include "constructor.h"
30 #include "stringpool.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
)
182 static match
var_element (gfc_data_variable
*);
184 /* Match a list of variables terminated by an iterator and a right
188 var_list (gfc_data_variable
*parent
)
190 gfc_data_variable
*tail
, var
;
193 m
= var_element (&var
);
194 if (m
== MATCH_ERROR
)
199 tail
= gfc_get_data_variable ();
206 if (gfc_match_char (',') != MATCH_YES
)
209 m
= gfc_match_iterator (&parent
->iter
, 1);
212 if (m
== MATCH_ERROR
)
215 m
= var_element (&var
);
216 if (m
== MATCH_ERROR
)
221 tail
->next
= gfc_get_data_variable ();
227 if (gfc_match_char (')') != MATCH_YES
)
232 gfc_syntax_error (ST_DATA
);
237 /* Match a single element in a data variable list, which can be a
238 variable-iterator list. */
241 var_element (gfc_data_variable
*new_var
)
246 memset (new_var
, 0, sizeof (gfc_data_variable
));
248 if (gfc_match_char ('(') == MATCH_YES
)
249 return var_list (new_var
);
251 m
= gfc_match_variable (&new_var
->expr
, 0);
255 sym
= new_var
->expr
->symtree
->n
.sym
;
257 /* Symbol should already have an associated type. */
258 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
261 if (!sym
->attr
.function
&& gfc_current_ns
->parent
262 && gfc_current_ns
->parent
== sym
->ns
)
264 gfc_error ("Host associated variable %qs may not be in the DATA "
265 "statement at %C", sym
->name
);
269 if (gfc_current_state () != COMP_BLOCK_DATA
270 && sym
->attr
.in_common
271 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
272 "common block variable '%s' in DATA statement at %C",
276 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
283 /* Match the top-level list of data variables. */
286 top_var_list (gfc_data
*d
)
288 gfc_data_variable var
, *tail
, *new_var
;
295 m
= var_element (&var
);
298 if (m
== MATCH_ERROR
)
301 new_var
= gfc_get_data_variable ();
307 tail
->next
= new_var
;
311 if (gfc_match_char ('/') == MATCH_YES
)
313 if (gfc_match_char (',') != MATCH_YES
)
320 gfc_syntax_error (ST_DATA
);
321 gfc_free_data_all (gfc_current_ns
);
327 match_data_constant (gfc_expr
**result
)
329 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
330 gfc_symbol
*sym
, *dt_sym
= NULL
;
335 m
= gfc_match_literal_constant (&expr
, 1);
342 if (m
== MATCH_ERROR
)
345 m
= gfc_match_null (result
);
349 old_loc
= gfc_current_locus
;
351 /* Should this be a structure component, try to match it
352 before matching a name. */
353 m
= gfc_match_rvalue (result
);
354 if (m
== MATCH_ERROR
)
357 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
359 if (!gfc_simplify_expr (*result
, 0))
363 else if (m
== MATCH_YES
)
364 gfc_free_expr (*result
);
366 gfc_current_locus
= old_loc
;
368 m
= gfc_match_name (name
);
372 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
375 if (sym
&& sym
->attr
.generic
)
376 dt_sym
= gfc_find_dt_in_generic (sym
);
379 || (sym
->attr
.flavor
!= FL_PARAMETER
380 && (!dt_sym
|| dt_sym
->attr
.flavor
!= FL_DERIVED
)))
382 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
386 else if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
)
387 return gfc_match_structure_constructor (dt_sym
, result
);
389 /* Check to see if the value is an initialization array expression. */
390 if (sym
->value
->expr_type
== EXPR_ARRAY
)
392 gfc_current_locus
= old_loc
;
394 m
= gfc_match_init_expr (result
);
395 if (m
== MATCH_ERROR
)
400 if (!gfc_simplify_expr (*result
, 0))
403 if ((*result
)->expr_type
== EXPR_CONSTANT
)
407 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
413 *result
= gfc_copy_expr (sym
->value
);
418 /* Match a list of values in a DATA statement. The leading '/' has
419 already been seen at this point. */
422 top_val_list (gfc_data
*data
)
424 gfc_data_value
*new_val
, *tail
;
432 m
= match_data_constant (&expr
);
435 if (m
== MATCH_ERROR
)
438 new_val
= gfc_get_data_value ();
439 mpz_init (new_val
->repeat
);
442 data
->value
= new_val
;
444 tail
->next
= new_val
;
448 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
451 mpz_set_ui (tail
->repeat
, 1);
455 mpz_set (tail
->repeat
, expr
->value
.integer
);
456 gfc_free_expr (expr
);
458 m
= match_data_constant (&tail
->expr
);
461 if (m
== MATCH_ERROR
)
465 if (gfc_match_char ('/') == MATCH_YES
)
467 if (gfc_match_char (',') == MATCH_NO
)
474 gfc_syntax_error (ST_DATA
);
475 gfc_free_data_all (gfc_current_ns
);
480 /* Matches an old style initialization. */
483 match_old_style_init (const char *name
)
490 /* Set up data structure to hold initializers. */
491 gfc_find_sym_tree (name
, NULL
, 0, &st
);
494 newdata
= gfc_get_data ();
495 newdata
->var
= gfc_get_data_variable ();
496 newdata
->var
->expr
= gfc_get_variable_expr (st
);
497 newdata
->where
= gfc_current_locus
;
499 /* Match initial value list. This also eats the terminal '/'. */
500 m
= top_val_list (newdata
);
509 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
513 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
515 /* Mark the variable as having appeared in a data statement. */
516 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
522 /* Chain in namespace list of DATA initializers. */
523 newdata
->next
= gfc_current_ns
->data
;
524 gfc_current_ns
->data
= newdata
;
530 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
531 we are matching a DATA statement and are therefore issuing an error
532 if we encounter something unexpected, if not, we're trying to match
533 an old-style initialization expression of the form INTEGER I /2/. */
536 gfc_match_data (void)
541 set_in_match_data (true);
545 new_data
= gfc_get_data ();
546 new_data
->where
= gfc_current_locus
;
548 m
= top_var_list (new_data
);
552 m
= top_val_list (new_data
);
556 new_data
->next
= gfc_current_ns
->data
;
557 gfc_current_ns
->data
= new_data
;
559 if (gfc_match_eos () == MATCH_YES
)
562 gfc_match_char (','); /* Optional comma */
565 set_in_match_data (false);
569 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
572 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
577 set_in_match_data (false);
578 gfc_free_data (new_data
);
583 /************************ Declaration statements *********************/
586 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
589 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
593 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
594 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
596 gfc_error ("The assumed-rank array at %C shall not have a codimension");
600 if (to
->rank
== 0 && from
->rank
> 0)
602 to
->rank
= from
->rank
;
603 to
->type
= from
->type
;
604 to
->cray_pointee
= from
->cray_pointee
;
605 to
->cp_was_assumed
= from
->cp_was_assumed
;
607 for (i
= 0; i
< to
->corank
; i
++)
609 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
610 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
612 for (i
= 0; i
< from
->rank
; i
++)
616 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
617 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
621 to
->lower
[i
] = from
->lower
[i
];
622 to
->upper
[i
] = from
->upper
[i
];
626 else if (to
->corank
== 0 && from
->corank
> 0)
628 to
->corank
= from
->corank
;
629 to
->cotype
= from
->cotype
;
631 for (i
= 0; i
< from
->corank
; i
++)
635 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
636 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
640 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
641 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
650 /* Match an intent specification. Since this can only happen after an
651 INTENT word, a legal intent-spec must follow. */
654 match_intent_spec (void)
657 if (gfc_match (" ( in out )") == MATCH_YES
)
659 if (gfc_match (" ( in )") == MATCH_YES
)
661 if (gfc_match (" ( out )") == MATCH_YES
)
664 gfc_error ("Bad INTENT specification at %C");
665 return INTENT_UNKNOWN
;
669 /* Matches a character length specification, which is either a
670 specification expression, '*', or ':'. */
673 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
680 if (gfc_match_char ('*') == MATCH_YES
)
683 if (gfc_match_char (':') == MATCH_YES
)
685 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type "
694 m
= gfc_match_expr (expr
);
697 && !gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
700 if (m
== MATCH_YES
&& (*expr
)->expr_type
== EXPR_FUNCTION
)
702 if ((*expr
)->value
.function
.actual
703 && (*expr
)->value
.function
.actual
->expr
->symtree
)
706 e
= (*expr
)->value
.function
.actual
->expr
;
707 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
708 && e
->expr_type
== EXPR_VARIABLE
)
710 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
712 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
713 && e
->symtree
->n
.sym
->ts
.u
.cl
714 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->ts
.type
== BT_UNKNOWN
)
722 gfc_error ("Conflict in attributes of function argument at %C");
727 /* A character length is a '*' followed by a literal integer or a
728 char_len_param_value in parenthesis. */
731 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
737 m
= gfc_match_char ('*');
741 m
= gfc_match_small_literal_int (&length
, NULL
);
742 if (m
== MATCH_ERROR
)
747 if (obsolescent_check
748 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
750 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
754 if (gfc_match_char ('(') == MATCH_NO
)
757 m
= char_len_param_value (expr
, deferred
);
758 if (m
!= MATCH_YES
&& gfc_matching_function
)
764 if (m
== MATCH_ERROR
)
769 if (gfc_match_char (')') == MATCH_NO
)
771 gfc_free_expr (*expr
);
779 gfc_error ("Syntax error in character length specification at %C");
784 /* Special subroutine for finding a symbol. Check if the name is found
785 in the current name space. If not, and we're compiling a function or
786 subroutine and the parent compilation unit is an interface, then check
787 to see if the name we've been given is the name of the interface
788 (located in another namespace). */
791 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
797 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
800 *result
= st
? st
->n
.sym
: NULL
;
804 if (gfc_current_state () != COMP_SUBROUTINE
805 && gfc_current_state () != COMP_FUNCTION
)
808 s
= gfc_state_stack
->previous
;
812 if (s
->state
!= COMP_INTERFACE
)
815 goto end
; /* Nameless interface. */
817 if (strcmp (name
, s
->sym
->name
) == 0)
828 /* Special subroutine for getting a symbol node associated with a
829 procedure name, used in SUBROUTINE and FUNCTION statements. The
830 symbol is created in the parent using with symtree node in the
831 child unit pointing to the symbol. If the current namespace has no
832 parent, then the symbol is just created in the current unit. */
835 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
841 /* Module functions have to be left in their own namespace because
842 they have potentially (almost certainly!) already been referenced.
843 In this sense, they are rather like external functions. This is
844 fixed up in resolve.c(resolve_entries), where the symbol name-
845 space is set to point to the master function, so that the fake
846 result mechanism can work. */
847 if (module_fcn_entry
)
849 /* Present if entry is declared to be a module procedure. */
850 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
853 rc
= gfc_get_symbol (name
, NULL
, result
);
854 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
855 && (*result
)->ts
.type
== BT_UNKNOWN
856 && sym
->attr
.flavor
== FL_UNKNOWN
)
857 /* Pick up the typespec for the entry, if declared in the function
858 body. Note that this symbol is FL_UNKNOWN because it will
859 only have appeared in a type declaration. The local symtree
860 is set to point to the module symbol and a unique symtree
861 to the local version. This latter ensures a correct clearing
864 /* If the ENTRY proceeds its specification, we need to ensure
865 that this does not raise a "has no IMPLICIT type" error. */
866 if (sym
->ts
.type
== BT_UNKNOWN
)
867 sym
->attr
.untyped
= 1;
869 (*result
)->ts
= sym
->ts
;
871 /* Put the symbol in the procedure namespace so that, should
872 the ENTRY precede its specification, the specification
874 (*result
)->ns
= gfc_current_ns
;
876 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
878 st
= gfc_get_unique_symtree (gfc_current_ns
);
883 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
890 if (sym
&& !sym
->gfc_new
&& gfc_current_state () != COMP_INTERFACE
)
892 /* Trap another encompassed procedure with the same name. All
893 these conditions are necessary to avoid picking up an entry
894 whose name clashes with that of the encompassing procedure;
895 this is handled using gsymbols to register unique,globally
897 if (sym
->attr
.flavor
!= 0
898 && sym
->attr
.proc
!= 0
899 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
900 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
901 gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L",
902 name
, &sym
->declared_at
);
904 /* Trap a procedure with a name the same as interface in the
905 encompassing scope. */
906 if (sym
->attr
.generic
!= 0
907 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
908 && !sym
->attr
.mod_proc
)
909 gfc_error_now_1 ("Name '%s' at %C is already defined"
910 " as a generic interface at %L",
911 name
, &sym
->declared_at
);
913 /* Trap declarations of attributes in encompassing scope. The
914 signature for this is that ts.kind is set. Legitimate
915 references only set ts.type. */
916 if (sym
->ts
.kind
!= 0
917 && !sym
->attr
.implicit_type
918 && sym
->attr
.proc
== 0
919 && gfc_current_ns
->parent
!= NULL
920 && sym
->attr
.access
== 0
921 && !module_fcn_entry
)
922 gfc_error_now_1 ("Procedure '%s' at %C has an explicit interface "
923 "and must not have attributes declared at %L",
924 name
, &sym
->declared_at
);
927 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
930 /* Module function entries will already have a symtree in
931 the current namespace but will need one at module level. */
932 if (module_fcn_entry
)
934 /* Present if entry is declared to be a module procedure. */
935 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
937 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
940 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
945 /* See if the procedure should be a module procedure. */
947 if (((sym
->ns
->proc_name
!= NULL
948 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
949 && sym
->attr
.proc
!= PROC_MODULE
)
950 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
951 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
958 /* Verify that the given symbol representing a parameter is C
959 interoperable, by checking to see if it was marked as such after
960 its declaration. If the given symbol is not interoperable, a
961 warning is reported, thus removing the need to return the status to
962 the calling function. The standard does not require the user use
963 one of the iso_c_binding named constants to declare an
964 interoperable parameter, but we can't be sure if the param is C
965 interop or not if the user doesn't. For example, integer(4) may be
966 legal Fortran, but doesn't have meaning in C. It may interop with
967 a number of the C types, which causes a problem because the
968 compiler can't know which one. This code is almost certainly not
969 portable, and the user will get what they deserve if the C type
970 across platforms isn't always interoperable with integer(4). If
971 the user had used something like integer(c_int) or integer(c_long),
972 the compiler could have automatically handled the varying sizes
976 gfc_verify_c_interop_param (gfc_symbol
*sym
)
978 int is_c_interop
= 0;
981 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
982 Don't repeat the checks here. */
983 if (sym
->attr
.implicit_type
)
986 /* For subroutines or functions that are passed to a BIND(C) procedure,
987 they're interoperable if they're BIND(C) and their params are all
989 if (sym
->attr
.flavor
== FL_PROCEDURE
)
991 if (sym
->attr
.is_bind_c
== 0)
993 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
994 "attribute to be C interoperable", sym
->name
,
995 &(sym
->declared_at
));
1000 if (sym
->attr
.is_c_interop
== 1)
1001 /* We've already checked this procedure; don't check it again. */
1004 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1009 /* See if we've stored a reference to a procedure that owns sym. */
1010 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1012 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1014 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1016 if (is_c_interop
!= 1)
1018 /* Make personalized messages to give better feedback. */
1019 if (sym
->ts
.type
== BT_DERIVED
)
1020 gfc_error ("Variable %qs at %L is a dummy argument to the "
1021 "BIND(C) procedure %qs but is not C interoperable "
1022 "because derived type %qs is not C interoperable",
1023 sym
->name
, &(sym
->declared_at
),
1024 sym
->ns
->proc_name
->name
,
1025 sym
->ts
.u
.derived
->name
);
1026 else if (sym
->ts
.type
== BT_CLASS
)
1027 gfc_error ("Variable %qs at %L is a dummy argument to the "
1028 "BIND(C) procedure %qs but is not C interoperable "
1029 "because it is polymorphic",
1030 sym
->name
, &(sym
->declared_at
),
1031 sym
->ns
->proc_name
->name
);
1032 else if (warn_c_binding_type
)
1033 gfc_warning (OPT_Wc_binding_type
,
1034 "Variable %qs at %L is a dummy argument of the "
1035 "BIND(C) procedure %qs but may not be C "
1037 sym
->name
, &(sym
->declared_at
),
1038 sym
->ns
->proc_name
->name
);
1041 /* Character strings are only C interoperable if they have a
1043 if (sym
->ts
.type
== BT_CHARACTER
)
1045 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1046 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1047 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1049 gfc_error ("Character argument %qs at %L "
1050 "must be length 1 because "
1051 "procedure %qs is BIND(C)",
1052 sym
->name
, &sym
->declared_at
,
1053 sym
->ns
->proc_name
->name
);
1058 /* We have to make sure that any param to a bind(c) routine does
1059 not have the allocatable, pointer, or optional attributes,
1060 according to J3/04-007, section 5.1. */
1061 if (sym
->attr
.allocatable
== 1
1062 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable '%s' at %L with "
1063 "ALLOCATABLE attribute in procedure '%s' "
1064 "with BIND(C)", sym
->name
,
1065 &(sym
->declared_at
),
1066 sym
->ns
->proc_name
->name
))
1069 if (sym
->attr
.pointer
== 1
1070 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable '%s' at %L with "
1071 "POINTER attribute in procedure '%s' "
1072 "with BIND(C)", sym
->name
,
1073 &(sym
->declared_at
),
1074 sym
->ns
->proc_name
->name
))
1077 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1079 gfc_error ("Scalar variable %qs at %L with POINTER or "
1080 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1081 " supported", sym
->name
, &(sym
->declared_at
),
1082 sym
->ns
->proc_name
->name
);
1086 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1088 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1089 "and the VALUE attribute because procedure %qs "
1090 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1091 sym
->ns
->proc_name
->name
);
1094 else if (sym
->attr
.optional
== 1
1095 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable '%s' "
1096 "at %L with OPTIONAL attribute in "
1097 "procedure '%s' which is BIND(C)",
1098 sym
->name
, &(sym
->declared_at
),
1099 sym
->ns
->proc_name
->name
))
1102 /* Make sure that if it has the dimension attribute, that it is
1103 either assumed size or explicit shape. Deferred shape is already
1104 covered by the pointer/allocatable attribute. */
1105 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1106 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array '%s' "
1107 "at %L as dummy argument to the BIND(C) "
1108 "procedure '%s' at %L", sym
->name
,
1109 &(sym
->declared_at
),
1110 sym
->ns
->proc_name
->name
,
1111 &(sym
->ns
->proc_name
->declared_at
)))
1121 /* Function called by variable_decl() that adds a name to the symbol table. */
1124 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1125 gfc_array_spec
**as
, locus
*var_locus
)
1127 symbol_attribute attr
;
1130 if (gfc_get_symbol (name
, NULL
, &sym
))
1133 /* Start updating the symbol table. Add basic type attribute if present. */
1134 if (current_ts
.type
!= BT_UNKNOWN
1135 && (sym
->attr
.implicit_type
== 0
1136 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1137 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1140 if (sym
->ts
.type
== BT_CHARACTER
)
1143 sym
->ts
.deferred
= cl_deferred
;
1146 /* Add dimension attribute if present. */
1147 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1151 /* Add attribute to symbol. The copy is so that we can reset the
1152 dimension attribute. */
1153 attr
= current_attr
;
1155 attr
.codimension
= 0;
1157 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1160 /* Finish any work that may need to be done for the binding label,
1161 if it's a bind(c). The bind(c) attr is found before the symbol
1162 is made, and before the symbol name (for data decls), so the
1163 current_ts is holding the binding label, or nothing if the
1164 name= attr wasn't given. Therefore, test here if we're dealing
1165 with a bind(c) and make sure the binding label is set correctly. */
1166 if (sym
->attr
.is_bind_c
== 1)
1168 if (!sym
->binding_label
)
1170 /* Set the binding label and verify that if a NAME= was specified
1171 then only one identifier was in the entity-decl-list. */
1172 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1173 num_idents_on_line
))
1178 /* See if we know we're in a common block, and if it's a bind(c)
1179 common then we need to make sure we're an interoperable type. */
1180 if (sym
->attr
.in_common
== 1)
1182 /* Test the common block object. */
1183 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1184 && sym
->ts
.is_c_interop
!= 1)
1186 gfc_error_now ("Variable %qs in common block %qs at %C "
1187 "must be declared with a C interoperable "
1188 "kind since common block %qs is BIND(C)",
1189 sym
->name
, sym
->common_block
->name
,
1190 sym
->common_block
->name
);
1195 sym
->attr
.implied_index
= 0;
1197 if (sym
->ts
.type
== BT_CLASS
)
1198 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1204 /* Set character constant to the given length. The constant will be padded or
1205 truncated. If we're inside an array constructor without a typespec, we
1206 additionally check that all elements have the same length; check_len -1
1207 means no checking. */
1210 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1215 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1216 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1218 slen
= expr
->value
.character
.length
;
1221 s
= gfc_get_wide_string (len
+ 1);
1222 memcpy (s
, expr
->value
.character
.string
,
1223 MIN (len
, slen
) * sizeof (gfc_char_t
));
1225 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1227 if (warn_character_truncation
&& slen
> len
)
1228 gfc_warning_now (OPT_Wcharacter_truncation
,
1229 "CHARACTER expression at %L is being truncated "
1230 "(%d/%d)", &expr
->where
, slen
, len
);
1232 /* Apply the standard by 'hand' otherwise it gets cleared for
1234 if (check_len
!= -1 && slen
!= check_len
1235 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1236 gfc_error_now ("The CHARACTER elements of the array constructor "
1237 "at %L must have the same length (%d/%d)",
1238 &expr
->where
, slen
, check_len
);
1241 free (expr
->value
.character
.string
);
1242 expr
->value
.character
.string
= s
;
1243 expr
->value
.character
.length
= len
;
1248 /* Function to create and update the enumerator history
1249 using the information passed as arguments.
1250 Pointer "max_enum" is also updated, to point to
1251 enum history node containing largest initializer.
1253 SYM points to the symbol node of enumerator.
1254 INIT points to its enumerator value. */
1257 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1259 enumerator_history
*new_enum_history
;
1260 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1262 new_enum_history
= XCNEW (enumerator_history
);
1264 new_enum_history
->sym
= sym
;
1265 new_enum_history
->initializer
= init
;
1266 new_enum_history
->next
= NULL
;
1268 if (enum_history
== NULL
)
1270 enum_history
= new_enum_history
;
1271 max_enum
= enum_history
;
1275 new_enum_history
->next
= enum_history
;
1276 enum_history
= new_enum_history
;
1278 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1279 new_enum_history
->initializer
->value
.integer
) < 0)
1280 max_enum
= new_enum_history
;
1285 /* Function to free enum kind history. */
1288 gfc_free_enum_history (void)
1290 enumerator_history
*current
= enum_history
;
1291 enumerator_history
*next
;
1293 while (current
!= NULL
)
1295 next
= current
->next
;
1300 enum_history
= NULL
;
1304 /* Function called by variable_decl() that adds an initialization
1305 expression to a symbol. */
1308 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1310 symbol_attribute attr
;
1315 if (find_special (name
, &sym
, false))
1320 /* If this symbol is confirming an implicit parameter type,
1321 then an initialization expression is not allowed. */
1322 if (attr
.flavor
== FL_PARAMETER
1323 && sym
->value
!= NULL
1326 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1333 /* An initializer is required for PARAMETER declarations. */
1334 if (attr
.flavor
== FL_PARAMETER
)
1336 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1342 /* If a variable appears in a DATA block, it cannot have an
1346 gfc_error ("Variable %qs at %C with an initializer already "
1347 "appears in a DATA statement", sym
->name
);
1351 /* Check if the assignment can happen. This has to be put off
1352 until later for derived type variables and procedure pointers. */
1353 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1354 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1355 && !sym
->attr
.proc_pointer
1356 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1359 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1360 && init
->ts
.type
== BT_CHARACTER
)
1362 /* Update symbol character length according initializer. */
1363 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1366 if (sym
->ts
.u
.cl
->length
== NULL
)
1369 /* If there are multiple CHARACTER variables declared on the
1370 same line, we don't want them to share the same length. */
1371 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1373 if (sym
->attr
.flavor
== FL_PARAMETER
)
1375 if (init
->expr_type
== EXPR_CONSTANT
)
1377 clen
= init
->value
.character
.length
;
1378 sym
->ts
.u
.cl
->length
1379 = gfc_get_int_expr (gfc_default_integer_kind
,
1382 else if (init
->expr_type
== EXPR_ARRAY
)
1385 c
= gfc_constructor_first (init
->value
.constructor
);
1386 clen
= c
->expr
->value
.character
.length
;
1387 sym
->ts
.u
.cl
->length
1388 = gfc_get_int_expr (gfc_default_integer_kind
,
1391 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1392 sym
->ts
.u
.cl
->length
=
1393 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1396 /* Update initializer character length according symbol. */
1397 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1399 int len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1401 if (init
->expr_type
== EXPR_CONSTANT
)
1402 gfc_set_constant_character_len (len
, init
, -1);
1403 else if (init
->expr_type
== EXPR_ARRAY
)
1407 /* Build a new charlen to prevent simplification from
1408 deleting the length before it is resolved. */
1409 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1410 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1412 for (c
= gfc_constructor_first (init
->value
.constructor
);
1413 c
; c
= gfc_constructor_next (c
))
1414 gfc_set_constant_character_len (len
, c
->expr
, -1);
1419 /* If sym is implied-shape, set its upper bounds from init. */
1420 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1421 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1425 if (init
->rank
== 0)
1427 gfc_error ("Can't initialize implied-shape array at %L"
1428 " with scalar", &sym
->declared_at
);
1431 gcc_assert (sym
->as
->rank
== init
->rank
);
1433 /* Shape should be present, we get an initialization expression. */
1434 gcc_assert (init
->shape
);
1436 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1442 lower
= sym
->as
->lower
[dim
];
1443 if (lower
->expr_type
!= EXPR_CONSTANT
)
1445 gfc_error ("Non-constant lower bound in implied-shape"
1446 " declaration at %L", &lower
->where
);
1450 /* All dimensions must be without upper bound. */
1451 gcc_assert (!sym
->as
->upper
[dim
]);
1454 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1455 mpz_add (e
->value
.integer
,
1456 lower
->value
.integer
, init
->shape
[dim
]);
1457 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1458 sym
->as
->upper
[dim
] = e
;
1461 sym
->as
->type
= AS_EXPLICIT
;
1464 /* Need to check if the expression we initialized this
1465 to was one of the iso_c_binding named constants. If so,
1466 and we're a parameter (constant), let it be iso_c.
1468 integer(c_int), parameter :: my_int = c_int
1469 integer(my_int) :: my_int_2
1470 If we mark my_int as iso_c (since we can see it's value
1471 is equal to one of the named constants), then my_int_2
1472 will be considered C interoperable. */
1473 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1475 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1476 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1477 /* attr bits needed for module files. */
1478 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1479 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1480 if (init
->ts
.is_iso_c
)
1481 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1484 /* Add initializer. Make sure we keep the ranks sane. */
1485 if (sym
->attr
.dimension
&& init
->rank
== 0)
1490 if (sym
->attr
.flavor
== FL_PARAMETER
1491 && init
->expr_type
== EXPR_CONSTANT
1492 && spec_size (sym
->as
, &size
)
1493 && mpz_cmp_si (size
, 0) > 0)
1495 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1497 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1498 gfc_constructor_append_expr (&array
->value
.constructor
,
1501 : gfc_copy_expr (init
),
1504 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1505 for (n
= 0; n
< sym
->as
->rank
; n
++)
1506 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1511 init
->rank
= sym
->as
->rank
;
1515 if (sym
->attr
.save
== SAVE_NONE
)
1516 sym
->attr
.save
= SAVE_IMPLICIT
;
1524 /* Function called by variable_decl() that adds a name to a structure
1528 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1529 gfc_array_spec
**as
)
1534 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1535 constructing, it must have the pointer attribute. */
1536 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1537 && current_ts
.u
.derived
== gfc_current_block ()
1538 && current_attr
.pointer
== 0)
1540 gfc_error ("Component at %C must have the POINTER attribute");
1544 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1546 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1548 gfc_error ("Array component of structure at %C must have explicit "
1549 "or deferred shape");
1554 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1558 if (c
->ts
.type
== BT_CHARACTER
)
1560 c
->attr
= current_attr
;
1562 c
->initializer
= *init
;
1569 c
->attr
.codimension
= 1;
1571 c
->attr
.dimension
= 1;
1575 /* Should this ever get more complicated, combine with similar section
1576 in add_init_expr_to_sym into a separate function. */
1577 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1579 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1583 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1584 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1585 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1587 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1589 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1590 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1591 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1592 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1594 gfc_constructor
*ctor
;
1595 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1600 bool has_ts
= (c
->initializer
->ts
.u
.cl
1601 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1603 /* Remember the length of the first element for checking
1604 that all elements *in the constructor* have the same
1605 length. This need not be the length of the LHS! */
1606 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1607 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1608 first_len
= ctor
->expr
->value
.character
.length
;
1610 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1611 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1613 gfc_set_constant_character_len (len
, ctor
->expr
,
1614 has_ts
? -1 : first_len
);
1615 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1621 /* Check array components. */
1622 if (!c
->attr
.dimension
)
1625 if (c
->attr
.pointer
)
1627 if (c
->as
->type
!= AS_DEFERRED
)
1629 gfc_error ("Pointer array component of structure at %C must have a "
1634 else if (c
->attr
.allocatable
)
1636 if (c
->as
->type
!= AS_DEFERRED
)
1638 gfc_error ("Allocatable component of structure at %C must have a "
1645 if (c
->as
->type
!= AS_EXPLICIT
)
1647 gfc_error ("Array component of structure at %C must have an "
1654 if (c
->ts
.type
== BT_CLASS
)
1656 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1666 /* Match a 'NULL()', and possibly take care of some side effects. */
1669 gfc_match_null (gfc_expr
**result
)
1672 match m
, m2
= MATCH_NO
;
1674 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1680 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1682 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1685 old_loc
= gfc_current_locus
;
1686 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1689 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1693 gfc_current_locus
= old_loc
;
1698 /* The NULL symbol now has to be/become an intrinsic function. */
1699 if (gfc_get_symbol ("null", NULL
, &sym
))
1701 gfc_error ("NULL() initialization at %C is ambiguous");
1705 gfc_intrinsic_symbol (sym
);
1707 if (sym
->attr
.proc
!= PROC_INTRINSIC
1708 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1709 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1710 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1713 *result
= gfc_get_null_expr (&gfc_current_locus
);
1715 /* Invalid per F2008, C512. */
1716 if (m2
== MATCH_YES
)
1718 gfc_error ("NULL() initialization at %C may not have MOLD");
1726 /* Match the initialization expr for a data pointer or procedure pointer. */
1729 match_pointer_init (gfc_expr
**init
, int procptr
)
1733 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1735 gfc_error ("Initialization of pointer at %C is not allowed in "
1736 "a PURE procedure");
1739 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1741 /* Match NULL() initialization. */
1742 m
= gfc_match_null (init
);
1746 /* Match non-NULL initialization. */
1747 gfc_matching_ptr_assignment
= !procptr
;
1748 gfc_matching_procptr_assignment
= procptr
;
1749 m
= gfc_match_rvalue (init
);
1750 gfc_matching_ptr_assignment
= 0;
1751 gfc_matching_procptr_assignment
= 0;
1752 if (m
== MATCH_ERROR
)
1754 else if (m
== MATCH_NO
)
1756 gfc_error ("Error in pointer initialization at %C");
1761 gfc_resolve_expr (*init
);
1763 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1764 "initialization at %C"))
1772 check_function_name (char *name
)
1774 /* In functions that have a RESULT variable defined, the function name always
1775 refers to function calls. Therefore, the name is not allowed to appear in
1776 specification statements. When checking this, be careful about
1777 'hidden' procedure pointer results ('ppr@'). */
1779 if (gfc_current_state () == COMP_FUNCTION
)
1781 gfc_symbol
*block
= gfc_current_block ();
1782 if (block
&& block
->result
&& block
->result
!= block
1783 && strcmp (block
->result
->name
, "ppr@") != 0
1784 && strcmp (block
->name
, name
) == 0)
1786 gfc_error ("Function name %qs not allowed at %C", name
);
1795 /* Match a variable name with an optional initializer. When this
1796 subroutine is called, a variable is expected to be parsed next.
1797 Depending on what is happening at the moment, updates either the
1798 symbol table or the current interface. */
1801 variable_decl (int elem
)
1803 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1804 gfc_expr
*initializer
, *char_len
;
1806 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1818 /* When we get here, we've just matched a list of attributes and
1819 maybe a type and a double colon. The next thing we expect to see
1820 is the name of the symbol. */
1821 m
= gfc_match_name (name
);
1825 var_locus
= gfc_current_locus
;
1827 /* Now we could see the optional array spec. or character length. */
1828 m
= gfc_match_array_spec (&as
, true, true);
1829 if (m
== MATCH_ERROR
)
1833 as
= gfc_copy_array_spec (current_as
);
1835 && !merge_array_spec (current_as
, as
, true))
1841 if (gfc_option
.flag_cray_pointer
)
1842 cp_as
= gfc_copy_array_spec (as
);
1844 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1845 determine (and check) whether it can be implied-shape. If it
1846 was parsed as assumed-size, change it because PARAMETERs can not
1850 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1853 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1858 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1859 && current_attr
.flavor
== FL_PARAMETER
)
1860 as
->type
= AS_IMPLIED_SHAPE
;
1862 if (as
->type
== AS_IMPLIED_SHAPE
1863 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1873 cl_deferred
= false;
1875 if (current_ts
.type
== BT_CHARACTER
)
1877 switch (match_char_length (&char_len
, &cl_deferred
, false))
1880 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1882 cl
->length
= char_len
;
1885 /* Non-constant lengths need to be copied after the first
1886 element. Also copy assumed lengths. */
1889 && (current_ts
.u
.cl
->length
== NULL
1890 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1892 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1893 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1896 cl
= current_ts
.u
.cl
;
1898 cl_deferred
= current_ts
.deferred
;
1907 /* If this symbol has already shown up in a Cray Pointer declaration,
1908 and this is not a component declaration,
1909 then we want to set the type & bail out. */
1910 if (gfc_option
.flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
1912 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1913 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1915 sym
->ts
.type
= current_ts
.type
;
1916 sym
->ts
.kind
= current_ts
.kind
;
1918 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1919 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1920 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1923 /* Check to see if we have an array specification. */
1926 if (sym
->as
!= NULL
)
1928 gfc_error ("Duplicate array spec for Cray pointee at %C");
1929 gfc_free_array_spec (cp_as
);
1935 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
1936 gfc_internal_error ("Couldn't set pointee array spec.");
1938 /* Fix the array spec. */
1939 m
= gfc_mod_pointee_as (sym
->as
);
1940 if (m
== MATCH_ERROR
)
1948 gfc_free_array_spec (cp_as
);
1952 /* Procedure pointer as function result. */
1953 if (gfc_current_state () == COMP_FUNCTION
1954 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
1955 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
1956 strcpy (name
, "ppr@");
1958 if (gfc_current_state () == COMP_FUNCTION
1959 && strcmp (name
, gfc_current_block ()->name
) == 0
1960 && gfc_current_block ()->result
1961 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
1962 strcpy (name
, "ppr@");
1964 /* OK, we've successfully matched the declaration. Now put the
1965 symbol in the current namespace, because it might be used in the
1966 optional initialization expression for this symbol, e.g. this is
1969 integer, parameter :: i = huge(i)
1971 This is only true for parameters or variables of a basic type.
1972 For components of derived types, it is not true, so we don't
1973 create a symbol for those yet. If we fail to create the symbol,
1975 if (gfc_current_state () != COMP_DERIVED
1976 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
1982 if (!check_function_name (name
))
1988 /* We allow old-style initializations of the form
1989 integer i /2/, j(4) /3*3, 1/
1990 (if no colon has been seen). These are different from data
1991 statements in that initializers are only allowed to apply to the
1992 variable immediately preceding, i.e.
1994 is not allowed. Therefore we have to do some work manually, that
1995 could otherwise be left to the matchers for DATA statements. */
1997 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1999 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2000 "initialization at %C"))
2002 else if (gfc_current_state () == COMP_DERIVED
)
2004 gfc_error ("Invalid old style initialization for derived type "
2010 return match_old_style_init (name
);
2013 /* The double colon must be present in order to have initializers.
2014 Otherwise the statement is ambiguous with an assignment statement. */
2017 if (gfc_match (" =>") == MATCH_YES
)
2019 if (!current_attr
.pointer
)
2021 gfc_error ("Initialization at %C isn't for a pointer variable");
2026 m
= match_pointer_init (&initializer
, 0);
2030 else if (gfc_match_char ('=') == MATCH_YES
)
2032 if (current_attr
.pointer
)
2034 gfc_error ("Pointer initialization at %C requires '=>', "
2040 m
= gfc_match_init_expr (&initializer
);
2043 gfc_error ("Expected an initialization expression at %C");
2047 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2048 && gfc_state_stack
->state
!= COMP_DERIVED
)
2050 gfc_error ("Initialization of variable at %C is not allowed in "
2051 "a PURE procedure");
2055 if (current_attr
.flavor
!= FL_PARAMETER
2056 && gfc_state_stack
->state
!= COMP_DERIVED
)
2057 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2064 if (initializer
!= NULL
&& current_attr
.allocatable
2065 && gfc_current_state () == COMP_DERIVED
)
2067 gfc_error ("Initialization of allocatable component at %C is not "
2073 /* Add the initializer. Note that it is fine if initializer is
2074 NULL here, because we sometimes also need to check if a
2075 declaration *must* have an initialization expression. */
2076 if (gfc_current_state () != COMP_DERIVED
)
2077 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2080 if (current_ts
.type
== BT_DERIVED
2081 && !current_attr
.pointer
&& !initializer
)
2082 initializer
= gfc_default_initializer (¤t_ts
);
2083 t
= build_struct (name
, cl
, &initializer
, &as
);
2086 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2089 /* Free stuff up and return. */
2090 gfc_free_expr (initializer
);
2091 gfc_free_array_spec (as
);
2097 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2098 This assumes that the byte size is equal to the kind number for
2099 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2102 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2107 if (gfc_match_char ('*') != MATCH_YES
)
2110 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2114 original_kind
= ts
->kind
;
2116 /* Massage the kind numbers for complex types. */
2117 if (ts
->type
== BT_COMPLEX
)
2121 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2122 gfc_basic_typename (ts
->type
), original_kind
);
2129 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2132 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2136 if (gfc_option
.flag_real4_kind
== 8)
2138 if (gfc_option
.flag_real4_kind
== 10)
2140 if (gfc_option
.flag_real4_kind
== 16)
2146 if (gfc_option
.flag_real8_kind
== 4)
2148 if (gfc_option
.flag_real8_kind
== 10)
2150 if (gfc_option
.flag_real8_kind
== 16)
2155 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2157 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2158 gfc_basic_typename (ts
->type
), original_kind
);
2162 if (!gfc_notify_std (GFC_STD_GNU
,
2163 "Nonstandard type declaration %s*%d at %C",
2164 gfc_basic_typename(ts
->type
), original_kind
))
2171 /* Match a kind specification. Since kinds are generally optional, we
2172 usually return MATCH_NO if something goes wrong. If a "kind="
2173 string is found, then we know we have an error. */
2176 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2188 where
= loc
= gfc_current_locus
;
2193 if (gfc_match_char ('(') == MATCH_NO
)
2196 /* Also gobbles optional text. */
2197 if (gfc_match (" kind = ") == MATCH_YES
)
2200 loc
= gfc_current_locus
;
2203 n
= gfc_match_init_expr (&e
);
2207 if (gfc_matching_function
)
2209 /* The function kind expression might include use associated or
2210 imported parameters and try again after the specification
2212 if (gfc_match_char (')') != MATCH_YES
)
2214 gfc_error ("Missing right parenthesis at %C");
2220 gfc_undo_symbols ();
2225 /* ....or else, the match is real. */
2227 gfc_error ("Expected initialization expression at %C");
2235 gfc_error ("Expected scalar initialization expression at %C");
2240 msg
= gfc_extract_int (e
, &ts
->kind
);
2249 /* Before throwing away the expression, let's see if we had a
2250 C interoperable kind (and store the fact). */
2251 if (e
->ts
.is_c_interop
== 1)
2253 /* Mark this as C interoperable if being declared with one
2254 of the named constants from iso_c_binding. */
2255 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2256 ts
->f90_type
= e
->ts
.f90_type
;
2262 /* Ignore errors to this point, if we've gotten here. This means
2263 we ignore the m=MATCH_ERROR from above. */
2264 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2266 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2267 gfc_basic_typename (ts
->type
));
2268 gfc_current_locus
= where
;
2272 /* Warn if, e.g., c_int is used for a REAL variable, but not
2273 if, e.g., c_double is used for COMPLEX as the standard
2274 explicitly says that the kind type parameter for complex and real
2275 variable is the same, i.e. c_float == c_float_complex. */
2276 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2277 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2278 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2279 gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2280 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2281 gfc_basic_typename (ts
->type
));
2283 gfc_gobble_whitespace ();
2284 if ((c
= gfc_next_ascii_char ()) != ')'
2285 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2287 if (ts
->type
== BT_CHARACTER
)
2288 gfc_error ("Missing right parenthesis or comma at %C");
2290 gfc_error ("Missing right parenthesis at %C");
2294 /* All tests passed. */
2297 if(m
== MATCH_ERROR
)
2298 gfc_current_locus
= where
;
2300 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2303 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2307 if (gfc_option
.flag_real4_kind
== 8)
2309 if (gfc_option
.flag_real4_kind
== 10)
2311 if (gfc_option
.flag_real4_kind
== 16)
2317 if (gfc_option
.flag_real8_kind
== 4)
2319 if (gfc_option
.flag_real8_kind
== 10)
2321 if (gfc_option
.flag_real8_kind
== 16)
2326 /* Return what we know from the test(s). */
2331 gfc_current_locus
= where
;
2337 match_char_kind (int * kind
, int * is_iso_c
)
2346 where
= gfc_current_locus
;
2348 n
= gfc_match_init_expr (&e
);
2350 if (n
!= MATCH_YES
&& gfc_matching_function
)
2352 /* The expression might include use-associated or imported
2353 parameters and try again after the specification
2356 gfc_undo_symbols ();
2361 gfc_error ("Expected initialization expression at %C");
2367 gfc_error ("Expected scalar initialization expression at %C");
2372 msg
= gfc_extract_int (e
, kind
);
2373 *is_iso_c
= e
->ts
.is_iso_c
;
2383 /* Ignore errors to this point, if we've gotten here. This means
2384 we ignore the m=MATCH_ERROR from above. */
2385 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2387 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2391 /* All tests passed. */
2394 if (m
== MATCH_ERROR
)
2395 gfc_current_locus
= where
;
2397 /* Return what we know from the test(s). */
2402 gfc_current_locus
= where
;
2407 /* Match the various kind/length specifications in a CHARACTER
2408 declaration. We don't return MATCH_NO. */
2411 gfc_match_char_spec (gfc_typespec
*ts
)
2413 int kind
, seen_length
, is_iso_c
;
2425 /* Try the old-style specification first. */
2426 old_char_selector
= 0;
2428 m
= match_char_length (&len
, &deferred
, true);
2432 old_char_selector
= 1;
2437 m
= gfc_match_char ('(');
2440 m
= MATCH_YES
; /* Character without length is a single char. */
2444 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2445 if (gfc_match (" kind =") == MATCH_YES
)
2447 m
= match_char_kind (&kind
, &is_iso_c
);
2449 if (m
== MATCH_ERROR
)
2454 if (gfc_match (" , len =") == MATCH_NO
)
2457 m
= char_len_param_value (&len
, &deferred
);
2460 if (m
== MATCH_ERROR
)
2467 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2468 if (gfc_match (" len =") == MATCH_YES
)
2470 m
= char_len_param_value (&len
, &deferred
);
2473 if (m
== MATCH_ERROR
)
2477 if (gfc_match_char (')') == MATCH_YES
)
2480 if (gfc_match (" , kind =") != MATCH_YES
)
2483 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2489 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2490 m
= char_len_param_value (&len
, &deferred
);
2493 if (m
== MATCH_ERROR
)
2497 m
= gfc_match_char (')');
2501 if (gfc_match_char (',') != MATCH_YES
)
2504 gfc_match (" kind ="); /* Gobble optional text. */
2506 m
= match_char_kind (&kind
, &is_iso_c
);
2507 if (m
== MATCH_ERROR
)
2513 /* Require a right-paren at this point. */
2514 m
= gfc_match_char (')');
2519 gfc_error ("Syntax error in CHARACTER declaration at %C");
2521 gfc_free_expr (len
);
2525 /* Deal with character functions after USE and IMPORT statements. */
2526 if (gfc_matching_function
)
2528 gfc_free_expr (len
);
2529 gfc_undo_symbols ();
2535 gfc_free_expr (len
);
2539 /* Do some final massaging of the length values. */
2540 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2542 if (seen_length
== 0)
2543 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2548 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2549 ts
->deferred
= deferred
;
2551 /* We have to know if it was a C interoperable kind so we can
2552 do accurate type checking of bind(c) procs, etc. */
2554 /* Mark this as C interoperable if being declared with one
2555 of the named constants from iso_c_binding. */
2556 ts
->is_c_interop
= is_iso_c
;
2557 else if (len
!= NULL
)
2558 /* Here, we might have parsed something such as: character(c_char)
2559 In this case, the parsing code above grabs the c_char when
2560 looking for the length (line 1690, roughly). it's the last
2561 testcase for parsing the kind params of a character variable.
2562 However, it's not actually the length. this seems like it
2564 To see if the user used a C interop kind, test the expr
2565 of the so called length, and see if it's C interoperable. */
2566 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2572 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2573 structure to the matched specification. This is necessary for FUNCTION and
2574 IMPLICIT statements.
2576 If implicit_flag is nonzero, then we don't check for the optional
2577 kind specification. Not doing so is needed for matching an IMPLICIT
2578 statement correctly. */
2581 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2583 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2584 gfc_symbol
*sym
, *dt_sym
;
2587 bool seen_deferred_kind
, matched_type
;
2588 const char *dt_name
;
2590 /* A belt and braces check that the typespec is correctly being treated
2591 as a deferred characteristic association. */
2592 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2593 && (gfc_current_block ()->result
->ts
.kind
== -1)
2594 && (ts
->kind
== -1);
2596 if (seen_deferred_kind
)
2599 /* Clear the current binding label, in case one is given. */
2600 curr_binding_label
= NULL
;
2602 if (gfc_match (" byte") == MATCH_YES
)
2604 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2607 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2609 gfc_error ("BYTE type used at %C "
2610 "is not available on the target machine");
2614 ts
->type
= BT_INTEGER
;
2620 m
= gfc_match (" type (");
2621 matched_type
= (m
== MATCH_YES
);
2624 gfc_gobble_whitespace ();
2625 if (gfc_peek_ascii_char () == '*')
2627 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2629 if (gfc_current_state () == COMP_DERIVED
)
2631 gfc_error ("Assumed type at %C is not allowed for components");
2634 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2637 ts
->type
= BT_ASSUMED
;
2641 m
= gfc_match ("%n", name
);
2642 matched_type
= (m
== MATCH_YES
);
2645 if ((matched_type
&& strcmp ("integer", name
) == 0)
2646 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2648 ts
->type
= BT_INTEGER
;
2649 ts
->kind
= gfc_default_integer_kind
;
2653 if ((matched_type
&& strcmp ("character", name
) == 0)
2654 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2657 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2658 "intrinsic-type-spec at %C"))
2661 ts
->type
= BT_CHARACTER
;
2662 if (implicit_flag
== 0)
2663 m
= gfc_match_char_spec (ts
);
2667 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2673 if ((matched_type
&& strcmp ("real", name
) == 0)
2674 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2677 ts
->kind
= gfc_default_real_kind
;
2682 && (strcmp ("doubleprecision", name
) == 0
2683 || (strcmp ("double", name
) == 0
2684 && gfc_match (" precision") == MATCH_YES
)))
2685 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2688 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2689 "intrinsic-type-spec at %C"))
2691 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2695 ts
->kind
= gfc_default_double_kind
;
2699 if ((matched_type
&& strcmp ("complex", name
) == 0)
2700 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2702 ts
->type
= BT_COMPLEX
;
2703 ts
->kind
= gfc_default_complex_kind
;
2708 && (strcmp ("doublecomplex", name
) == 0
2709 || (strcmp ("double", name
) == 0
2710 && gfc_match (" complex") == MATCH_YES
)))
2711 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2713 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2717 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2718 "intrinsic-type-spec at %C"))
2721 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2724 ts
->type
= BT_COMPLEX
;
2725 ts
->kind
= gfc_default_double_kind
;
2729 if ((matched_type
&& strcmp ("logical", name
) == 0)
2730 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2732 ts
->type
= BT_LOGICAL
;
2733 ts
->kind
= gfc_default_logical_kind
;
2738 m
= gfc_match_char (')');
2741 ts
->type
= BT_DERIVED
;
2744 /* Match CLASS declarations. */
2745 m
= gfc_match (" class ( * )");
2746 if (m
== MATCH_ERROR
)
2748 else if (m
== MATCH_YES
)
2752 ts
->type
= BT_CLASS
;
2753 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2756 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2757 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2759 gfc_set_sym_referenced (upe
);
2761 upe
->ts
.type
= BT_VOID
;
2762 upe
->attr
.unlimited_polymorphic
= 1;
2763 /* This is essential to force the construction of
2764 unlimited polymorphic component class containers. */
2765 upe
->attr
.zero_comp
= 1;
2766 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2767 &gfc_current_locus
))
2772 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2774 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2778 ts
->u
.derived
= upe
;
2782 m
= gfc_match (" class ( %n )", name
);
2785 ts
->type
= BT_CLASS
;
2787 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2791 /* Defer association of the derived type until the end of the
2792 specification block. However, if the derived type can be
2793 found, add it to the typespec. */
2794 if (gfc_matching_function
)
2796 ts
->u
.derived
= NULL
;
2797 if (gfc_current_state () != COMP_INTERFACE
2798 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2800 sym
= gfc_find_dt_in_generic (sym
);
2801 ts
->u
.derived
= sym
;
2806 /* Search for the name but allow the components to be defined later. If
2807 type = -1, this typespec has been seen in a function declaration but
2808 the type could not be accessed at that point. The actual derived type is
2809 stored in a symtree with the first letter of the name capitalized; the
2810 symtree with the all lower-case name contains the associated
2811 generic function. */
2812 dt_name
= gfc_get_string ("%c%s",
2813 (char) TOUPPER ((unsigned char) name
[0]),
2814 (const char*)&name
[1]);
2819 gfc_get_ha_symbol (name
, &sym
);
2820 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2822 gfc_error ("Type name %qs at %C is ambiguous", name
);
2825 if (sym
->generic
&& !dt_sym
)
2826 dt_sym
= gfc_find_dt_in_generic (sym
);
2828 else if (ts
->kind
== -1)
2830 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2831 || gfc_current_ns
->has_import_set
;
2832 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2833 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2835 gfc_error ("Type name %qs at %C is ambiguous", name
);
2838 if (sym
&& sym
->generic
&& !dt_sym
)
2839 dt_sym
= gfc_find_dt_in_generic (sym
);
2846 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2847 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2848 || sym
->attr
.subroutine
)
2850 gfc_error_1 ("Type name '%s' at %C conflicts with previously declared "
2851 "entity at %L, which has the same name", name
,
2856 gfc_set_sym_referenced (sym
);
2857 if (!sym
->attr
.generic
2858 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2861 if (!sym
->attr
.function
2862 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2867 gfc_interface
*intr
, *head
;
2869 /* Use upper case to save the actual derived-type symbol. */
2870 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2871 dt_sym
->name
= gfc_get_string (sym
->name
);
2872 head
= sym
->generic
;
2873 intr
= gfc_get_interface ();
2875 intr
->where
= gfc_current_locus
;
2877 sym
->generic
= intr
;
2878 sym
->attr
.if_source
= IFSRC_DECL
;
2881 gfc_set_sym_referenced (dt_sym
);
2883 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2884 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2887 ts
->u
.derived
= dt_sym
;
2893 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2894 "intrinsic-type-spec at %C"))
2897 /* For all types except double, derived and character, look for an
2898 optional kind specifier. MATCH_NO is actually OK at this point. */
2899 if (implicit_flag
== 1)
2901 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2907 if (gfc_current_form
== FORM_FREE
)
2909 c
= gfc_peek_ascii_char ();
2910 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2911 && c
!= ':' && c
!= ',')
2913 if (matched_type
&& c
== ')')
2915 gfc_next_ascii_char ();
2922 m
= gfc_match_kind_spec (ts
, false);
2923 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2924 m
= gfc_match_old_kind_spec (ts
);
2926 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2929 /* Defer association of the KIND expression of function results
2930 until after USE and IMPORT statements. */
2931 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
2932 || gfc_matching_function
)
2936 m
= MATCH_YES
; /* No kind specifier found. */
2942 /* Match an IMPLICIT NONE statement. Actually, this statement is
2943 already matched in parse.c, or we would not end up here in the
2944 first place. So the only thing we need to check, is if there is
2945 trailing garbage. If not, the match is successful. */
2948 gfc_match_implicit_none (void)
2952 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2954 bool external
= false;
2955 locus cur_loc
= gfc_current_locus
;
2957 if (gfc_current_ns
->seen_implicit_none
2958 || gfc_current_ns
->has_implicit_none_export
)
2960 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
2964 gfc_gobble_whitespace ();
2965 c
= gfc_peek_ascii_char ();
2968 (void) gfc_next_ascii_char ();
2969 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
2972 gfc_gobble_whitespace ();
2973 if (gfc_peek_ascii_char () == ')')
2975 (void) gfc_next_ascii_char ();
2981 m
= gfc_match (" %n", name
);
2985 if (strcmp (name
, "type") == 0)
2987 else if (strcmp (name
, "external") == 0)
2992 gfc_gobble_whitespace ();
2993 c
= gfc_next_ascii_char ();
3004 if (gfc_match_eos () != MATCH_YES
)
3007 gfc_set_implicit_none (type
, external
, &cur_loc
);
3013 /* Match the letter range(s) of an IMPLICIT statement. */
3016 match_implicit_range (void)
3022 cur_loc
= gfc_current_locus
;
3024 gfc_gobble_whitespace ();
3025 c
= gfc_next_ascii_char ();
3028 gfc_error ("Missing character range in IMPLICIT at %C");
3035 gfc_gobble_whitespace ();
3036 c1
= gfc_next_ascii_char ();
3040 gfc_gobble_whitespace ();
3041 c
= gfc_next_ascii_char ();
3046 inner
= 0; /* Fall through. */
3053 gfc_gobble_whitespace ();
3054 c2
= gfc_next_ascii_char ();
3058 gfc_gobble_whitespace ();
3059 c
= gfc_next_ascii_char ();
3061 if ((c
!= ',') && (c
!= ')'))
3074 gfc_error ("Letters must be in alphabetic order in "
3075 "IMPLICIT statement at %C");
3079 /* See if we can add the newly matched range to the pending
3080 implicits from this IMPLICIT statement. We do not check for
3081 conflicts with whatever earlier IMPLICIT statements may have
3082 set. This is done when we've successfully finished matching
3084 if (!gfc_add_new_implicit_range (c1
, c2
))
3091 gfc_syntax_error (ST_IMPLICIT
);
3093 gfc_current_locus
= cur_loc
;
3098 /* Match an IMPLICIT statement, storing the types for
3099 gfc_set_implicit() if the statement is accepted by the parser.
3100 There is a strange looking, but legal syntactic construction
3101 possible. It looks like:
3103 IMPLICIT INTEGER (a-b) (c-d)
3105 This is legal if "a-b" is a constant expression that happens to
3106 equal one of the legal kinds for integers. The real problem
3107 happens with an implicit specification that looks like:
3109 IMPLICIT INTEGER (a-b)
3111 In this case, a typespec matcher that is "greedy" (as most of the
3112 matchers are) gobbles the character range as a kindspec, leaving
3113 nothing left. We therefore have to go a bit more slowly in the
3114 matching process by inhibiting the kindspec checking during
3115 typespec matching and checking for a kind later. */
3118 gfc_match_implicit (void)
3125 if (gfc_current_ns
->seen_implicit_none
)
3127 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3134 /* We don't allow empty implicit statements. */
3135 if (gfc_match_eos () == MATCH_YES
)
3137 gfc_error ("Empty IMPLICIT statement at %C");
3143 /* First cleanup. */
3144 gfc_clear_new_implicit ();
3146 /* A basic type is mandatory here. */
3147 m
= gfc_match_decl_type_spec (&ts
, 1);
3148 if (m
== MATCH_ERROR
)
3153 cur_loc
= gfc_current_locus
;
3154 m
= match_implicit_range ();
3158 /* We may have <TYPE> (<RANGE>). */
3159 gfc_gobble_whitespace ();
3160 c
= gfc_peek_ascii_char ();
3161 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3163 /* Check for CHARACTER with no length parameter. */
3164 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3166 ts
.kind
= gfc_default_character_kind
;
3167 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3168 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3172 /* Record the Successful match. */
3173 if (!gfc_merge_new_implicit (&ts
))
3176 c
= gfc_next_ascii_char ();
3177 else if (gfc_match_eos () == MATCH_ERROR
)
3182 gfc_current_locus
= cur_loc
;
3185 /* Discard the (incorrectly) matched range. */
3186 gfc_clear_new_implicit ();
3188 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3189 if (ts
.type
== BT_CHARACTER
)
3190 m
= gfc_match_char_spec (&ts
);
3193 m
= gfc_match_kind_spec (&ts
, false);
3196 m
= gfc_match_old_kind_spec (&ts
);
3197 if (m
== MATCH_ERROR
)
3203 if (m
== MATCH_ERROR
)
3206 m
= match_implicit_range ();
3207 if (m
== MATCH_ERROR
)
3212 gfc_gobble_whitespace ();
3213 c
= gfc_next_ascii_char ();
3214 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3217 if (!gfc_merge_new_implicit (&ts
))
3225 gfc_syntax_error (ST_IMPLICIT
);
3233 gfc_match_import (void)
3235 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3240 if (gfc_current_ns
->proc_name
== NULL
3241 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3243 gfc_error ("IMPORT statement at %C only permitted in "
3244 "an INTERFACE body");
3248 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3251 if (gfc_match_eos () == MATCH_YES
)
3253 /* All host variables should be imported. */
3254 gfc_current_ns
->has_import_set
= 1;
3258 if (gfc_match (" ::") == MATCH_YES
)
3260 if (gfc_match_eos () == MATCH_YES
)
3262 gfc_error ("Expecting list of named entities at %C");
3270 m
= gfc_match (" %n", name
);
3274 if (gfc_current_ns
->parent
!= NULL
3275 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3277 gfc_error ("Type name %qs at %C is ambiguous", name
);
3280 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3281 && gfc_find_symbol (name
,
3282 gfc_current_ns
->proc_name
->ns
->parent
,
3285 gfc_error ("Type name %qs at %C is ambiguous", name
);
3291 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3292 "at %C - does not exist.", name
);
3296 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3298 gfc_warning ("%qs is already IMPORTed from host scoping unit "
3303 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3306 sym
->attr
.imported
= 1;
3308 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3310 /* The actual derived type is stored in a symtree with the first
3311 letter of the name capitalized; the symtree with the all
3312 lower-case name contains the associated generic function. */
3313 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3314 gfc_get_string ("%c%s",
3315 (char) TOUPPER ((unsigned char) name
[0]),
3319 sym
->attr
.imported
= 1;
3332 if (gfc_match_eos () == MATCH_YES
)
3334 if (gfc_match_char (',') != MATCH_YES
)
3341 gfc_error ("Syntax error in IMPORT statement at %C");
3346 /* A minimal implementation of gfc_match without whitespace, escape
3347 characters or variable arguments. Returns true if the next
3348 characters match the TARGET template exactly. */
3351 match_string_p (const char *target
)
3355 for (p
= target
; *p
; p
++)
3356 if ((char) gfc_next_ascii_char () != *p
)
3361 /* Matches an attribute specification including array specs. If
3362 successful, leaves the variables current_attr and current_as
3363 holding the specification. Also sets the colon_seen variable for
3364 later use by matchers associated with initializations.
3366 This subroutine is a little tricky in the sense that we don't know
3367 if we really have an attr-spec until we hit the double colon.
3368 Until that time, we can only return MATCH_NO. This forces us to
3369 check for duplicate specification at this level. */
3372 match_attr_spec (void)
3374 /* Modifiers that can exist in a type statement. */
3376 { GFC_DECL_BEGIN
= 0,
3377 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3378 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3379 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3380 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3381 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3382 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3385 /* GFC_DECL_END is the sentinel, index starts at 0. */
3386 #define NUM_DECL GFC_DECL_END
3388 locus start
, seen_at
[NUM_DECL
];
3395 gfc_clear_attr (¤t_attr
);
3396 start
= gfc_current_locus
;
3401 /* See if we get all of the keywords up to the final double colon. */
3402 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3410 gfc_gobble_whitespace ();
3412 ch
= gfc_next_ascii_char ();
3415 /* This is the successful exit condition for the loop. */
3416 if (gfc_next_ascii_char () == ':')
3421 gfc_gobble_whitespace ();
3422 switch (gfc_peek_ascii_char ())
3425 gfc_next_ascii_char ();
3426 switch (gfc_next_ascii_char ())
3429 if (match_string_p ("locatable"))
3431 /* Matched "allocatable". */
3432 d
= DECL_ALLOCATABLE
;
3437 if (match_string_p ("ynchronous"))
3439 /* Matched "asynchronous". */
3440 d
= DECL_ASYNCHRONOUS
;
3447 /* Try and match the bind(c). */
3448 m
= gfc_match_bind_c (NULL
, true);
3451 else if (m
== MATCH_ERROR
)
3456 gfc_next_ascii_char ();
3457 if ('o' != gfc_next_ascii_char ())
3459 switch (gfc_next_ascii_char ())
3462 if (match_string_p ("imension"))
3464 d
= DECL_CODIMENSION
;
3468 if (match_string_p ("tiguous"))
3470 d
= DECL_CONTIGUOUS
;
3477 if (match_string_p ("dimension"))
3482 if (match_string_p ("external"))
3487 if (match_string_p ("int"))
3489 ch
= gfc_next_ascii_char ();
3492 if (match_string_p ("nt"))
3494 /* Matched "intent". */
3495 /* TODO: Call match_intent_spec from here. */
3496 if (gfc_match (" ( in out )") == MATCH_YES
)
3498 else if (gfc_match (" ( in )") == MATCH_YES
)
3500 else if (gfc_match (" ( out )") == MATCH_YES
)
3506 if (match_string_p ("insic"))
3508 /* Matched "intrinsic". */
3516 if (match_string_p ("optional"))
3521 gfc_next_ascii_char ();
3522 switch (gfc_next_ascii_char ())
3525 if (match_string_p ("rameter"))
3527 /* Matched "parameter". */
3533 if (match_string_p ("inter"))
3535 /* Matched "pointer". */
3541 ch
= gfc_next_ascii_char ();
3544 if (match_string_p ("vate"))
3546 /* Matched "private". */
3552 if (match_string_p ("tected"))
3554 /* Matched "protected". */
3561 if (match_string_p ("blic"))
3563 /* Matched "public". */
3571 if (match_string_p ("save"))
3576 if (match_string_p ("target"))
3581 gfc_next_ascii_char ();
3582 ch
= gfc_next_ascii_char ();
3585 if (match_string_p ("lue"))
3587 /* Matched "value". */
3593 if (match_string_p ("latile"))
3595 /* Matched "volatile". */
3603 /* No double colon and no recognizable decl_type, so assume that
3604 we've been looking at something else the whole time. */
3611 /* Check to make sure any parens are paired up correctly. */
3612 if (gfc_match_parens () == MATCH_ERROR
)
3619 seen_at
[d
] = gfc_current_locus
;
3621 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3623 gfc_array_spec
*as
= NULL
;
3625 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3626 d
== DECL_CODIMENSION
);
3628 if (current_as
== NULL
)
3630 else if (m
== MATCH_YES
)
3632 if (!merge_array_spec (as
, current_as
, false))
3639 if (d
== DECL_CODIMENSION
)
3640 gfc_error ("Missing codimension specification at %C");
3642 gfc_error ("Missing dimension specification at %C");
3646 if (m
== MATCH_ERROR
)
3651 /* Since we've seen a double colon, we have to be looking at an
3652 attr-spec. This means that we can now issue errors. */
3653 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3658 case DECL_ALLOCATABLE
:
3659 attr
= "ALLOCATABLE";
3661 case DECL_ASYNCHRONOUS
:
3662 attr
= "ASYNCHRONOUS";
3664 case DECL_CODIMENSION
:
3665 attr
= "CODIMENSION";
3667 case DECL_CONTIGUOUS
:
3668 attr
= "CONTIGUOUS";
3670 case DECL_DIMENSION
:
3677 attr
= "INTENT (IN)";
3680 attr
= "INTENT (OUT)";
3683 attr
= "INTENT (IN OUT)";
3685 case DECL_INTRINSIC
:
3691 case DECL_PARAMETER
:
3697 case DECL_PROTECTED
:
3712 case DECL_IS_BIND_C
:
3722 attr
= NULL
; /* This shouldn't happen. */
3725 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3730 /* Now that we've dealt with duplicate attributes, add the attributes
3731 to the current attribute. */
3732 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3737 if (gfc_current_state () == COMP_DERIVED
3738 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3739 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3740 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3742 if (d
== DECL_ALLOCATABLE
)
3744 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3745 "attribute at %C in a TYPE definition"))
3753 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3760 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3761 && gfc_current_state () != COMP_MODULE
)
3763 if (d
== DECL_PRIVATE
)
3767 if (gfc_current_state () == COMP_DERIVED
3768 && gfc_state_stack
->previous
3769 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3771 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3772 "at %L in a TYPE definition", attr
,
3781 gfc_error ("%s attribute at %L is not allowed outside of the "
3782 "specification part of a module", attr
, &seen_at
[d
]);
3790 case DECL_ALLOCATABLE
:
3791 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3794 case DECL_ASYNCHRONOUS
:
3795 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3798 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3801 case DECL_CODIMENSION
:
3802 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3805 case DECL_CONTIGUOUS
:
3806 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3809 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3812 case DECL_DIMENSION
:
3813 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3817 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3821 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3825 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3829 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3832 case DECL_INTRINSIC
:
3833 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3837 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3840 case DECL_PARAMETER
:
3841 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3845 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3848 case DECL_PROTECTED
:
3849 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3851 gfc_error ("PROTECTED at %C only allowed in specification "
3852 "part of a module");
3857 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3860 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3864 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3869 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3874 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3878 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3881 case DECL_IS_BIND_C
:
3882 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3886 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3889 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3893 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3896 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3900 gfc_internal_error ("match_attr_spec(): Bad attribute");
3910 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3911 if (gfc_current_state () == COMP_MODULE
&& !current_attr
.save
3912 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3913 current_attr
.save
= SAVE_IMPLICIT
;
3919 gfc_current_locus
= start
;
3920 gfc_free_array_spec (current_as
);
3926 /* Set the binding label, dest_label, either with the binding label
3927 stored in the given gfc_typespec, ts, or if none was provided, it
3928 will be the symbol name in all lower case, as required by the draft
3929 (J3/04-007, section 15.4.1). If a binding label was given and
3930 there is more than one argument (num_idents), it is an error. */
3933 set_binding_label (const char **dest_label
, const char *sym_name
,
3936 if (num_idents
> 1 && has_name_equals
)
3938 gfc_error ("Multiple identifiers provided with "
3939 "single NAME= specifier at %C");
3943 if (curr_binding_label
)
3944 /* Binding label given; store in temp holder till have sym. */
3945 *dest_label
= curr_binding_label
;
3948 /* No binding label given, and the NAME= specifier did not exist,
3949 which means there was no NAME="". */
3950 if (sym_name
!= NULL
&& has_name_equals
== 0)
3951 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
3958 /* Set the status of the given common block as being BIND(C) or not,
3959 depending on the given parameter, is_bind_c. */
3962 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
3964 com_block
->is_bind_c
= is_bind_c
;
3969 /* Verify that the given gfc_typespec is for a C interoperable type. */
3972 gfc_verify_c_interop (gfc_typespec
*ts
)
3974 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
3975 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
3977 else if (ts
->type
== BT_CLASS
)
3979 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
3986 /* Verify that the variables of a given common block, which has been
3987 defined with the attribute specifier bind(c), to be of a C
3988 interoperable type. Errors will be reported here, if
3992 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
3994 gfc_symbol
*curr_sym
= NULL
;
3997 curr_sym
= com_block
->head
;
3999 /* Make sure we have at least one symbol. */
4000 if (curr_sym
== NULL
)
4003 /* Here we know we have a symbol, so we'll execute this loop
4007 /* The second to last param, 1, says this is in a common block. */
4008 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4009 curr_sym
= curr_sym
->common_next
;
4010 } while (curr_sym
!= NULL
);
4016 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4017 an appropriate error message is reported. */
4020 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4021 int is_in_common
, gfc_common_head
*com_block
)
4023 bool bind_c_function
= false;
4026 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4027 bind_c_function
= true;
4029 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4031 tmp_sym
= tmp_sym
->result
;
4032 /* Make sure it wasn't an implicitly typed result. */
4033 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4035 gfc_warning (OPT_Wc_binding_type
,
4036 "Implicitly declared BIND(C) function %qs at "
4037 "%L may not be C interoperable", tmp_sym
->name
,
4038 &tmp_sym
->declared_at
);
4039 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4040 /* Mark it as C interoperable to prevent duplicate warnings. */
4041 tmp_sym
->ts
.is_c_interop
= 1;
4042 tmp_sym
->attr
.is_c_interop
= 1;
4046 /* Here, we know we have the bind(c) attribute, so if we have
4047 enough type info, then verify that it's a C interop kind.
4048 The info could be in the symbol already, or possibly still in
4049 the given ts (current_ts), so look in both. */
4050 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4052 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4054 /* See if we're dealing with a sym in a common block or not. */
4055 if (is_in_common
== 1 && warn_c_binding_type
)
4057 gfc_warning (OPT_Wc_binding_type
,
4058 "Variable %qs in common block %qs at %L "
4059 "may not be a C interoperable "
4060 "kind though common block %qs is BIND(C)",
4061 tmp_sym
->name
, com_block
->name
,
4062 &(tmp_sym
->declared_at
), com_block
->name
);
4066 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4067 gfc_error ("Type declaration %qs at %L is not C "
4068 "interoperable but it is BIND(C)",
4069 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4070 else if (warn_c_binding_type
)
4071 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4072 "may not be a C interoperable "
4073 "kind but it is BIND(C)",
4074 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4078 /* Variables declared w/in a common block can't be bind(c)
4079 since there's no way for C to see these variables, so there's
4080 semantically no reason for the attribute. */
4081 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4083 gfc_error ("Variable %qs in common block %qs at "
4084 "%L cannot be declared with BIND(C) "
4085 "since it is not a global",
4086 tmp_sym
->name
, com_block
->name
,
4087 &(tmp_sym
->declared_at
));
4091 /* Scalar variables that are bind(c) can not have the pointer
4092 or allocatable attributes. */
4093 if (tmp_sym
->attr
.is_bind_c
== 1)
4095 if (tmp_sym
->attr
.pointer
== 1)
4097 gfc_error ("Variable %qs at %L cannot have both the "
4098 "POINTER and BIND(C) attributes",
4099 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4103 if (tmp_sym
->attr
.allocatable
== 1)
4105 gfc_error ("Variable %qs at %L cannot have both the "
4106 "ALLOCATABLE and BIND(C) attributes",
4107 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4113 /* If it is a BIND(C) function, make sure the return value is a
4114 scalar value. The previous tests in this function made sure
4115 the type is interoperable. */
4116 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4117 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4118 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4120 /* BIND(C) functions can not return a character string. */
4121 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4122 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4123 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4124 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4125 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4126 "be a character string", tmp_sym
->name
,
4127 &(tmp_sym
->declared_at
));
4130 /* See if the symbol has been marked as private. If it has, make sure
4131 there is no binding label and warn the user if there is one. */
4132 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4133 && tmp_sym
->binding_label
)
4134 /* Use gfc_warning_now because we won't say that the symbol fails
4135 just because of this. */
4136 gfc_warning_now ("Symbol %qs at %L is marked PRIVATE but has been "
4137 "given the binding label %qs", tmp_sym
->name
,
4138 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4144 /* Set the appropriate fields for a symbol that's been declared as
4145 BIND(C) (the is_bind_c flag and the binding label), and verify that
4146 the type is C interoperable. Errors are reported by the functions
4147 used to set/test these fields. */
4150 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4154 /* TODO: Do we need to make sure the vars aren't marked private? */
4156 /* Set the is_bind_c bit in symbol_attribute. */
4157 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4159 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4166 /* Set the fields marking the given common block as BIND(C), including
4167 a binding label, and report any errors encountered. */
4170 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4174 /* destLabel, common name, typespec (which may have binding label). */
4175 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4179 /* Set the given common block (com_block) to being bind(c) (1). */
4180 set_com_block_bind_c (com_block
, 1);
4186 /* Retrieve the list of one or more identifiers that the given bind(c)
4187 attribute applies to. */
4190 get_bind_c_idents (void)
4192 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4194 gfc_symbol
*tmp_sym
= NULL
;
4196 gfc_common_head
*com_block
= NULL
;
4198 if (gfc_match_name (name
) == MATCH_YES
)
4200 found_id
= MATCH_YES
;
4201 gfc_get_ha_symbol (name
, &tmp_sym
);
4203 else if (match_common_name (name
) == MATCH_YES
)
4205 found_id
= MATCH_YES
;
4206 com_block
= gfc_get_common (name
, 0);
4210 gfc_error ("Need either entity or common block name for "
4211 "attribute specification statement at %C");
4215 /* Save the current identifier and look for more. */
4218 /* Increment the number of identifiers found for this spec stmt. */
4221 /* Make sure we have a sym or com block, and verify that it can
4222 be bind(c). Set the appropriate field(s) and look for more
4224 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4226 if (tmp_sym
!= NULL
)
4228 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4233 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4237 /* Look to see if we have another identifier. */
4239 if (gfc_match_eos () == MATCH_YES
)
4240 found_id
= MATCH_NO
;
4241 else if (gfc_match_char (',') != MATCH_YES
)
4242 found_id
= MATCH_NO
;
4243 else if (gfc_match_name (name
) == MATCH_YES
)
4245 found_id
= MATCH_YES
;
4246 gfc_get_ha_symbol (name
, &tmp_sym
);
4248 else if (match_common_name (name
) == MATCH_YES
)
4250 found_id
= MATCH_YES
;
4251 com_block
= gfc_get_common (name
, 0);
4255 gfc_error ("Missing entity or common block name for "
4256 "attribute specification statement at %C");
4262 gfc_internal_error ("Missing symbol");
4264 } while (found_id
== MATCH_YES
);
4266 /* if we get here we were successful */
4271 /* Try and match a BIND(C) attribute specification statement. */
4274 gfc_match_bind_c_stmt (void)
4276 match found_match
= MATCH_NO
;
4281 /* This may not be necessary. */
4283 /* Clear the temporary binding label holder. */
4284 curr_binding_label
= NULL
;
4286 /* Look for the bind(c). */
4287 found_match
= gfc_match_bind_c (NULL
, true);
4289 if (found_match
== MATCH_YES
)
4291 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4294 /* Look for the :: now, but it is not required. */
4297 /* Get the identifier(s) that needs to be updated. This may need to
4298 change to hand the flag(s) for the attr specified so all identifiers
4299 found can have all appropriate parts updated (assuming that the same
4300 spec stmt can have multiple attrs, such as both bind(c) and
4302 if (!get_bind_c_idents ())
4303 /* Error message should have printed already. */
4311 /* Match a data declaration statement. */
4314 gfc_match_data_decl (void)
4320 num_idents_on_line
= 0;
4322 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4326 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4327 && gfc_current_state () != COMP_DERIVED
)
4329 sym
= gfc_use_derived (current_ts
.u
.derived
);
4337 current_ts
.u
.derived
= sym
;
4340 m
= match_attr_spec ();
4341 if (m
== MATCH_ERROR
)
4347 if (current_ts
.type
== BT_CLASS
4348 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4351 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4352 && current_ts
.u
.derived
->components
== NULL
4353 && !current_ts
.u
.derived
->attr
.zero_comp
)
4356 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4359 gfc_find_symbol (current_ts
.u
.derived
->name
,
4360 current_ts
.u
.derived
->ns
, 1, &sym
);
4362 /* Any symbol that we find had better be a type definition
4363 which has its components defined. */
4364 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4365 && (current_ts
.u
.derived
->components
!= NULL
4366 || current_ts
.u
.derived
->attr
.zero_comp
))
4369 gfc_error ("Derived type at %C has not been previously defined "
4370 "and so cannot appear in a derived type definition");
4376 /* If we have an old-style character declaration, and no new-style
4377 attribute specifications, then there a comma is optional between
4378 the type specification and the variable list. */
4379 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4380 gfc_match_char (',');
4382 /* Give the types/attributes to symbols that follow. Give the element
4383 a number so that repeat character length expressions can be copied. */
4387 num_idents_on_line
++;
4388 m
= variable_decl (elem
++);
4389 if (m
== MATCH_ERROR
)
4394 if (gfc_match_eos () == MATCH_YES
)
4396 if (gfc_match_char (',') != MATCH_YES
)
4400 if (!gfc_error_flag_test ())
4401 gfc_error ("Syntax error in data declaration at %C");
4404 gfc_free_data_all (gfc_current_ns
);
4407 gfc_free_array_spec (current_as
);
4413 /* Match a prefix associated with a function or subroutine
4414 declaration. If the typespec pointer is nonnull, then a typespec
4415 can be matched. Note that if nothing matches, MATCH_YES is
4416 returned (the null string was matched). */
4419 gfc_match_prefix (gfc_typespec
*ts
)
4425 gfc_clear_attr (¤t_attr
);
4427 seen_impure
= false;
4429 gcc_assert (!gfc_matching_prefix
);
4430 gfc_matching_prefix
= true;
4434 found_prefix
= false;
4436 if (!seen_type
&& ts
!= NULL
4437 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4438 && gfc_match_space () == MATCH_YES
)
4442 found_prefix
= true;
4445 if (gfc_match ("elemental% ") == MATCH_YES
)
4447 if (!gfc_add_elemental (¤t_attr
, NULL
))
4450 found_prefix
= true;
4453 if (gfc_match ("pure% ") == MATCH_YES
)
4455 if (!gfc_add_pure (¤t_attr
, NULL
))
4458 found_prefix
= true;
4461 if (gfc_match ("recursive% ") == MATCH_YES
)
4463 if (!gfc_add_recursive (¤t_attr
, NULL
))
4466 found_prefix
= true;
4469 /* IMPURE is a somewhat special case, as it needs not set an actual
4470 attribute but rather only prevents ELEMENTAL routines from being
4471 automatically PURE. */
4472 if (gfc_match ("impure% ") == MATCH_YES
)
4474 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4478 found_prefix
= true;
4481 while (found_prefix
);
4483 /* IMPURE and PURE must not both appear, of course. */
4484 if (seen_impure
&& current_attr
.pure
)
4486 gfc_error ("PURE and IMPURE must not appear both at %C");
4490 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4491 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4493 if (!gfc_add_pure (¤t_attr
, NULL
))
4497 /* At this point, the next item is not a prefix. */
4498 gcc_assert (gfc_matching_prefix
);
4499 gfc_matching_prefix
= false;
4503 gcc_assert (gfc_matching_prefix
);
4504 gfc_matching_prefix
= false;
4509 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4512 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4514 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4517 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4520 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4527 /* Match a formal argument list. */
4530 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4532 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4533 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4539 if (gfc_match_char ('(') != MATCH_YES
)
4546 if (gfc_match_char (')') == MATCH_YES
)
4551 if (gfc_match_char ('*') == MATCH_YES
)
4554 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4563 m
= gfc_match_name (name
);
4567 if (gfc_get_symbol (name
, NULL
, &sym
))
4571 p
= gfc_get_formal_arglist ();
4583 /* We don't add the VARIABLE flavor because the name could be a
4584 dummy procedure. We don't apply these attributes to formal
4585 arguments of statement functions. */
4586 if (sym
!= NULL
&& !st_flag
4587 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4588 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4594 /* The name of a program unit can be in a different namespace,
4595 so check for it explicitly. After the statement is accepted,
4596 the name is checked for especially in gfc_get_symbol(). */
4597 if (gfc_new_block
!= NULL
&& sym
!= NULL
4598 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4600 gfc_error ("Name %qs at %C is the name of the procedure",
4606 if (gfc_match_char (')') == MATCH_YES
)
4609 m
= gfc_match_char (',');
4612 gfc_error ("Unexpected junk in formal argument list at %C");
4618 /* Check for duplicate symbols in the formal argument list. */
4621 for (p
= head
; p
->next
; p
= p
->next
)
4626 for (q
= p
->next
; q
; q
= q
->next
)
4627 if (p
->sym
== q
->sym
)
4629 gfc_error ("Duplicate symbol %qs in formal argument list "
4630 "at %C", p
->sym
->name
);
4638 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4647 gfc_free_formal_arglist (head
);
4652 /* Match a RESULT specification following a function declaration or
4653 ENTRY statement. Also matches the end-of-statement. */
4656 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4658 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4662 if (gfc_match (" result (") != MATCH_YES
)
4665 m
= gfc_match_name (name
);
4669 /* Get the right paren, and that's it because there could be the
4670 bind(c) attribute after the result clause. */
4671 if (gfc_match_char (')') != MATCH_YES
)
4673 /* TODO: should report the missing right paren here. */
4677 if (strcmp (function
->name
, name
) == 0)
4679 gfc_error ("RESULT variable at %C must be different than function name");
4683 if (gfc_get_symbol (name
, NULL
, &r
))
4686 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4695 /* Match a function suffix, which could be a combination of a result
4696 clause and BIND(C), either one, or neither. The draft does not
4697 require them to come in a specific order. */
4700 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4702 match is_bind_c
; /* Found bind(c). */
4703 match is_result
; /* Found result clause. */
4704 match found_match
; /* Status of whether we've found a good match. */
4705 char peek_char
; /* Character we're going to peek at. */
4706 bool allow_binding_name
;
4708 /* Initialize to having found nothing. */
4709 found_match
= MATCH_NO
;
4710 is_bind_c
= MATCH_NO
;
4711 is_result
= MATCH_NO
;
4713 /* Get the next char to narrow between result and bind(c). */
4714 gfc_gobble_whitespace ();
4715 peek_char
= gfc_peek_ascii_char ();
4717 /* C binding names are not allowed for internal procedures. */
4718 if (gfc_current_state () == COMP_CONTAINS
4719 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4720 allow_binding_name
= false;
4722 allow_binding_name
= true;
4727 /* Look for result clause. */
4728 is_result
= match_result (sym
, result
);
4729 if (is_result
== MATCH_YES
)
4731 /* Now see if there is a bind(c) after it. */
4732 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4733 /* We've found the result clause and possibly bind(c). */
4734 found_match
= MATCH_YES
;
4737 /* This should only be MATCH_ERROR. */
4738 found_match
= is_result
;
4741 /* Look for bind(c) first. */
4742 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4743 if (is_bind_c
== MATCH_YES
)
4745 /* Now see if a result clause followed it. */
4746 is_result
= match_result (sym
, result
);
4747 found_match
= MATCH_YES
;
4751 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4752 found_match
= MATCH_ERROR
;
4756 gfc_error ("Unexpected junk after function declaration at %C");
4757 found_match
= MATCH_ERROR
;
4761 if (is_bind_c
== MATCH_YES
)
4763 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4764 if (gfc_current_state () == COMP_CONTAINS
4765 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4766 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4767 "at %L may not be specified for an internal "
4768 "procedure", &gfc_current_locus
))
4771 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4779 /* Procedure pointer return value without RESULT statement:
4780 Add "hidden" result variable named "ppr@". */
4783 add_hidden_procptr_result (gfc_symbol
*sym
)
4787 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4790 /* First usage case: PROCEDURE and EXTERNAL statements. */
4791 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4792 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4793 && sym
->attr
.external
;
4794 /* Second usage case: INTERFACE statements. */
4795 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4796 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4797 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4803 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4807 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4808 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4809 st2
->n
.sym
= stree
->n
.sym
;
4811 sym
->result
= stree
->n
.sym
;
4813 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4814 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4815 sym
->result
->attr
.external
= sym
->attr
.external
;
4816 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4817 sym
->result
->ts
= sym
->ts
;
4818 sym
->attr
.proc_pointer
= 0;
4819 sym
->attr
.pointer
= 0;
4820 sym
->attr
.external
= 0;
4821 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4823 sym
->result
->attr
.pointer
= 0;
4824 sym
->result
->attr
.proc_pointer
= 1;
4827 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4829 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4830 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4831 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4832 && sym
== gfc_current_ns
->proc_name
4833 && sym
== sym
->result
->ns
->proc_name
4834 && strcmp ("ppr@", sym
->result
->name
) == 0)
4836 sym
->result
->attr
.proc_pointer
= 1;
4837 sym
->attr
.pointer
= 0;
4845 /* Match the interface for a PROCEDURE declaration,
4846 including brackets (R1212). */
4849 match_procedure_interface (gfc_symbol
**proc_if
)
4853 locus old_loc
, entry_loc
;
4854 gfc_namespace
*old_ns
= gfc_current_ns
;
4855 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4857 old_loc
= entry_loc
= gfc_current_locus
;
4858 gfc_clear_ts (¤t_ts
);
4860 if (gfc_match (" (") != MATCH_YES
)
4862 gfc_current_locus
= entry_loc
;
4866 /* Get the type spec. for the procedure interface. */
4867 old_loc
= gfc_current_locus
;
4868 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4869 gfc_gobble_whitespace ();
4870 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4873 if (m
== MATCH_ERROR
)
4876 /* Procedure interface is itself a procedure. */
4877 gfc_current_locus
= old_loc
;
4878 m
= gfc_match_name (name
);
4880 /* First look to see if it is already accessible in the current
4881 namespace because it is use associated or contained. */
4883 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
4886 /* If it is still not found, then try the parent namespace, if it
4887 exists and create the symbol there if it is still not found. */
4888 if (gfc_current_ns
->parent
)
4889 gfc_current_ns
= gfc_current_ns
->parent
;
4890 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
4893 gfc_current_ns
= old_ns
;
4894 *proc_if
= st
->n
.sym
;
4899 /* Resolve interface if possible. That way, attr.procedure is only set
4900 if it is declared by a later procedure-declaration-stmt, which is
4901 invalid per F08:C1216 (cf. resolve_procedure_interface). */
4902 while ((*proc_if
)->ts
.interface
)
4903 *proc_if
= (*proc_if
)->ts
.interface
;
4905 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
4906 && (*proc_if
)->ts
.type
== BT_UNKNOWN
4907 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
4908 (*proc_if
)->name
, NULL
))
4913 if (gfc_match (" )") != MATCH_YES
)
4915 gfc_current_locus
= entry_loc
;
4923 /* Match a PROCEDURE declaration (R1211). */
4926 match_procedure_decl (void)
4929 gfc_symbol
*sym
, *proc_if
= NULL
;
4931 gfc_expr
*initializer
= NULL
;
4933 /* Parse interface (with brackets). */
4934 m
= match_procedure_interface (&proc_if
);
4938 /* Parse attributes (with colons). */
4939 m
= match_attr_spec();
4940 if (m
== MATCH_ERROR
)
4943 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
4945 current_attr
.is_bind_c
= 1;
4946 has_name_equals
= 0;
4947 curr_binding_label
= NULL
;
4950 /* Get procedure symbols. */
4953 m
= gfc_match_symbol (&sym
, 0);
4956 else if (m
== MATCH_ERROR
)
4959 /* Add current_attr to the symbol attributes. */
4960 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
4963 if (sym
->attr
.is_bind_c
)
4965 /* Check for C1218. */
4966 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
4968 gfc_error ("BIND(C) attribute at %C requires "
4969 "an interface with BIND(C)");
4972 /* Check for C1217. */
4973 if (has_name_equals
&& sym
->attr
.pointer
)
4975 gfc_error ("BIND(C) procedure with NAME may not have "
4976 "POINTER attribute at %C");
4979 if (has_name_equals
&& sym
->attr
.dummy
)
4981 gfc_error ("Dummy procedure at %C may not have "
4982 "BIND(C) attribute with NAME");
4985 /* Set binding label for BIND(C). */
4986 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
4990 if (!gfc_add_external (&sym
->attr
, NULL
))
4993 if (add_hidden_procptr_result (sym
))
4996 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
4999 /* Set interface. */
5000 if (proc_if
!= NULL
)
5002 if (sym
->ts
.type
!= BT_UNKNOWN
)
5004 gfc_error ("Procedure %qs at %L already has basic type of %s",
5005 sym
->name
, &gfc_current_locus
,
5006 gfc_basic_typename (sym
->ts
.type
));
5009 sym
->ts
.interface
= proc_if
;
5010 sym
->attr
.untyped
= 1;
5011 sym
->attr
.if_source
= IFSRC_IFBODY
;
5013 else if (current_ts
.type
!= BT_UNKNOWN
)
5015 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5017 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5018 sym
->ts
.interface
->ts
= current_ts
;
5019 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5020 sym
->ts
.interface
->attr
.function
= 1;
5021 sym
->attr
.function
= 1;
5022 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5025 if (gfc_match (" =>") == MATCH_YES
)
5027 if (!current_attr
.pointer
)
5029 gfc_error ("Initialization at %C isn't for a pointer variable");
5034 m
= match_pointer_init (&initializer
, 1);
5038 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5043 if (gfc_match_eos () == MATCH_YES
)
5045 if (gfc_match_char (',') != MATCH_YES
)
5050 gfc_error ("Syntax error in PROCEDURE statement at %C");
5054 /* Free stuff up and return. */
5055 gfc_free_expr (initializer
);
5061 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5064 /* Match a procedure pointer component declaration (R445). */
5067 match_ppc_decl (void)
5070 gfc_symbol
*proc_if
= NULL
;
5074 gfc_expr
*initializer
= NULL
;
5075 gfc_typebound_proc
* tb
;
5076 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5078 /* Parse interface (with brackets). */
5079 m
= match_procedure_interface (&proc_if
);
5083 /* Parse attributes. */
5084 tb
= XCNEW (gfc_typebound_proc
);
5085 tb
->where
= gfc_current_locus
;
5086 m
= match_binding_attributes (tb
, false, true);
5087 if (m
== MATCH_ERROR
)
5090 gfc_clear_attr (¤t_attr
);
5091 current_attr
.procedure
= 1;
5092 current_attr
.proc_pointer
= 1;
5093 current_attr
.access
= tb
->access
;
5094 current_attr
.flavor
= FL_PROCEDURE
;
5096 /* Match the colons (required). */
5097 if (gfc_match (" ::") != MATCH_YES
)
5099 gfc_error ("Expected '::' after binding-attributes at %C");
5103 /* Check for C450. */
5104 if (!tb
->nopass
&& proc_if
== NULL
)
5106 gfc_error("NOPASS or explicit interface required at %C");
5110 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5113 /* Match PPC names. */
5117 m
= gfc_match_name (name
);
5120 else if (m
== MATCH_ERROR
)
5123 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5126 /* Add current_attr to the symbol attributes. */
5127 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5130 if (!gfc_add_external (&c
->attr
, NULL
))
5133 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5140 c
->tb
= XCNEW (gfc_typebound_proc
);
5141 c
->tb
->where
= gfc_current_locus
;
5145 /* Set interface. */
5146 if (proc_if
!= NULL
)
5148 c
->ts
.interface
= proc_if
;
5149 c
->attr
.untyped
= 1;
5150 c
->attr
.if_source
= IFSRC_IFBODY
;
5152 else if (ts
.type
!= BT_UNKNOWN
)
5155 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5156 c
->ts
.interface
->result
= c
->ts
.interface
;
5157 c
->ts
.interface
->ts
= ts
;
5158 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5159 c
->ts
.interface
->attr
.function
= 1;
5160 c
->attr
.function
= 1;
5161 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5164 if (gfc_match (" =>") == MATCH_YES
)
5166 m
= match_pointer_init (&initializer
, 1);
5169 gfc_free_expr (initializer
);
5172 c
->initializer
= initializer
;
5175 if (gfc_match_eos () == MATCH_YES
)
5177 if (gfc_match_char (',') != MATCH_YES
)
5182 gfc_error ("Syntax error in procedure pointer component at %C");
5187 /* Match a PROCEDURE declaration inside an interface (R1206). */
5190 match_procedure_in_interface (void)
5194 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5197 if (current_interface
.type
== INTERFACE_NAMELESS
5198 || current_interface
.type
== INTERFACE_ABSTRACT
)
5200 gfc_error ("PROCEDURE at %C must be in a generic interface");
5204 /* Check if the F2008 optional double colon appears. */
5205 gfc_gobble_whitespace ();
5206 old_locus
= gfc_current_locus
;
5207 if (gfc_match ("::") == MATCH_YES
)
5209 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5210 "MODULE PROCEDURE statement at %L", &old_locus
))
5214 gfc_current_locus
= old_locus
;
5218 m
= gfc_match_name (name
);
5221 else if (m
== MATCH_ERROR
)
5223 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5226 if (!gfc_add_interface (sym
))
5229 if (gfc_match_eos () == MATCH_YES
)
5231 if (gfc_match_char (',') != MATCH_YES
)
5238 gfc_error ("Syntax error in PROCEDURE statement at %C");
5243 /* General matcher for PROCEDURE declarations. */
5245 static match
match_procedure_in_type (void);
5248 gfc_match_procedure (void)
5252 switch (gfc_current_state ())
5257 case COMP_SUBROUTINE
:
5260 m
= match_procedure_decl ();
5262 case COMP_INTERFACE
:
5263 m
= match_procedure_in_interface ();
5266 m
= match_ppc_decl ();
5268 case COMP_DERIVED_CONTAINS
:
5269 m
= match_procedure_in_type ();
5278 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5285 /* Warn if a matched procedure has the same name as an intrinsic; this is
5286 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5287 parser-state-stack to find out whether we're in a module. */
5290 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5294 in_module
= (gfc_state_stack
->previous
5295 && gfc_state_stack
->previous
->state
== COMP_MODULE
);
5297 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5301 /* Match a function declaration. */
5304 gfc_match_function_decl (void)
5306 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5307 gfc_symbol
*sym
, *result
;
5311 match found_match
; /* Status returned by match func. */
5313 if (gfc_current_state () != COMP_NONE
5314 && gfc_current_state () != COMP_INTERFACE
5315 && gfc_current_state () != COMP_CONTAINS
)
5318 gfc_clear_ts (¤t_ts
);
5320 old_loc
= gfc_current_locus
;
5322 m
= gfc_match_prefix (¤t_ts
);
5325 gfc_current_locus
= old_loc
;
5329 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5331 gfc_current_locus
= old_loc
;
5334 if (get_proc_name (name
, &sym
, false))
5337 if (add_hidden_procptr_result (sym
))
5340 gfc_new_block
= sym
;
5342 m
= gfc_match_formal_arglist (sym
, 0, 0);
5345 gfc_error ("Expected formal argument list in function "
5346 "definition at %C");
5350 else if (m
== MATCH_ERROR
)
5355 /* According to the draft, the bind(c) and result clause can
5356 come in either order after the formal_arg_list (i.e., either
5357 can be first, both can exist together or by themselves or neither
5358 one). Therefore, the match_result can't match the end of the
5359 string, and check for the bind(c) or result clause in either order. */
5360 found_match
= gfc_match_eos ();
5362 /* Make sure that it isn't already declared as BIND(C). If it is, it
5363 must have been marked BIND(C) with a BIND(C) attribute and that is
5364 not allowed for procedures. */
5365 if (sym
->attr
.is_bind_c
== 1)
5367 sym
->attr
.is_bind_c
= 0;
5368 if (sym
->old_symbol
!= NULL
)
5369 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5370 "variables or common blocks",
5371 &(sym
->old_symbol
->declared_at
));
5373 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5374 "variables or common blocks", &gfc_current_locus
);
5377 if (found_match
!= MATCH_YES
)
5379 /* If we haven't found the end-of-statement, look for a suffix. */
5380 suffix_match
= gfc_match_suffix (sym
, &result
);
5381 if (suffix_match
== MATCH_YES
)
5382 /* Need to get the eos now. */
5383 found_match
= gfc_match_eos ();
5385 found_match
= suffix_match
;
5388 if(found_match
!= MATCH_YES
)
5392 /* Make changes to the symbol. */
5395 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5398 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5399 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5402 /* Delay matching the function characteristics until after the
5403 specification block by signalling kind=-1. */
5404 sym
->declared_at
= old_loc
;
5405 if (current_ts
.type
!= BT_UNKNOWN
)
5406 current_ts
.kind
= -1;
5408 current_ts
.kind
= 0;
5412 if (current_ts
.type
!= BT_UNKNOWN
5413 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5419 if (current_ts
.type
!= BT_UNKNOWN
5420 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5422 sym
->result
= result
;
5425 /* Warn if this procedure has the same name as an intrinsic. */
5426 do_warn_intrinsic_shadow (sym
, true);
5432 gfc_current_locus
= old_loc
;
5437 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5438 pass the name of the entry, rather than the gfc_current_block name, and
5439 to return false upon finding an existing global entry. */
5442 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5446 enum gfc_symbol_type type
;
5448 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5450 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5451 name is a global identifier. */
5452 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5454 s
= gfc_get_gsymbol (name
);
5456 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5458 gfc_global_used (s
, where
);
5467 s
->ns
= gfc_current_ns
;
5471 /* Don't add the symbol multiple times. */
5473 && (!gfc_notification_std (GFC_STD_F2008
)
5474 || strcmp (name
, binding_label
) != 0))
5476 s
= gfc_get_gsymbol (binding_label
);
5478 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5480 gfc_global_used (s
, where
);
5487 s
->binding_label
= binding_label
;
5490 s
->ns
= gfc_current_ns
;
5498 /* Match an ENTRY statement. */
5501 gfc_match_entry (void)
5506 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5507 gfc_compile_state state
;
5511 bool module_procedure
;
5515 m
= gfc_match_name (name
);
5519 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5522 state
= gfc_current_state ();
5523 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5528 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5531 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5533 case COMP_BLOCK_DATA
:
5534 gfc_error ("ENTRY statement at %C cannot appear within "
5537 case COMP_INTERFACE
:
5538 gfc_error ("ENTRY statement at %C cannot appear within "
5542 gfc_error ("ENTRY statement at %C cannot appear within "
5543 "a DERIVED TYPE block");
5546 gfc_error ("ENTRY statement at %C cannot appear within "
5547 "an IF-THEN block");
5550 case COMP_DO_CONCURRENT
:
5551 gfc_error ("ENTRY statement at %C cannot appear within "
5555 gfc_error ("ENTRY statement at %C cannot appear within "
5559 gfc_error ("ENTRY statement at %C cannot appear within "
5563 gfc_error ("ENTRY statement at %C cannot appear within "
5567 gfc_error ("ENTRY statement at %C cannot appear within "
5568 "a contained subprogram");
5571 gfc_internal_error ("gfc_match_entry(): Bad state");
5576 module_procedure
= gfc_current_ns
->parent
!= NULL
5577 && gfc_current_ns
->parent
->proc_name
5578 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5581 if (gfc_current_ns
->parent
!= NULL
5582 && gfc_current_ns
->parent
->proc_name
5583 && !module_procedure
)
5585 gfc_error("ENTRY statement at %C cannot appear in a "
5586 "contained procedure");
5590 /* Module function entries need special care in get_proc_name
5591 because previous references within the function will have
5592 created symbols attached to the current namespace. */
5593 if (get_proc_name (name
, &entry
,
5594 gfc_current_ns
->parent
!= NULL
5595 && module_procedure
))
5598 proc
= gfc_current_block ();
5600 /* Make sure that it isn't already declared as BIND(C). If it is, it
5601 must have been marked BIND(C) with a BIND(C) attribute and that is
5602 not allowed for procedures. */
5603 if (entry
->attr
.is_bind_c
== 1)
5605 entry
->attr
.is_bind_c
= 0;
5606 if (entry
->old_symbol
!= NULL
)
5607 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5608 "variables or common blocks",
5609 &(entry
->old_symbol
->declared_at
));
5611 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5612 "variables or common blocks", &gfc_current_locus
);
5615 /* Check what next non-whitespace character is so we can tell if there
5616 is the required parens if we have a BIND(C). */
5617 old_loc
= gfc_current_locus
;
5618 gfc_gobble_whitespace ();
5619 peek_char
= gfc_peek_ascii_char ();
5621 if (state
== COMP_SUBROUTINE
)
5623 m
= gfc_match_formal_arglist (entry
, 0, 1);
5627 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5628 never be an internal procedure. */
5629 is_bind_c
= gfc_match_bind_c (entry
, true);
5630 if (is_bind_c
== MATCH_ERROR
)
5632 if (is_bind_c
== MATCH_YES
)
5634 if (peek_char
!= '(')
5636 gfc_error ("Missing required parentheses before BIND(C) at %C");
5639 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5640 &(entry
->declared_at
), 1))
5644 if (!gfc_current_ns
->parent
5645 && !add_global_entry (name
, entry
->binding_label
, true,
5649 /* An entry in a subroutine. */
5650 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5651 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5656 /* An entry in a function.
5657 We need to take special care because writing
5662 ENTRY f() RESULT (r)
5664 ENTRY f RESULT (r). */
5665 if (gfc_match_eos () == MATCH_YES
)
5667 gfc_current_locus
= old_loc
;
5668 /* Match the empty argument list, and add the interface to
5670 m
= gfc_match_formal_arglist (entry
, 0, 1);
5673 m
= gfc_match_formal_arglist (entry
, 0, 0);
5680 if (gfc_match_eos () == MATCH_YES
)
5682 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5683 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5686 entry
->result
= entry
;
5690 m
= gfc_match_suffix (entry
, &result
);
5692 gfc_syntax_error (ST_ENTRY
);
5698 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5699 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5700 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5702 entry
->result
= result
;
5706 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5707 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5709 entry
->result
= entry
;
5713 if (!gfc_current_ns
->parent
5714 && !add_global_entry (name
, entry
->binding_label
, false,
5719 if (gfc_match_eos () != MATCH_YES
)
5721 gfc_syntax_error (ST_ENTRY
);
5725 entry
->attr
.recursive
= proc
->attr
.recursive
;
5726 entry
->attr
.elemental
= proc
->attr
.elemental
;
5727 entry
->attr
.pure
= proc
->attr
.pure
;
5729 el
= gfc_get_entry_list ();
5731 el
->next
= gfc_current_ns
->entries
;
5732 gfc_current_ns
->entries
= el
;
5734 el
->id
= el
->next
->id
+ 1;
5738 new_st
.op
= EXEC_ENTRY
;
5739 new_st
.ext
.entry
= el
;
5745 /* Match a subroutine statement, including optional prefixes. */
5748 gfc_match_subroutine (void)
5750 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5755 bool allow_binding_name
;
5757 if (gfc_current_state () != COMP_NONE
5758 && gfc_current_state () != COMP_INTERFACE
5759 && gfc_current_state () != COMP_CONTAINS
)
5762 m
= gfc_match_prefix (NULL
);
5766 m
= gfc_match ("subroutine% %n", name
);
5770 if (get_proc_name (name
, &sym
, false))
5773 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5774 the symbol existed before. */
5775 sym
->declared_at
= gfc_current_locus
;
5777 if (add_hidden_procptr_result (sym
))
5780 gfc_new_block
= sym
;
5782 /* Check what next non-whitespace character is so we can tell if there
5783 is the required parens if we have a BIND(C). */
5784 gfc_gobble_whitespace ();
5785 peek_char
= gfc_peek_ascii_char ();
5787 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5790 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5793 /* Make sure that it isn't already declared as BIND(C). If it is, it
5794 must have been marked BIND(C) with a BIND(C) attribute and that is
5795 not allowed for procedures. */
5796 if (sym
->attr
.is_bind_c
== 1)
5798 sym
->attr
.is_bind_c
= 0;
5799 if (sym
->old_symbol
!= NULL
)
5800 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5801 "variables or common blocks",
5802 &(sym
->old_symbol
->declared_at
));
5804 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5805 "variables or common blocks", &gfc_current_locus
);
5808 /* C binding names are not allowed for internal procedures. */
5809 if (gfc_current_state () == COMP_CONTAINS
5810 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5811 allow_binding_name
= false;
5813 allow_binding_name
= true;
5815 /* Here, we are just checking if it has the bind(c) attribute, and if
5816 so, then we need to make sure it's all correct. If it doesn't,
5817 we still need to continue matching the rest of the subroutine line. */
5818 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5819 if (is_bind_c
== MATCH_ERROR
)
5821 /* There was an attempt at the bind(c), but it was wrong. An
5822 error message should have been printed w/in the gfc_match_bind_c
5823 so here we'll just return the MATCH_ERROR. */
5827 if (is_bind_c
== MATCH_YES
)
5829 /* The following is allowed in the Fortran 2008 draft. */
5830 if (gfc_current_state () == COMP_CONTAINS
5831 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5832 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5833 "at %L may not be specified for an internal "
5834 "procedure", &gfc_current_locus
))
5837 if (peek_char
!= '(')
5839 gfc_error ("Missing required parentheses before BIND(C) at %C");
5842 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5843 &(sym
->declared_at
), 1))
5847 if (gfc_match_eos () != MATCH_YES
)
5849 gfc_syntax_error (ST_SUBROUTINE
);
5853 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5856 /* Warn if it has the same name as an intrinsic. */
5857 do_warn_intrinsic_shadow (sym
, false);
5863 /* Check that the NAME identifier in a BIND attribute or statement
5864 is conform to C identifier rules. */
5867 check_bind_name_identifier (char **name
)
5869 char *n
= *name
, *p
;
5871 /* Remove leading spaces. */
5875 /* On an empty string, free memory and set name to NULL. */
5883 /* Remove trailing spaces. */
5884 p
= n
+ strlen(n
) - 1;
5888 /* Insert the identifier into the symbol table. */
5893 /* Now check that identifier is valid under C rules. */
5896 gfc_error ("Invalid C identifier in NAME= specifier at %C");
5901 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
5903 gfc_error ("Invalid C identifier in NAME= specifier at %C");
5911 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
5912 given, and set the binding label in either the given symbol (if not
5913 NULL), or in the current_ts. The symbol may be NULL because we may
5914 encounter the BIND(C) before the declaration itself. Return
5915 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
5916 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
5917 or MATCH_YES if the specifier was correct and the binding label and
5918 bind(c) fields were set correctly for the given symbol or the
5919 current_ts. If allow_binding_name is false, no binding name may be
5923 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
5925 char *binding_label
= NULL
;
5928 /* Initialize the flag that specifies whether we encountered a NAME=
5929 specifier or not. */
5930 has_name_equals
= 0;
5932 /* This much we have to be able to match, in this order, if
5933 there is a bind(c) label. */
5934 if (gfc_match (" bind ( c ") != MATCH_YES
)
5937 /* Now see if there is a binding label, or if we've reached the
5938 end of the bind(c) attribute without one. */
5939 if (gfc_match_char (',') == MATCH_YES
)
5941 if (gfc_match (" name = ") != MATCH_YES
)
5943 gfc_error ("Syntax error in NAME= specifier for binding label "
5945 /* should give an error message here */
5949 has_name_equals
= 1;
5951 if (gfc_match_init_expr (&e
) != MATCH_YES
)
5957 if (!gfc_simplify_expr(e
, 0))
5959 gfc_error ("NAME= specifier at %C should be a constant expression");
5964 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
5965 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
5967 gfc_error ("NAME= specifier at %C should be a scalar of "
5968 "default character kind");
5973 // Get a C string from the Fortran string constant
5974 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
5975 e
->value
.character
.length
);
5978 // Check that it is valid (old gfc_match_name_C)
5979 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
5983 /* Get the required right paren. */
5984 if (gfc_match_char (')') != MATCH_YES
)
5986 gfc_error ("Missing closing paren for binding label at %C");
5990 if (has_name_equals
&& !allow_binding_name
)
5992 gfc_error ("No binding name is allowed in BIND(C) at %C");
5996 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
5998 gfc_error ("For dummy procedure %s, no binding name is "
5999 "allowed in BIND(C) at %C", sym
->name
);
6004 /* Save the binding label to the symbol. If sym is null, we're
6005 probably matching the typespec attributes of a declaration and
6006 haven't gotten the name yet, and therefore, no symbol yet. */
6010 sym
->binding_label
= binding_label
;
6012 curr_binding_label
= binding_label
;
6014 else if (allow_binding_name
)
6016 /* No binding label, but if symbol isn't null, we
6017 can set the label for it here.
6018 If name="" or allow_binding_name is false, no C binding name is
6020 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6021 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6024 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6025 && current_interface
.type
== INTERFACE_ABSTRACT
)
6027 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6035 /* Return nonzero if we're currently compiling a contained procedure. */
6038 contained_procedure (void)
6040 gfc_state_data
*s
= gfc_state_stack
;
6042 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6043 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6049 /* Set the kind of each enumerator. The kind is selected such that it is
6050 interoperable with the corresponding C enumeration type, making
6051 sure that -fshort-enums is honored. */
6056 enumerator_history
*current_history
= NULL
;
6060 if (max_enum
== NULL
|| enum_history
== NULL
)
6063 if (!flag_short_enums
)
6069 kind
= gfc_integer_kinds
[i
++].kind
;
6071 while (kind
< gfc_c_int_kind
6072 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6075 current_history
= enum_history
;
6076 while (current_history
!= NULL
)
6078 current_history
->sym
->ts
.kind
= kind
;
6079 current_history
= current_history
->next
;
6084 /* Match any of the various end-block statements. Returns the type of
6085 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6086 and END BLOCK statements cannot be replaced by a single END statement. */
6089 gfc_match_end (gfc_statement
*st
)
6091 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6092 gfc_compile_state state
;
6094 const char *block_name
;
6098 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6099 gfc_namespace
**nsp
;
6101 old_loc
= gfc_current_locus
;
6102 if (gfc_match ("end") != MATCH_YES
)
6105 state
= gfc_current_state ();
6106 block_name
= gfc_current_block () == NULL
6107 ? NULL
: gfc_current_block ()->name
;
6111 case COMP_ASSOCIATE
:
6113 if (!strncmp (block_name
, "block@", strlen("block@")))
6118 case COMP_DERIVED_CONTAINS
:
6119 state
= gfc_state_stack
->previous
->state
;
6120 block_name
= gfc_state_stack
->previous
->sym
== NULL
6121 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6132 *st
= ST_END_PROGRAM
;
6133 target
= " program";
6137 case COMP_SUBROUTINE
:
6138 *st
= ST_END_SUBROUTINE
;
6139 target
= " subroutine";
6140 eos_ok
= !contained_procedure ();
6144 *st
= ST_END_FUNCTION
;
6145 target
= " function";
6146 eos_ok
= !contained_procedure ();
6149 case COMP_BLOCK_DATA
:
6150 *st
= ST_END_BLOCK_DATA
;
6151 target
= " block data";
6156 *st
= ST_END_MODULE
;
6161 case COMP_INTERFACE
:
6162 *st
= ST_END_INTERFACE
;
6163 target
= " interface";
6168 case COMP_DERIVED_CONTAINS
:
6174 case COMP_ASSOCIATE
:
6175 *st
= ST_END_ASSOCIATE
;
6176 target
= " associate";
6193 case COMP_DO_CONCURRENT
:
6200 *st
= ST_END_CRITICAL
;
6201 target
= " critical";
6206 case COMP_SELECT_TYPE
:
6207 *st
= ST_END_SELECT
;
6213 *st
= ST_END_FORALL
;
6228 last_initializer
= NULL
;
6230 gfc_free_enum_history ();
6234 gfc_error ("Unexpected END statement at %C");
6238 old_loc
= gfc_current_locus
;
6239 if (gfc_match_eos () == MATCH_YES
)
6241 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6243 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6244 "instead of %s statement at %L",
6245 gfc_ascii_statement(*st
), &old_loc
))
6250 /* We would have required END [something]. */
6251 gfc_error ("%s statement expected at %L",
6252 gfc_ascii_statement (*st
), &old_loc
);
6259 /* Verify that we've got the sort of end-block that we're expecting. */
6260 if (gfc_match (target
) != MATCH_YES
)
6262 gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st
),
6267 old_loc
= gfc_current_locus
;
6268 /* If we're at the end, make sure a block name wasn't required. */
6269 if (gfc_match_eos () == MATCH_YES
)
6272 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6273 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6274 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6280 gfc_error ("Expected block name of %qs in %s statement at %L",
6281 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6286 /* END INTERFACE has a special handler for its several possible endings. */
6287 if (*st
== ST_END_INTERFACE
)
6288 return gfc_match_end_interface ();
6290 /* We haven't hit the end of statement, so what is left must be an
6292 m
= gfc_match_space ();
6294 m
= gfc_match_name (name
);
6297 gfc_error ("Expected terminating name at %C");
6301 if (block_name
== NULL
)
6304 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6306 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6307 gfc_ascii_statement (*st
));
6310 /* Procedure pointer as function result. */
6311 else if (strcmp (block_name
, "ppr@") == 0
6312 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6314 gfc_error ("Expected label %qs for %s statement at %C",
6315 gfc_current_block ()->ns
->proc_name
->name
,
6316 gfc_ascii_statement (*st
));
6320 if (gfc_match_eos () == MATCH_YES
)
6324 gfc_syntax_error (*st
);
6327 gfc_current_locus
= old_loc
;
6329 /* If we are missing an END BLOCK, we created a half-ready namespace.
6330 Remove it from the parent namespace's sibling list. */
6332 if (state
== COMP_BLOCK
)
6334 parent_ns
= gfc_current_ns
->parent
;
6336 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6342 if (ns
== gfc_current_ns
)
6344 if (prev_ns
== NULL
)
6347 prev_ns
->sibling
= ns
->sibling
;
6353 gfc_free_namespace (gfc_current_ns
);
6354 gfc_current_ns
= parent_ns
;
6362 /***************** Attribute declaration statements ****************/
6364 /* Set the attribute of a single variable. */
6369 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6377 m
= gfc_match_name (name
);
6381 if (find_special (name
, &sym
, false))
6384 if (!check_function_name (name
))
6390 var_locus
= gfc_current_locus
;
6392 /* Deal with possible array specification for certain attributes. */
6393 if (current_attr
.dimension
6394 || current_attr
.codimension
6395 || current_attr
.allocatable
6396 || current_attr
.pointer
6397 || current_attr
.target
)
6399 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6400 !current_attr
.dimension
6401 && !current_attr
.pointer
6402 && !current_attr
.target
);
6403 if (m
== MATCH_ERROR
)
6406 if (current_attr
.dimension
&& m
== MATCH_NO
)
6408 gfc_error ("Missing array specification at %L in DIMENSION "
6409 "statement", &var_locus
);
6414 if (current_attr
.dimension
&& sym
->value
)
6416 gfc_error ("Dimensions specified for %s at %L after its "
6417 "initialisation", sym
->name
, &var_locus
);
6422 if (current_attr
.codimension
&& m
== MATCH_NO
)
6424 gfc_error ("Missing array specification at %L in CODIMENSION "
6425 "statement", &var_locus
);
6430 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6431 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6433 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6439 /* Update symbol table. DIMENSION attribute is set in
6440 gfc_set_array_spec(). For CLASS variables, this must be applied
6441 to the first component, or '_data' field. */
6442 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6444 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6452 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6453 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6460 if (sym
->ts
.type
== BT_CLASS
6461 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6467 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6473 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6475 /* Fix the array spec. */
6476 m
= gfc_mod_pointee_as (sym
->as
);
6477 if (m
== MATCH_ERROR
)
6481 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6487 if ((current_attr
.external
|| current_attr
.intrinsic
)
6488 && sym
->attr
.flavor
!= FL_PROCEDURE
6489 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6495 add_hidden_procptr_result (sym
);
6500 gfc_free_array_spec (as
);
6505 /* Generic attribute declaration subroutine. Used for attributes that
6506 just have a list of names. */
6513 /* Gobble the optional double colon, by simply ignoring the result
6523 if (gfc_match_eos () == MATCH_YES
)
6529 if (gfc_match_char (',') != MATCH_YES
)
6531 gfc_error ("Unexpected character in variable list at %C");
6541 /* This routine matches Cray Pointer declarations of the form:
6542 pointer ( <pointer>, <pointee> )
6544 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6545 The pointer, if already declared, should be an integer. Otherwise, we
6546 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6547 be either a scalar, or an array declaration. No space is allocated for
6548 the pointee. For the statement
6549 pointer (ipt, ar(10))
6550 any subsequent uses of ar will be translated (in C-notation) as
6551 ar(i) => ((<type> *) ipt)(i)
6552 After gimplification, pointee variable will disappear in the code. */
6555 cray_pointer_decl (void)
6558 gfc_array_spec
*as
= NULL
;
6559 gfc_symbol
*cptr
; /* Pointer symbol. */
6560 gfc_symbol
*cpte
; /* Pointee symbol. */
6566 if (gfc_match_char ('(') != MATCH_YES
)
6568 gfc_error ("Expected '(' at %C");
6572 /* Match pointer. */
6573 var_locus
= gfc_current_locus
;
6574 gfc_clear_attr (¤t_attr
);
6575 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6576 current_ts
.type
= BT_INTEGER
;
6577 current_ts
.kind
= gfc_index_integer_kind
;
6579 m
= gfc_match_symbol (&cptr
, 0);
6582 gfc_error ("Expected variable name at %C");
6586 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6589 gfc_set_sym_referenced (cptr
);
6591 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6593 cptr
->ts
.type
= BT_INTEGER
;
6594 cptr
->ts
.kind
= gfc_index_integer_kind
;
6596 else if (cptr
->ts
.type
!= BT_INTEGER
)
6598 gfc_error ("Cray pointer at %C must be an integer");
6601 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6602 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
6603 " memory addresses require %d bytes",
6604 cptr
->ts
.kind
, gfc_index_integer_kind
);
6606 if (gfc_match_char (',') != MATCH_YES
)
6608 gfc_error ("Expected \",\" at %C");
6612 /* Match Pointee. */
6613 var_locus
= gfc_current_locus
;
6614 gfc_clear_attr (¤t_attr
);
6615 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6616 current_ts
.type
= BT_UNKNOWN
;
6617 current_ts
.kind
= 0;
6619 m
= gfc_match_symbol (&cpte
, 0);
6622 gfc_error ("Expected variable name at %C");
6626 /* Check for an optional array spec. */
6627 m
= gfc_match_array_spec (&as
, true, false);
6628 if (m
== MATCH_ERROR
)
6630 gfc_free_array_spec (as
);
6633 else if (m
== MATCH_NO
)
6635 gfc_free_array_spec (as
);
6639 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6642 gfc_set_sym_referenced (cpte
);
6644 if (cpte
->as
== NULL
)
6646 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6647 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6649 else if (as
!= NULL
)
6651 gfc_error ("Duplicate array spec for Cray pointee at %C");
6652 gfc_free_array_spec (as
);
6658 if (cpte
->as
!= NULL
)
6660 /* Fix array spec. */
6661 m
= gfc_mod_pointee_as (cpte
->as
);
6662 if (m
== MATCH_ERROR
)
6666 /* Point the Pointee at the Pointer. */
6667 cpte
->cp_pointer
= cptr
;
6669 if (gfc_match_char (')') != MATCH_YES
)
6671 gfc_error ("Expected \")\" at %C");
6674 m
= gfc_match_char (',');
6676 done
= true; /* Stop searching for more declarations. */
6680 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6681 || gfc_match_eos () != MATCH_YES
)
6683 gfc_error ("Expected \",\" or end of statement at %C");
6691 gfc_match_external (void)
6694 gfc_clear_attr (¤t_attr
);
6695 current_attr
.external
= 1;
6697 return attr_decl ();
6702 gfc_match_intent (void)
6706 /* This is not allowed within a BLOCK construct! */
6707 if (gfc_current_state () == COMP_BLOCK
)
6709 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6713 intent
= match_intent_spec ();
6714 if (intent
== INTENT_UNKNOWN
)
6717 gfc_clear_attr (¤t_attr
);
6718 current_attr
.intent
= intent
;
6720 return attr_decl ();
6725 gfc_match_intrinsic (void)
6728 gfc_clear_attr (¤t_attr
);
6729 current_attr
.intrinsic
= 1;
6731 return attr_decl ();
6736 gfc_match_optional (void)
6738 /* This is not allowed within a BLOCK construct! */
6739 if (gfc_current_state () == COMP_BLOCK
)
6741 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6745 gfc_clear_attr (¤t_attr
);
6746 current_attr
.optional
= 1;
6748 return attr_decl ();
6753 gfc_match_pointer (void)
6755 gfc_gobble_whitespace ();
6756 if (gfc_peek_ascii_char () == '(')
6758 if (!gfc_option
.flag_cray_pointer
)
6760 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6764 return cray_pointer_decl ();
6768 gfc_clear_attr (¤t_attr
);
6769 current_attr
.pointer
= 1;
6771 return attr_decl ();
6777 gfc_match_allocatable (void)
6779 gfc_clear_attr (¤t_attr
);
6780 current_attr
.allocatable
= 1;
6782 return attr_decl ();
6787 gfc_match_codimension (void)
6789 gfc_clear_attr (¤t_attr
);
6790 current_attr
.codimension
= 1;
6792 return attr_decl ();
6797 gfc_match_contiguous (void)
6799 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6802 gfc_clear_attr (¤t_attr
);
6803 current_attr
.contiguous
= 1;
6805 return attr_decl ();
6810 gfc_match_dimension (void)
6812 gfc_clear_attr (¤t_attr
);
6813 current_attr
.dimension
= 1;
6815 return attr_decl ();
6820 gfc_match_target (void)
6822 gfc_clear_attr (¤t_attr
);
6823 current_attr
.target
= 1;
6825 return attr_decl ();
6829 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6833 access_attr_decl (gfc_statement st
)
6835 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6836 interface_type type
;
6838 gfc_symbol
*sym
, *dt_sym
;
6839 gfc_intrinsic_op op
;
6842 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6847 m
= gfc_match_generic_spec (&type
, name
, &op
);
6850 if (m
== MATCH_ERROR
)
6855 case INTERFACE_NAMELESS
:
6856 case INTERFACE_ABSTRACT
:
6859 case INTERFACE_GENERIC
:
6860 if (gfc_get_symbol (name
, NULL
, &sym
))
6863 if (!gfc_add_access (&sym
->attr
,
6865 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6869 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
6870 && !gfc_add_access (&dt_sym
->attr
,
6872 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6878 case INTERFACE_INTRINSIC_OP
:
6879 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
6881 gfc_intrinsic_op other_op
;
6883 gfc_current_ns
->operator_access
[op
] =
6884 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6886 /* Handle the case if there is another op with the same
6887 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
6888 other_op
= gfc_equivalent_op (op
);
6890 if (other_op
!= INTRINSIC_NONE
)
6891 gfc_current_ns
->operator_access
[other_op
] =
6892 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6897 gfc_error ("Access specification of the %s operator at %C has "
6898 "already been specified", gfc_op2string (op
));
6904 case INTERFACE_USER_OP
:
6905 uop
= gfc_get_uop (name
);
6907 if (uop
->access
== ACCESS_UNKNOWN
)
6909 uop
->access
= (st
== ST_PUBLIC
)
6910 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6914 gfc_error ("Access specification of the .%s. operator at %C "
6915 "has already been specified", sym
->name
);
6922 if (gfc_match_char (',') == MATCH_NO
)
6926 if (gfc_match_eos () != MATCH_YES
)
6931 gfc_syntax_error (st
);
6939 gfc_match_protected (void)
6944 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6946 gfc_error ("PROTECTED at %C only allowed in specification "
6947 "part of a module");
6952 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
6955 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6960 if (gfc_match_eos () == MATCH_YES
)
6965 m
= gfc_match_symbol (&sym
, 0);
6969 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
6981 if (gfc_match_eos () == MATCH_YES
)
6983 if (gfc_match_char (',') != MATCH_YES
)
6990 gfc_error ("Syntax error in PROTECTED statement at %C");
6995 /* The PRIVATE statement is a bit weird in that it can be an attribute
6996 declaration, but also works as a standalone statement inside of a
6997 type declaration or a module. */
7000 gfc_match_private (gfc_statement
*st
)
7003 if (gfc_match ("private") != MATCH_YES
)
7006 if (gfc_current_state () != COMP_MODULE
7007 && !(gfc_current_state () == COMP_DERIVED
7008 && gfc_state_stack
->previous
7009 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7010 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7011 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7012 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7014 gfc_error ("PRIVATE statement at %C is only allowed in the "
7015 "specification part of a module");
7019 if (gfc_current_state () == COMP_DERIVED
)
7021 if (gfc_match_eos () == MATCH_YES
)
7027 gfc_syntax_error (ST_PRIVATE
);
7031 if (gfc_match_eos () == MATCH_YES
)
7038 return access_attr_decl (ST_PRIVATE
);
7043 gfc_match_public (gfc_statement
*st
)
7046 if (gfc_match ("public") != MATCH_YES
)
7049 if (gfc_current_state () != COMP_MODULE
)
7051 gfc_error ("PUBLIC statement at %C is only allowed in the "
7052 "specification part of a module");
7056 if (gfc_match_eos () == MATCH_YES
)
7063 return access_attr_decl (ST_PUBLIC
);
7067 /* Workhorse for gfc_match_parameter. */
7077 m
= gfc_match_symbol (&sym
, 0);
7079 gfc_error ("Expected variable name at %C in PARAMETER statement");
7084 if (gfc_match_char ('=') == MATCH_NO
)
7086 gfc_error ("Expected = sign in PARAMETER statement at %C");
7090 m
= gfc_match_init_expr (&init
);
7092 gfc_error ("Expected expression at %C in PARAMETER statement");
7096 if (sym
->ts
.type
== BT_UNKNOWN
7097 && !gfc_set_default_type (sym
, 1, NULL
))
7103 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7104 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7112 gfc_error ("Initializing already initialized variable at %C");
7117 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7118 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7121 gfc_free_expr (init
);
7126 /* Match a parameter statement, with the weird syntax that these have. */
7129 gfc_match_parameter (void)
7133 if (gfc_match_char ('(') == MATCH_NO
)
7142 if (gfc_match (" )%t") == MATCH_YES
)
7145 if (gfc_match_char (',') != MATCH_YES
)
7147 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7157 /* Save statements have a special syntax. */
7160 gfc_match_save (void)
7162 char n
[GFC_MAX_SYMBOL_LEN
+1];
7167 if (gfc_match_eos () == MATCH_YES
)
7169 if (gfc_current_ns
->seen_save
)
7171 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7172 "follows previous SAVE statement"))
7176 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7180 if (gfc_current_ns
->save_all
)
7182 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7183 "blanket SAVE statement"))
7191 m
= gfc_match_symbol (&sym
, 0);
7195 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7196 &gfc_current_locus
))
7207 m
= gfc_match (" / %n /", &n
);
7208 if (m
== MATCH_ERROR
)
7213 c
= gfc_get_common (n
, 0);
7216 gfc_current_ns
->seen_save
= 1;
7219 if (gfc_match_eos () == MATCH_YES
)
7221 if (gfc_match_char (',') != MATCH_YES
)
7228 gfc_error ("Syntax error in SAVE statement at %C");
7234 gfc_match_value (void)
7239 /* This is not allowed within a BLOCK construct! */
7240 if (gfc_current_state () == COMP_BLOCK
)
7242 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7246 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7249 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7254 if (gfc_match_eos () == MATCH_YES
)
7259 m
= gfc_match_symbol (&sym
, 0);
7263 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7275 if (gfc_match_eos () == MATCH_YES
)
7277 if (gfc_match_char (',') != MATCH_YES
)
7284 gfc_error ("Syntax error in VALUE statement at %C");
7290 gfc_match_volatile (void)
7295 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7298 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7303 if (gfc_match_eos () == MATCH_YES
)
7308 /* VOLATILE is special because it can be added to host-associated
7309 symbols locally. Except for coarrays. */
7310 m
= gfc_match_symbol (&sym
, 1);
7314 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7315 for variable in a BLOCK which is defined outside of the BLOCK. */
7316 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7318 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7319 "%C, which is use-/host-associated", sym
->name
);
7322 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7334 if (gfc_match_eos () == MATCH_YES
)
7336 if (gfc_match_char (',') != MATCH_YES
)
7343 gfc_error ("Syntax error in VOLATILE statement at %C");
7349 gfc_match_asynchronous (void)
7354 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7357 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7362 if (gfc_match_eos () == MATCH_YES
)
7367 /* ASYNCHRONOUS is special because it can be added to host-associated
7369 m
= gfc_match_symbol (&sym
, 1);
7373 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7385 if (gfc_match_eos () == MATCH_YES
)
7387 if (gfc_match_char (',') != MATCH_YES
)
7394 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7399 /* Match a module procedure statement. Note that we have to modify
7400 symbols in the parent's namespace because the current one was there
7401 to receive symbols that are in an interface's formal argument list. */
7404 gfc_match_modproc (void)
7406 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7410 gfc_namespace
*module_ns
;
7411 gfc_interface
*old_interface_head
, *interface
;
7413 if (gfc_state_stack
->state
!= COMP_INTERFACE
7414 || gfc_state_stack
->previous
== NULL
7415 || current_interface
.type
== INTERFACE_NAMELESS
7416 || current_interface
.type
== INTERFACE_ABSTRACT
)
7418 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7423 module_ns
= gfc_current_ns
->parent
;
7424 for (; module_ns
; module_ns
= module_ns
->parent
)
7425 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7426 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7427 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7428 && !module_ns
->proc_name
->attr
.contained
))
7431 if (module_ns
== NULL
)
7434 /* Store the current state of the interface. We will need it if we
7435 end up with a syntax error and need to recover. */
7436 old_interface_head
= gfc_current_interface_head ();
7438 /* Check if the F2008 optional double colon appears. */
7439 gfc_gobble_whitespace ();
7440 old_locus
= gfc_current_locus
;
7441 if (gfc_match ("::") == MATCH_YES
)
7443 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7444 "MODULE PROCEDURE statement at %L", &old_locus
))
7448 gfc_current_locus
= old_locus
;
7453 old_locus
= gfc_current_locus
;
7455 m
= gfc_match_name (name
);
7461 /* Check for syntax error before starting to add symbols to the
7462 current namespace. */
7463 if (gfc_match_eos () == MATCH_YES
)
7466 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7469 /* Now we're sure the syntax is valid, we process this item
7471 if (gfc_get_symbol (name
, module_ns
, &sym
))
7474 if (sym
->attr
.intrinsic
)
7476 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7477 "PROCEDURE", &old_locus
);
7481 if (sym
->attr
.proc
!= PROC_MODULE
7482 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7485 if (!gfc_add_interface (sym
))
7488 sym
->attr
.mod_proc
= 1;
7489 sym
->declared_at
= old_locus
;
7498 /* Restore the previous state of the interface. */
7499 interface
= gfc_current_interface_head ();
7500 gfc_set_current_interface_head (old_interface_head
);
7502 /* Free the new interfaces. */
7503 while (interface
!= old_interface_head
)
7505 gfc_interface
*i
= interface
->next
;
7510 /* And issue a syntax error. */
7511 gfc_syntax_error (ST_MODULE_PROC
);
7516 /* Check a derived type that is being extended. */
7519 check_extended_derived_type (char *name
)
7521 gfc_symbol
*extended
;
7523 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7525 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7529 extended
= gfc_find_dt_in_generic (extended
);
7534 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7538 if (extended
->attr
.flavor
!= FL_DERIVED
)
7540 gfc_error ("%qs in EXTENDS expression at %C is not a "
7541 "derived type", name
);
7545 if (extended
->attr
.is_bind_c
)
7547 gfc_error ("%qs cannot be extended at %C because it "
7548 "is BIND(C)", extended
->name
);
7552 if (extended
->attr
.sequence
)
7554 gfc_error ("%qs cannot be extended at %C because it "
7555 "is a SEQUENCE type", extended
->name
);
7563 /* Match the optional attribute specifiers for a type declaration.
7564 Return MATCH_ERROR if an error is encountered in one of the handled
7565 attributes (public, private, bind(c)), MATCH_NO if what's found is
7566 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7567 checking on attribute conflicts needs to be done. */
7570 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7572 /* See if the derived type is marked as private. */
7573 if (gfc_match (" , private") == MATCH_YES
)
7575 if (gfc_current_state () != COMP_MODULE
)
7577 gfc_error ("Derived type at %C can only be PRIVATE in the "
7578 "specification part of a module");
7582 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7585 else if (gfc_match (" , public") == MATCH_YES
)
7587 if (gfc_current_state () != COMP_MODULE
)
7589 gfc_error ("Derived type at %C can only be PUBLIC in the "
7590 "specification part of a module");
7594 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7597 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7599 /* If the type is defined to be bind(c) it then needs to make
7600 sure that all fields are interoperable. This will
7601 need to be a semantic check on the finished derived type.
7602 See 15.2.3 (lines 9-12) of F2003 draft. */
7603 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7606 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7608 else if (gfc_match (" , abstract") == MATCH_YES
)
7610 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7613 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7616 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7618 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7624 /* If we get here, something matched. */
7629 /* Match the beginning of a derived type declaration. If a type name
7630 was the result of a function, then it is possible to have a symbol
7631 already to be known as a derived type yet have no components. */
7634 gfc_match_derived_decl (void)
7636 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7637 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7638 symbol_attribute attr
;
7639 gfc_symbol
*sym
, *gensym
;
7640 gfc_symbol
*extended
;
7642 match is_type_attr_spec
= MATCH_NO
;
7643 bool seen_attr
= false;
7644 gfc_interface
*intr
= NULL
, *head
;
7646 if (gfc_current_state () == COMP_DERIVED
)
7651 gfc_clear_attr (&attr
);
7656 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7657 if (is_type_attr_spec
== MATCH_ERROR
)
7659 if (is_type_attr_spec
== MATCH_YES
)
7661 } while (is_type_attr_spec
== MATCH_YES
);
7663 /* Deal with derived type extensions. The extension attribute has
7664 been added to 'attr' but now the parent type must be found and
7667 extended
= check_extended_derived_type (parent
);
7669 if (parent
[0] && !extended
)
7672 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7674 gfc_error ("Expected :: in TYPE definition at %C");
7678 m
= gfc_match (" %n%t", name
);
7682 /* Make sure the name is not the name of an intrinsic type. */
7683 if (gfc_is_intrinsic_typename (name
))
7685 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
7690 if (gfc_get_symbol (name
, NULL
, &gensym
))
7693 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7695 gfc_error ("Derived type name %qs at %C already has a basic type "
7696 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7700 if (!gensym
->attr
.generic
7701 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7704 if (!gensym
->attr
.function
7705 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7708 sym
= gfc_find_dt_in_generic (gensym
);
7710 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7712 gfc_error ("Derived type definition of %qs at %C has already been "
7713 "defined", sym
->name
);
7719 /* Use upper case to save the actual derived-type symbol. */
7720 gfc_get_symbol (gfc_get_string ("%c%s",
7721 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7722 &gensym
->name
[1]), NULL
, &sym
);
7723 sym
->name
= gfc_get_string (gensym
->name
);
7724 head
= gensym
->generic
;
7725 intr
= gfc_get_interface ();
7727 intr
->where
= gfc_current_locus
;
7728 intr
->sym
->declared_at
= gfc_current_locus
;
7730 gensym
->generic
= intr
;
7731 gensym
->attr
.if_source
= IFSRC_DECL
;
7734 /* The symbol may already have the derived attribute without the
7735 components. The ways this can happen is via a function
7736 definition, an INTRINSIC statement or a subtype in another
7737 derived type that is a pointer. The first part of the AND clause
7738 is true if the symbol is not the return value of a function. */
7739 if (sym
->attr
.flavor
!= FL_DERIVED
7740 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
7743 if (attr
.access
!= ACCESS_UNKNOWN
7744 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
7746 else if (sym
->attr
.access
== ACCESS_UNKNOWN
7747 && gensym
->attr
.access
!= ACCESS_UNKNOWN
7748 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
7752 if (sym
->attr
.access
!= ACCESS_UNKNOWN
7753 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
7754 gensym
->attr
.access
= sym
->attr
.access
;
7756 /* See if the derived type was labeled as bind(c). */
7757 if (attr
.is_bind_c
!= 0)
7758 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
7760 /* Construct the f2k_derived namespace if it is not yet there. */
7761 if (!sym
->f2k_derived
)
7762 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7764 if (extended
&& !sym
->components
)
7769 /* Add the extended derived type as the first component. */
7770 gfc_add_component (sym
, parent
, &p
);
7772 gfc_set_sym_referenced (extended
);
7774 p
->ts
.type
= BT_DERIVED
;
7775 p
->ts
.u
.derived
= extended
;
7776 p
->initializer
= gfc_default_initializer (&p
->ts
);
7778 /* Set extension level. */
7779 if (extended
->attr
.extension
== 255)
7781 /* Since the extension field is 8 bit wide, we can only have
7782 up to 255 extension levels. */
7783 gfc_error ("Maximum extension level reached with type %qs at %L",
7784 extended
->name
, &extended
->declared_at
);
7787 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
7789 /* Provide the links between the extended type and its extension. */
7790 if (!extended
->f2k_derived
)
7791 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7792 st
= gfc_new_symtree (&extended
->f2k_derived
->sym_root
, sym
->name
);
7796 if (!sym
->hash_value
)
7797 /* Set the hash for the compound name for this type. */
7798 sym
->hash_value
= gfc_hash_value (sym
);
7800 /* Take over the ABSTRACT attribute. */
7801 sym
->attr
.abstract
= attr
.abstract
;
7803 gfc_new_block
= sym
;
7809 /* Cray Pointees can be declared as:
7810 pointer (ipt, a (n,m,...,*)) */
7813 gfc_mod_pointee_as (gfc_array_spec
*as
)
7815 as
->cray_pointee
= true; /* This will be useful to know later. */
7816 if (as
->type
== AS_ASSUMED_SIZE
)
7817 as
->cp_was_assumed
= true;
7818 else if (as
->type
== AS_ASSUMED_SHAPE
)
7820 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
7827 /* Match the enum definition statement, here we are trying to match
7828 the first line of enum definition statement.
7829 Returns MATCH_YES if match is found. */
7832 gfc_match_enum (void)
7836 m
= gfc_match_eos ();
7840 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
7847 /* Returns an initializer whose value is one higher than the value of the
7848 LAST_INITIALIZER argument. If the argument is NULL, the
7849 initializers value will be set to zero. The initializer's kind
7850 will be set to gfc_c_int_kind.
7852 If -fshort-enums is given, the appropriate kind will be selected
7853 later after all enumerators have been parsed. A warning is issued
7854 here if an initializer exceeds gfc_c_int_kind. */
7857 enum_initializer (gfc_expr
*last_initializer
, locus where
)
7860 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
7862 mpz_init (result
->value
.integer
);
7864 if (last_initializer
!= NULL
)
7866 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
7867 result
->where
= last_initializer
->where
;
7869 if (gfc_check_integer_range (result
->value
.integer
,
7870 gfc_c_int_kind
) != ARITH_OK
)
7872 gfc_error ("Enumerator exceeds the C integer type at %C");
7878 /* Control comes here, if it's the very first enumerator and no
7879 initializer has been given. It will be initialized to zero. */
7880 mpz_set_si (result
->value
.integer
, 0);
7887 /* Match a variable name with an optional initializer. When this
7888 subroutine is called, a variable is expected to be parsed next.
7889 Depending on what is happening at the moment, updates either the
7890 symbol table or the current interface. */
7893 enumerator_decl (void)
7895 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7896 gfc_expr
*initializer
;
7897 gfc_array_spec
*as
= NULL
;
7905 old_locus
= gfc_current_locus
;
7907 /* When we get here, we've just matched a list of attributes and
7908 maybe a type and a double colon. The next thing we expect to see
7909 is the name of the symbol. */
7910 m
= gfc_match_name (name
);
7914 var_locus
= gfc_current_locus
;
7916 /* OK, we've successfully matched the declaration. Now put the
7917 symbol in the current namespace. If we fail to create the symbol,
7919 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
7925 /* The double colon must be present in order to have initializers.
7926 Otherwise the statement is ambiguous with an assignment statement. */
7929 if (gfc_match_char ('=') == MATCH_YES
)
7931 m
= gfc_match_init_expr (&initializer
);
7934 gfc_error ("Expected an initialization expression at %C");
7943 /* If we do not have an initializer, the initialization value of the
7944 previous enumerator (stored in last_initializer) is incremented
7945 by 1 and is used to initialize the current enumerator. */
7946 if (initializer
== NULL
)
7947 initializer
= enum_initializer (last_initializer
, old_locus
);
7949 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
7951 gfc_error ("ENUMERATOR %L not initialized with integer expression",
7957 /* Store this current initializer, for the next enumerator variable
7958 to be parsed. add_init_expr_to_sym() zeros initializer, so we
7959 use last_initializer below. */
7960 last_initializer
= initializer
;
7961 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
7963 /* Maintain enumerator history. */
7964 gfc_find_symbol (name
, NULL
, 0, &sym
);
7965 create_enum_history (sym
, last_initializer
);
7967 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7970 /* Free stuff up and return. */
7971 gfc_free_expr (initializer
);
7977 /* Match the enumerator definition statement. */
7980 gfc_match_enumerator_def (void)
7985 gfc_clear_ts (¤t_ts
);
7987 m
= gfc_match (" enumerator");
7991 m
= gfc_match (" :: ");
7992 if (m
== MATCH_ERROR
)
7995 colon_seen
= (m
== MATCH_YES
);
7997 if (gfc_current_state () != COMP_ENUM
)
7999 gfc_error ("ENUM definition statement expected before %C");
8000 gfc_free_enum_history ();
8004 (¤t_ts
)->type
= BT_INTEGER
;
8005 (¤t_ts
)->kind
= gfc_c_int_kind
;
8007 gfc_clear_attr (¤t_attr
);
8008 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8017 m
= enumerator_decl ();
8018 if (m
== MATCH_ERROR
)
8020 gfc_free_enum_history ();
8026 if (gfc_match_eos () == MATCH_YES
)
8028 if (gfc_match_char (',') != MATCH_YES
)
8032 if (gfc_current_state () == COMP_ENUM
)
8034 gfc_free_enum_history ();
8035 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8040 gfc_free_array_spec (current_as
);
8047 /* Match binding attributes. */
8050 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8052 bool found_passing
= false;
8053 bool seen_ptr
= false;
8054 match m
= MATCH_YES
;
8056 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8057 this case the defaults are in there. */
8058 ba
->access
= ACCESS_UNKNOWN
;
8059 ba
->pass_arg
= NULL
;
8060 ba
->pass_arg_num
= 0;
8062 ba
->non_overridable
= 0;
8066 /* If we find a comma, we believe there are binding attributes. */
8067 m
= gfc_match_char (',');
8073 /* Access specifier. */
8075 m
= gfc_match (" public");
8076 if (m
== MATCH_ERROR
)
8080 if (ba
->access
!= ACCESS_UNKNOWN
)
8082 gfc_error ("Duplicate access-specifier at %C");
8086 ba
->access
= ACCESS_PUBLIC
;
8090 m
= gfc_match (" private");
8091 if (m
== MATCH_ERROR
)
8095 if (ba
->access
!= ACCESS_UNKNOWN
)
8097 gfc_error ("Duplicate access-specifier at %C");
8101 ba
->access
= ACCESS_PRIVATE
;
8105 /* If inside GENERIC, the following is not allowed. */
8110 m
= gfc_match (" nopass");
8111 if (m
== MATCH_ERROR
)
8117 gfc_error ("Binding attributes already specify passing,"
8118 " illegal NOPASS at %C");
8122 found_passing
= true;
8127 /* PASS possibly including argument. */
8128 m
= gfc_match (" pass");
8129 if (m
== MATCH_ERROR
)
8133 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8137 gfc_error ("Binding attributes already specify passing,"
8138 " illegal PASS at %C");
8142 m
= gfc_match (" ( %n )", arg
);
8143 if (m
== MATCH_ERROR
)
8146 ba
->pass_arg
= gfc_get_string (arg
);
8147 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8149 found_passing
= true;
8157 m
= gfc_match (" pointer");
8158 if (m
== MATCH_ERROR
)
8164 gfc_error ("Duplicate POINTER attribute at %C");
8174 /* NON_OVERRIDABLE flag. */
8175 m
= gfc_match (" non_overridable");
8176 if (m
== MATCH_ERROR
)
8180 if (ba
->non_overridable
)
8182 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8186 ba
->non_overridable
= 1;
8190 /* DEFERRED flag. */
8191 m
= gfc_match (" deferred");
8192 if (m
== MATCH_ERROR
)
8198 gfc_error ("Duplicate DEFERRED at %C");
8209 /* Nothing matching found. */
8211 gfc_error ("Expected access-specifier at %C");
8213 gfc_error ("Expected binding attribute at %C");
8216 while (gfc_match_char (',') == MATCH_YES
);
8218 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8219 if (ba
->non_overridable
&& ba
->deferred
)
8221 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8228 if (ba
->access
== ACCESS_UNKNOWN
)
8229 ba
->access
= gfc_typebound_default_access
;
8231 if (ppc
&& !seen_ptr
)
8233 gfc_error ("POINTER attribute is required for procedure pointer component"
8245 /* Match a PROCEDURE specific binding inside a derived type. */
8248 match_procedure_in_type (void)
8250 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8251 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8252 char* target
= NULL
, *ifc
= NULL
;
8253 gfc_typebound_proc tb
;
8262 /* Check current state. */
8263 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8264 block
= gfc_state_stack
->previous
->sym
;
8267 /* Try to match PROCEDURE(interface). */
8268 if (gfc_match (" (") == MATCH_YES
)
8270 m
= gfc_match_name (target_buf
);
8271 if (m
== MATCH_ERROR
)
8275 gfc_error ("Interface-name expected after '(' at %C");
8279 if (gfc_match (" )") != MATCH_YES
)
8281 gfc_error ("')' expected at %C");
8288 /* Construct the data structure. */
8289 memset (&tb
, 0, sizeof (tb
));
8290 tb
.where
= gfc_current_locus
;
8292 /* Match binding attributes. */
8293 m
= match_binding_attributes (&tb
, false, false);
8294 if (m
== MATCH_ERROR
)
8296 seen_attrs
= (m
== MATCH_YES
);
8298 /* Check that attribute DEFERRED is given if an interface is specified. */
8299 if (tb
.deferred
&& !ifc
)
8301 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8304 if (ifc
&& !tb
.deferred
)
8306 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8310 /* Match the colons. */
8311 m
= gfc_match (" ::");
8312 if (m
== MATCH_ERROR
)
8314 seen_colons
= (m
== MATCH_YES
);
8315 if (seen_attrs
&& !seen_colons
)
8317 gfc_error ("Expected '::' after binding-attributes at %C");
8321 /* Match the binding names. */
8324 m
= gfc_match_name (name
);
8325 if (m
== MATCH_ERROR
)
8329 gfc_error ("Expected binding name at %C");
8333 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8336 /* Try to match the '=> target', if it's there. */
8338 m
= gfc_match (" =>");
8339 if (m
== MATCH_ERROR
)
8345 gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
8351 gfc_error ("'::' needed in PROCEDURE binding with explicit target"
8356 m
= gfc_match_name (target_buf
);
8357 if (m
== MATCH_ERROR
)
8361 gfc_error ("Expected binding target after '=>' at %C");
8364 target
= target_buf
;
8367 /* If no target was found, it has the same name as the binding. */
8371 /* Get the namespace to insert the symbols into. */
8372 ns
= block
->f2k_derived
;
8375 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8376 if (tb
.deferred
&& !block
->attr
.abstract
)
8378 gfc_error ("Type %qs containing DEFERRED binding at %C "
8379 "is not ABSTRACT", block
->name
);
8383 /* See if we already have a binding with this name in the symtree which
8384 would be an error. If a GENERIC already targeted this binding, it may
8385 be already there but then typebound is still NULL. */
8386 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8387 if (stree
&& stree
->n
.tb
)
8389 gfc_error ("There is already a procedure with binding name %qs for "
8390 "the derived type %qs at %C", name
, block
->name
);
8394 /* Insert it and set attributes. */
8398 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8401 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8403 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8406 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8408 if (gfc_match_eos () == MATCH_YES
)
8410 if (gfc_match_char (',') != MATCH_YES
)
8415 gfc_error ("Syntax error in PROCEDURE statement at %C");
8420 /* Match a GENERIC procedure binding inside a derived type. */
8423 gfc_match_generic (void)
8425 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8426 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8428 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8429 gfc_typebound_proc
* tb
;
8431 interface_type op_type
;
8432 gfc_intrinsic_op op
;
8435 /* Check current state. */
8436 if (gfc_current_state () == COMP_DERIVED
)
8438 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8441 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8443 block
= gfc_state_stack
->previous
->sym
;
8444 ns
= block
->f2k_derived
;
8445 gcc_assert (block
&& ns
);
8447 memset (&tbattr
, 0, sizeof (tbattr
));
8448 tbattr
.where
= gfc_current_locus
;
8450 /* See if we get an access-specifier. */
8451 m
= match_binding_attributes (&tbattr
, true, false);
8452 if (m
== MATCH_ERROR
)
8455 /* Now the colons, those are required. */
8456 if (gfc_match (" ::") != MATCH_YES
)
8458 gfc_error ("Expected '::' at %C");
8462 /* Match the binding name; depending on type (operator / generic) format
8463 it for future error messages into bind_name. */
8465 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8466 if (m
== MATCH_ERROR
)
8470 gfc_error ("Expected generic name or operator descriptor at %C");
8476 case INTERFACE_GENERIC
:
8477 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8480 case INTERFACE_USER_OP
:
8481 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8484 case INTERFACE_INTRINSIC_OP
:
8485 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8486 gfc_op2string (op
));
8493 /* Match the required =>. */
8494 if (gfc_match (" =>") != MATCH_YES
)
8496 gfc_error ("Expected '=>' at %C");
8500 /* Try to find existing GENERIC binding with this name / for this operator;
8501 if there is something, check that it is another GENERIC and then extend
8502 it rather than building a new node. Otherwise, create it and put it
8503 at the right position. */
8507 case INTERFACE_USER_OP
:
8508 case INTERFACE_GENERIC
:
8510 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8513 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8525 case INTERFACE_INTRINSIC_OP
:
8535 if (!tb
->is_generic
)
8537 gcc_assert (op_type
== INTERFACE_GENERIC
);
8538 gfc_error ("There's already a non-generic procedure with binding name"
8539 " %qs for the derived type %qs at %C",
8540 bind_name
, block
->name
);
8544 if (tb
->access
!= tbattr
.access
)
8546 gfc_error ("Binding at %C must have the same access as already"
8547 " defined binding %qs", bind_name
);
8553 tb
= gfc_get_typebound_proc (NULL
);
8554 tb
->where
= gfc_current_locus
;
8555 tb
->access
= tbattr
.access
;
8557 tb
->u
.generic
= NULL
;
8561 case INTERFACE_GENERIC
:
8562 case INTERFACE_USER_OP
:
8564 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8567 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8575 case INTERFACE_INTRINSIC_OP
:
8584 /* Now, match all following names as specific targets. */
8587 gfc_symtree
* target_st
;
8588 gfc_tbp_generic
* target
;
8590 m
= gfc_match_name (name
);
8591 if (m
== MATCH_ERROR
)
8595 gfc_error ("Expected specific binding name at %C");
8599 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8601 /* See if this is a duplicate specification. */
8602 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8603 if (target_st
== target
->specific_st
)
8605 gfc_error ("%qs already defined as specific binding for the"
8606 " generic %qs at %C", name
, bind_name
);
8610 target
= gfc_get_tbp_generic ();
8611 target
->specific_st
= target_st
;
8612 target
->specific
= NULL
;
8613 target
->next
= tb
->u
.generic
;
8614 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8615 || (op_type
== INTERFACE_INTRINSIC_OP
));
8616 tb
->u
.generic
= target
;
8618 while (gfc_match (" ,") == MATCH_YES
);
8620 /* Here should be the end. */
8621 if (gfc_match_eos () != MATCH_YES
)
8623 gfc_error ("Junk after GENERIC binding at %C");
8634 /* Match a FINAL declaration inside a derived type. */
8637 gfc_match_final_decl (void)
8639 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8642 gfc_namespace
* module_ns
;
8646 if (gfc_current_form
== FORM_FREE
)
8648 char c
= gfc_peek_ascii_char ();
8649 if (!gfc_is_whitespace (c
) && c
!= ':')
8653 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8655 if (gfc_current_form
== FORM_FIXED
)
8658 gfc_error ("FINAL declaration at %C must be inside a derived type "
8659 "CONTAINS section");
8663 block
= gfc_state_stack
->previous
->sym
;
8666 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8667 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8669 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8670 " specification part of a MODULE");
8674 module_ns
= gfc_current_ns
;
8675 gcc_assert (module_ns
);
8676 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8678 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8679 if (gfc_match (" ::") == MATCH_ERROR
)
8682 /* Match the sequence of procedure names. */
8689 if (first
&& gfc_match_eos () == MATCH_YES
)
8691 gfc_error ("Empty FINAL at %C");
8695 m
= gfc_match_name (name
);
8698 gfc_error ("Expected module procedure name at %C");
8701 else if (m
!= MATCH_YES
)
8704 if (gfc_match_eos () == MATCH_YES
)
8706 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8708 gfc_error ("Expected ',' at %C");
8712 if (gfc_get_symbol (name
, module_ns
, &sym
))
8714 gfc_error ("Unknown procedure name %qs at %C", name
);
8718 /* Mark the symbol as module procedure. */
8719 if (sym
->attr
.proc
!= PROC_MODULE
8720 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8723 /* Check if we already have this symbol in the list, this is an error. */
8724 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8725 if (f
->proc_sym
== sym
)
8727 gfc_error ("%qs at %C is already defined as FINAL procedure!",
8732 /* Add this symbol to the list of finalizers. */
8733 gcc_assert (block
->f2k_derived
);
8735 f
= XCNEW (gfc_finalizer
);
8737 f
->proc_tree
= NULL
;
8738 f
->where
= gfc_current_locus
;
8739 f
->next
= block
->f2k_derived
->finalizers
;
8740 block
->f2k_derived
->finalizers
= f
;
8750 const ext_attr_t ext_attr_list
[] = {
8751 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
8752 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
8753 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
8754 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
8755 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
8756 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
8757 { NULL
, EXT_ATTR_LAST
, NULL
}
8760 /* Match a !GCC$ ATTRIBUTES statement of the form:
8761 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
8762 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
8764 TODO: We should support all GCC attributes using the same syntax for
8765 the attribute list, i.e. the list in C
8766 __attributes(( attribute-list ))
8768 !GCC$ ATTRIBUTES attribute-list ::
8769 Cf. c-parser.c's c_parser_attributes; the data can then directly be
8772 As there is absolutely no risk of confusion, we should never return
8775 gfc_match_gcc_attributes (void)
8777 symbol_attribute attr
;
8778 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8783 gfc_clear_attr (&attr
);
8788 if (gfc_match_name (name
) != MATCH_YES
)
8791 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
8792 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
8795 if (id
== EXT_ATTR_LAST
)
8797 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
8801 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
8804 gfc_gobble_whitespace ();
8805 ch
= gfc_next_ascii_char ();
8808 /* This is the successful exit condition for the loop. */
8809 if (gfc_next_ascii_char () == ':')
8819 if (gfc_match_eos () == MATCH_YES
)
8824 m
= gfc_match_name (name
);
8828 if (find_special (name
, &sym
, true))
8831 sym
->attr
.ext_attr
|= attr
.ext_attr
;
8833 if (gfc_match_eos () == MATCH_YES
)
8836 if (gfc_match_char (',') != MATCH_YES
)
8843 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");