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 '%s' 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 '%s' 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 ("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 ("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 ("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 '%s' at %L must have the BIND(C) "
994 "attribute to be C interoperable", sym
->name
,
995 &(sym
->declared_at
));
1001 if (sym
->attr
.is_c_interop
== 1)
1002 /* We've already checked this procedure; don't check it again. */
1005 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1010 /* See if we've stored a reference to a procedure that owns sym. */
1011 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1013 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1015 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1017 if (is_c_interop
!= 1)
1019 /* Make personalized messages to give better feedback. */
1020 if (sym
->ts
.type
== BT_DERIVED
)
1021 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1022 "BIND(C) procedure '%s' but is not C interoperable "
1023 "because derived type '%s' is not C interoperable",
1024 sym
->name
, &(sym
->declared_at
),
1025 sym
->ns
->proc_name
->name
,
1026 sym
->ts
.u
.derived
->name
);
1027 else if (sym
->ts
.type
== BT_CLASS
)
1028 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1029 "BIND(C) procedure '%s' but is not C interoperable "
1030 "because it is polymorphic",
1031 sym
->name
, &(sym
->declared_at
),
1032 sym
->ns
->proc_name
->name
);
1033 else if (gfc_option
.warn_c_binding_type
)
1034 gfc_warning ("Variable '%s' at %L is a dummy argument of the "
1035 "BIND(C) procedure '%s' 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 '%s' at %L "
1050 "must be length 1 because "
1051 "procedure '%s' 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 '%s' at %L with POINTER or "
1080 "ALLOCATABLE in procedure '%s' 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 '%s' at %L cannot have both the OPTIONAL "
1089 "and the VALUE attribute because procedure '%s' "
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 '%s' in common block '%s' at %C "
1187 "must be declared with a C interoperable "
1188 "kind since common block '%s' 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 (gfc_option
.warn_character_truncation
&& slen
> len
)
1228 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1229 "(%d/%d)", &expr
->where
, slen
, len
);
1231 /* Apply the standard by 'hand' otherwise it gets cleared for
1233 if (check_len
!= -1 && slen
!= check_len
1234 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1235 gfc_error_now ("The CHARACTER elements of the array constructor "
1236 "at %L must have the same length (%d/%d)",
1237 &expr
->where
, slen
, check_len
);
1240 free (expr
->value
.character
.string
);
1241 expr
->value
.character
.string
= s
;
1242 expr
->value
.character
.length
= len
;
1247 /* Function to create and update the enumerator history
1248 using the information passed as arguments.
1249 Pointer "max_enum" is also updated, to point to
1250 enum history node containing largest initializer.
1252 SYM points to the symbol node of enumerator.
1253 INIT points to its enumerator value. */
1256 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1258 enumerator_history
*new_enum_history
;
1259 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1261 new_enum_history
= XCNEW (enumerator_history
);
1263 new_enum_history
->sym
= sym
;
1264 new_enum_history
->initializer
= init
;
1265 new_enum_history
->next
= NULL
;
1267 if (enum_history
== NULL
)
1269 enum_history
= new_enum_history
;
1270 max_enum
= enum_history
;
1274 new_enum_history
->next
= enum_history
;
1275 enum_history
= new_enum_history
;
1277 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1278 new_enum_history
->initializer
->value
.integer
) < 0)
1279 max_enum
= new_enum_history
;
1284 /* Function to free enum kind history. */
1287 gfc_free_enum_history (void)
1289 enumerator_history
*current
= enum_history
;
1290 enumerator_history
*next
;
1292 while (current
!= NULL
)
1294 next
= current
->next
;
1299 enum_history
= NULL
;
1303 /* Function called by variable_decl() that adds an initialization
1304 expression to a symbol. */
1307 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1309 symbol_attribute attr
;
1314 if (find_special (name
, &sym
, false))
1319 /* If this symbol is confirming an implicit parameter type,
1320 then an initialization expression is not allowed. */
1321 if (attr
.flavor
== FL_PARAMETER
1322 && sym
->value
!= NULL
1325 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1332 /* An initializer is required for PARAMETER declarations. */
1333 if (attr
.flavor
== FL_PARAMETER
)
1335 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1341 /* If a variable appears in a DATA block, it cannot have an
1345 gfc_error ("Variable '%s' at %C with an initializer already "
1346 "appears in a DATA statement", sym
->name
);
1350 /* Check if the assignment can happen. This has to be put off
1351 until later for derived type variables and procedure pointers. */
1352 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1353 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1354 && !sym
->attr
.proc_pointer
1355 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1358 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1359 && init
->ts
.type
== BT_CHARACTER
)
1361 /* Update symbol character length according initializer. */
1362 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1365 if (sym
->ts
.u
.cl
->length
== NULL
)
1368 /* If there are multiple CHARACTER variables declared on the
1369 same line, we don't want them to share the same length. */
1370 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1372 if (sym
->attr
.flavor
== FL_PARAMETER
)
1374 if (init
->expr_type
== EXPR_CONSTANT
)
1376 clen
= init
->value
.character
.length
;
1377 sym
->ts
.u
.cl
->length
1378 = gfc_get_int_expr (gfc_default_integer_kind
,
1381 else if (init
->expr_type
== EXPR_ARRAY
)
1384 c
= gfc_constructor_first (init
->value
.constructor
);
1385 clen
= c
->expr
->value
.character
.length
;
1386 sym
->ts
.u
.cl
->length
1387 = gfc_get_int_expr (gfc_default_integer_kind
,
1390 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1391 sym
->ts
.u
.cl
->length
=
1392 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1395 /* Update initializer character length according symbol. */
1396 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1398 int len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1400 if (init
->expr_type
== EXPR_CONSTANT
)
1401 gfc_set_constant_character_len (len
, init
, -1);
1402 else if (init
->expr_type
== EXPR_ARRAY
)
1406 /* Build a new charlen to prevent simplification from
1407 deleting the length before it is resolved. */
1408 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1409 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1411 for (c
= gfc_constructor_first (init
->value
.constructor
);
1412 c
; c
= gfc_constructor_next (c
))
1413 gfc_set_constant_character_len (len
, c
->expr
, -1);
1418 /* If sym is implied-shape, set its upper bounds from init. */
1419 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1420 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1424 if (init
->rank
== 0)
1426 gfc_error ("Can't initialize implied-shape array at %L"
1427 " with scalar", &sym
->declared_at
);
1430 gcc_assert (sym
->as
->rank
== init
->rank
);
1432 /* Shape should be present, we get an initialization expression. */
1433 gcc_assert (init
->shape
);
1435 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1441 lower
= sym
->as
->lower
[dim
];
1442 if (lower
->expr_type
!= EXPR_CONSTANT
)
1444 gfc_error ("Non-constant lower bound in implied-shape"
1445 " declaration at %L", &lower
->where
);
1449 /* All dimensions must be without upper bound. */
1450 gcc_assert (!sym
->as
->upper
[dim
]);
1453 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1454 mpz_add (e
->value
.integer
,
1455 lower
->value
.integer
, init
->shape
[dim
]);
1456 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1457 sym
->as
->upper
[dim
] = e
;
1460 sym
->as
->type
= AS_EXPLICIT
;
1463 /* Need to check if the expression we initialized this
1464 to was one of the iso_c_binding named constants. If so,
1465 and we're a parameter (constant), let it be iso_c.
1467 integer(c_int), parameter :: my_int = c_int
1468 integer(my_int) :: my_int_2
1469 If we mark my_int as iso_c (since we can see it's value
1470 is equal to one of the named constants), then my_int_2
1471 will be considered C interoperable. */
1472 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1474 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1475 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1476 /* attr bits needed for module files. */
1477 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1478 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1479 if (init
->ts
.is_iso_c
)
1480 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1483 /* Add initializer. Make sure we keep the ranks sane. */
1484 if (sym
->attr
.dimension
&& init
->rank
== 0)
1489 if (sym
->attr
.flavor
== FL_PARAMETER
1490 && init
->expr_type
== EXPR_CONSTANT
1491 && spec_size (sym
->as
, &size
)
1492 && mpz_cmp_si (size
, 0) > 0)
1494 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1496 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1497 gfc_constructor_append_expr (&array
->value
.constructor
,
1500 : gfc_copy_expr (init
),
1503 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1504 for (n
= 0; n
< sym
->as
->rank
; n
++)
1505 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1510 init
->rank
= sym
->as
->rank
;
1514 if (sym
->attr
.save
== SAVE_NONE
)
1515 sym
->attr
.save
= SAVE_IMPLICIT
;
1523 /* Function called by variable_decl() that adds a name to a structure
1527 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1528 gfc_array_spec
**as
)
1533 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1534 constructing, it must have the pointer attribute. */
1535 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1536 && current_ts
.u
.derived
== gfc_current_block ()
1537 && current_attr
.pointer
== 0)
1539 gfc_error ("Component at %C must have the POINTER attribute");
1543 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1545 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1547 gfc_error ("Array component of structure at %C must have explicit "
1548 "or deferred shape");
1553 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1557 if (c
->ts
.type
== BT_CHARACTER
)
1559 c
->attr
= current_attr
;
1561 c
->initializer
= *init
;
1568 c
->attr
.codimension
= 1;
1570 c
->attr
.dimension
= 1;
1574 /* Should this ever get more complicated, combine with similar section
1575 in add_init_expr_to_sym into a separate function. */
1576 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1578 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1582 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1583 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1584 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1586 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1588 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1589 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1590 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1591 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1593 gfc_constructor
*ctor
;
1594 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1599 bool has_ts
= (c
->initializer
->ts
.u
.cl
1600 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1602 /* Remember the length of the first element for checking
1603 that all elements *in the constructor* have the same
1604 length. This need not be the length of the LHS! */
1605 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1606 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1607 first_len
= ctor
->expr
->value
.character
.length
;
1609 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1610 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1612 gfc_set_constant_character_len (len
, ctor
->expr
,
1613 has_ts
? -1 : first_len
);
1614 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1620 /* Check array components. */
1621 if (!c
->attr
.dimension
)
1624 if (c
->attr
.pointer
)
1626 if (c
->as
->type
!= AS_DEFERRED
)
1628 gfc_error ("Pointer array component of structure at %C must have a "
1633 else if (c
->attr
.allocatable
)
1635 if (c
->as
->type
!= AS_DEFERRED
)
1637 gfc_error ("Allocatable component of structure at %C must have a "
1644 if (c
->as
->type
!= AS_EXPLICIT
)
1646 gfc_error ("Array component of structure at %C must have an "
1653 if (c
->ts
.type
== BT_CLASS
)
1655 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1665 /* Match a 'NULL()', and possibly take care of some side effects. */
1668 gfc_match_null (gfc_expr
**result
)
1671 match m
, m2
= MATCH_NO
;
1673 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1679 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1681 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1684 old_loc
= gfc_current_locus
;
1685 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1688 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1692 gfc_current_locus
= old_loc
;
1697 /* The NULL symbol now has to be/become an intrinsic function. */
1698 if (gfc_get_symbol ("null", NULL
, &sym
))
1700 gfc_error ("NULL() initialization at %C is ambiguous");
1704 gfc_intrinsic_symbol (sym
);
1706 if (sym
->attr
.proc
!= PROC_INTRINSIC
1707 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1708 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1709 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1712 *result
= gfc_get_null_expr (&gfc_current_locus
);
1714 /* Invalid per F2008, C512. */
1715 if (m2
== MATCH_YES
)
1717 gfc_error ("NULL() initialization at %C may not have MOLD");
1725 /* Match the initialization expr for a data pointer or procedure pointer. */
1728 match_pointer_init (gfc_expr
**init
, int procptr
)
1732 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1734 gfc_error ("Initialization of pointer at %C is not allowed in "
1735 "a PURE procedure");
1738 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1740 /* Match NULL() initialization. */
1741 m
= gfc_match_null (init
);
1745 /* Match non-NULL initialization. */
1746 gfc_matching_ptr_assignment
= !procptr
;
1747 gfc_matching_procptr_assignment
= procptr
;
1748 m
= gfc_match_rvalue (init
);
1749 gfc_matching_ptr_assignment
= 0;
1750 gfc_matching_procptr_assignment
= 0;
1751 if (m
== MATCH_ERROR
)
1753 else if (m
== MATCH_NO
)
1755 gfc_error ("Error in pointer initialization at %C");
1760 gfc_resolve_expr (*init
);
1762 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1763 "initialization at %C"))
1771 check_function_name (char *name
)
1773 /* In functions that have a RESULT variable defined, the function name always
1774 refers to function calls. Therefore, the name is not allowed to appear in
1775 specification statements. When checking this, be careful about
1776 'hidden' procedure pointer results ('ppr@'). */
1778 if (gfc_current_state () == COMP_FUNCTION
)
1780 gfc_symbol
*block
= gfc_current_block ();
1781 if (block
&& block
->result
&& block
->result
!= block
1782 && strcmp (block
->result
->name
, "ppr@") != 0
1783 && strcmp (block
->name
, name
) == 0)
1785 gfc_error ("Function name '%s' not allowed at %C", name
);
1794 /* Match a variable name with an optional initializer. When this
1795 subroutine is called, a variable is expected to be parsed next.
1796 Depending on what is happening at the moment, updates either the
1797 symbol table or the current interface. */
1800 variable_decl (int elem
)
1802 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1803 gfc_expr
*initializer
, *char_len
;
1805 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1817 /* When we get here, we've just matched a list of attributes and
1818 maybe a type and a double colon. The next thing we expect to see
1819 is the name of the symbol. */
1820 m
= gfc_match_name (name
);
1824 var_locus
= gfc_current_locus
;
1826 /* Now we could see the optional array spec. or character length. */
1827 m
= gfc_match_array_spec (&as
, true, true);
1828 if (m
== MATCH_ERROR
)
1832 as
= gfc_copy_array_spec (current_as
);
1834 && !merge_array_spec (current_as
, as
, true))
1840 if (gfc_option
.flag_cray_pointer
)
1841 cp_as
= gfc_copy_array_spec (as
);
1843 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1844 determine (and check) whether it can be implied-shape. If it
1845 was parsed as assumed-size, change it because PARAMETERs can not
1849 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1852 gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
1857 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1858 && current_attr
.flavor
== FL_PARAMETER
)
1859 as
->type
= AS_IMPLIED_SHAPE
;
1861 if (as
->type
== AS_IMPLIED_SHAPE
1862 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1872 cl_deferred
= false;
1874 if (current_ts
.type
== BT_CHARACTER
)
1876 switch (match_char_length (&char_len
, &cl_deferred
, false))
1879 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1881 cl
->length
= char_len
;
1884 /* Non-constant lengths need to be copied after the first
1885 element. Also copy assumed lengths. */
1888 && (current_ts
.u
.cl
->length
== NULL
1889 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1891 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1892 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1895 cl
= current_ts
.u
.cl
;
1897 cl_deferred
= current_ts
.deferred
;
1906 /* If this symbol has already shown up in a Cray Pointer declaration,
1907 then we want to set the type & bail out. */
1908 if (gfc_option
.flag_cray_pointer
)
1910 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1911 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1913 sym
->ts
.type
= current_ts
.type
;
1914 sym
->ts
.kind
= current_ts
.kind
;
1916 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1917 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1918 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1921 /* Check to see if we have an array specification. */
1924 if (sym
->as
!= NULL
)
1926 gfc_error ("Duplicate array spec for Cray pointee at %C");
1927 gfc_free_array_spec (cp_as
);
1933 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
1934 gfc_internal_error ("Couldn't set pointee array spec.");
1936 /* Fix the array spec. */
1937 m
= gfc_mod_pointee_as (sym
->as
);
1938 if (m
== MATCH_ERROR
)
1946 gfc_free_array_spec (cp_as
);
1950 /* Procedure pointer as function result. */
1951 if (gfc_current_state () == COMP_FUNCTION
1952 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
1953 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
1954 strcpy (name
, "ppr@");
1956 if (gfc_current_state () == COMP_FUNCTION
1957 && strcmp (name
, gfc_current_block ()->name
) == 0
1958 && gfc_current_block ()->result
1959 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
1960 strcpy (name
, "ppr@");
1962 /* OK, we've successfully matched the declaration. Now put the
1963 symbol in the current namespace, because it might be used in the
1964 optional initialization expression for this symbol, e.g. this is
1967 integer, parameter :: i = huge(i)
1969 This is only true for parameters or variables of a basic type.
1970 For components of derived types, it is not true, so we don't
1971 create a symbol for those yet. If we fail to create the symbol,
1973 if (gfc_current_state () != COMP_DERIVED
1974 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
1980 if (!check_function_name (name
))
1986 /* We allow old-style initializations of the form
1987 integer i /2/, j(4) /3*3, 1/
1988 (if no colon has been seen). These are different from data
1989 statements in that initializers are only allowed to apply to the
1990 variable immediately preceding, i.e.
1992 is not allowed. Therefore we have to do some work manually, that
1993 could otherwise be left to the matchers for DATA statements. */
1995 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1997 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
1998 "initialization at %C"))
2000 else if (gfc_current_state () == COMP_DERIVED
)
2002 gfc_error ("Invalid old style initialization for derived type "
2008 return match_old_style_init (name
);
2011 /* The double colon must be present in order to have initializers.
2012 Otherwise the statement is ambiguous with an assignment statement. */
2015 if (gfc_match (" =>") == MATCH_YES
)
2017 if (!current_attr
.pointer
)
2019 gfc_error ("Initialization at %C isn't for a pointer variable");
2024 m
= match_pointer_init (&initializer
, 0);
2028 else if (gfc_match_char ('=') == MATCH_YES
)
2030 if (current_attr
.pointer
)
2032 gfc_error ("Pointer initialization at %C requires '=>', "
2038 m
= gfc_match_init_expr (&initializer
);
2041 gfc_error ("Expected an initialization expression at %C");
2045 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2046 && gfc_state_stack
->state
!= COMP_DERIVED
)
2048 gfc_error ("Initialization of variable at %C is not allowed in "
2049 "a PURE procedure");
2053 if (current_attr
.flavor
!= FL_PARAMETER
2054 && gfc_state_stack
->state
!= COMP_DERIVED
)
2055 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2062 if (initializer
!= NULL
&& current_attr
.allocatable
2063 && gfc_current_state () == COMP_DERIVED
)
2065 gfc_error ("Initialization of allocatable component at %C is not "
2071 /* Add the initializer. Note that it is fine if initializer is
2072 NULL here, because we sometimes also need to check if a
2073 declaration *must* have an initialization expression. */
2074 if (gfc_current_state () != COMP_DERIVED
)
2075 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2078 if (current_ts
.type
== BT_DERIVED
2079 && !current_attr
.pointer
&& !initializer
)
2080 initializer
= gfc_default_initializer (¤t_ts
);
2081 t
= build_struct (name
, cl
, &initializer
, &as
);
2084 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2087 /* Free stuff up and return. */
2088 gfc_free_expr (initializer
);
2089 gfc_free_array_spec (as
);
2095 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2096 This assumes that the byte size is equal to the kind number for
2097 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2100 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2105 if (gfc_match_char ('*') != MATCH_YES
)
2108 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2112 original_kind
= ts
->kind
;
2114 /* Massage the kind numbers for complex types. */
2115 if (ts
->type
== BT_COMPLEX
)
2119 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2120 gfc_basic_typename (ts
->type
), original_kind
);
2127 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2130 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2134 if (gfc_option
.flag_real4_kind
== 8)
2136 if (gfc_option
.flag_real4_kind
== 10)
2138 if (gfc_option
.flag_real4_kind
== 16)
2144 if (gfc_option
.flag_real8_kind
== 4)
2146 if (gfc_option
.flag_real8_kind
== 10)
2148 if (gfc_option
.flag_real8_kind
== 16)
2153 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2155 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2156 gfc_basic_typename (ts
->type
), original_kind
);
2160 if (!gfc_notify_std (GFC_STD_GNU
,
2161 "Nonstandard type declaration %s*%d at %C",
2162 gfc_basic_typename(ts
->type
), original_kind
))
2169 /* Match a kind specification. Since kinds are generally optional, we
2170 usually return MATCH_NO if something goes wrong. If a "kind="
2171 string is found, then we know we have an error. */
2174 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2186 where
= loc
= gfc_current_locus
;
2191 if (gfc_match_char ('(') == MATCH_NO
)
2194 /* Also gobbles optional text. */
2195 if (gfc_match (" kind = ") == MATCH_YES
)
2198 loc
= gfc_current_locus
;
2201 n
= gfc_match_init_expr (&e
);
2205 if (gfc_matching_function
)
2207 /* The function kind expression might include use associated or
2208 imported parameters and try again after the specification
2210 if (gfc_match_char (')') != MATCH_YES
)
2212 gfc_error ("Missing right parenthesis at %C");
2218 gfc_undo_symbols ();
2223 /* ....or else, the match is real. */
2225 gfc_error ("Expected initialization expression at %C");
2233 gfc_error ("Expected scalar initialization expression at %C");
2238 msg
= gfc_extract_int (e
, &ts
->kind
);
2247 /* Before throwing away the expression, let's see if we had a
2248 C interoperable kind (and store the fact). */
2249 if (e
->ts
.is_c_interop
== 1)
2251 /* Mark this as C interoperable if being declared with one
2252 of the named constants from iso_c_binding. */
2253 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2254 ts
->f90_type
= e
->ts
.f90_type
;
2260 /* Ignore errors to this point, if we've gotten here. This means
2261 we ignore the m=MATCH_ERROR from above. */
2262 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2264 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2265 gfc_basic_typename (ts
->type
));
2266 gfc_current_locus
= where
;
2270 /* Warn if, e.g., c_int is used for a REAL variable, but not
2271 if, e.g., c_double is used for COMPLEX as the standard
2272 explicitly says that the kind type parameter for complex and real
2273 variable is the same, i.e. c_float == c_float_complex. */
2274 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2275 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2276 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2277 gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2278 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2279 gfc_basic_typename (ts
->type
));
2281 gfc_gobble_whitespace ();
2282 if ((c
= gfc_next_ascii_char ()) != ')'
2283 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2285 if (ts
->type
== BT_CHARACTER
)
2286 gfc_error ("Missing right parenthesis or comma at %C");
2288 gfc_error ("Missing right parenthesis at %C");
2292 /* All tests passed. */
2295 if(m
== MATCH_ERROR
)
2296 gfc_current_locus
= where
;
2298 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2301 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2305 if (gfc_option
.flag_real4_kind
== 8)
2307 if (gfc_option
.flag_real4_kind
== 10)
2309 if (gfc_option
.flag_real4_kind
== 16)
2315 if (gfc_option
.flag_real8_kind
== 4)
2317 if (gfc_option
.flag_real8_kind
== 10)
2319 if (gfc_option
.flag_real8_kind
== 16)
2324 /* Return what we know from the test(s). */
2329 gfc_current_locus
= where
;
2335 match_char_kind (int * kind
, int * is_iso_c
)
2344 where
= gfc_current_locus
;
2346 n
= gfc_match_init_expr (&e
);
2348 if (n
!= MATCH_YES
&& gfc_matching_function
)
2350 /* The expression might include use-associated or imported
2351 parameters and try again after the specification
2354 gfc_undo_symbols ();
2359 gfc_error ("Expected initialization expression at %C");
2365 gfc_error ("Expected scalar initialization expression at %C");
2370 msg
= gfc_extract_int (e
, kind
);
2371 *is_iso_c
= e
->ts
.is_iso_c
;
2381 /* Ignore errors to this point, if we've gotten here. This means
2382 we ignore the m=MATCH_ERROR from above. */
2383 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2385 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2389 /* All tests passed. */
2392 if (m
== MATCH_ERROR
)
2393 gfc_current_locus
= where
;
2395 /* Return what we know from the test(s). */
2400 gfc_current_locus
= where
;
2405 /* Match the various kind/length specifications in a CHARACTER
2406 declaration. We don't return MATCH_NO. */
2409 gfc_match_char_spec (gfc_typespec
*ts
)
2411 int kind
, seen_length
, is_iso_c
;
2423 /* Try the old-style specification first. */
2424 old_char_selector
= 0;
2426 m
= match_char_length (&len
, &deferred
, true);
2430 old_char_selector
= 1;
2435 m
= gfc_match_char ('(');
2438 m
= MATCH_YES
; /* Character without length is a single char. */
2442 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2443 if (gfc_match (" kind =") == MATCH_YES
)
2445 m
= match_char_kind (&kind
, &is_iso_c
);
2447 if (m
== MATCH_ERROR
)
2452 if (gfc_match (" , len =") == MATCH_NO
)
2455 m
= char_len_param_value (&len
, &deferred
);
2458 if (m
== MATCH_ERROR
)
2465 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2466 if (gfc_match (" len =") == MATCH_YES
)
2468 m
= char_len_param_value (&len
, &deferred
);
2471 if (m
== MATCH_ERROR
)
2475 if (gfc_match_char (')') == MATCH_YES
)
2478 if (gfc_match (" , kind =") != MATCH_YES
)
2481 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2487 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2488 m
= char_len_param_value (&len
, &deferred
);
2491 if (m
== MATCH_ERROR
)
2495 m
= gfc_match_char (')');
2499 if (gfc_match_char (',') != MATCH_YES
)
2502 gfc_match (" kind ="); /* Gobble optional text. */
2504 m
= match_char_kind (&kind
, &is_iso_c
);
2505 if (m
== MATCH_ERROR
)
2511 /* Require a right-paren at this point. */
2512 m
= gfc_match_char (')');
2517 gfc_error ("Syntax error in CHARACTER declaration at %C");
2519 gfc_free_expr (len
);
2523 /* Deal with character functions after USE and IMPORT statements. */
2524 if (gfc_matching_function
)
2526 gfc_free_expr (len
);
2527 gfc_undo_symbols ();
2533 gfc_free_expr (len
);
2537 /* Do some final massaging of the length values. */
2538 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2540 if (seen_length
== 0)
2541 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2546 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2547 ts
->deferred
= deferred
;
2549 /* We have to know if it was a C interoperable kind so we can
2550 do accurate type checking of bind(c) procs, etc. */
2552 /* Mark this as C interoperable if being declared with one
2553 of the named constants from iso_c_binding. */
2554 ts
->is_c_interop
= is_iso_c
;
2555 else if (len
!= NULL
)
2556 /* Here, we might have parsed something such as: character(c_char)
2557 In this case, the parsing code above grabs the c_char when
2558 looking for the length (line 1690, roughly). it's the last
2559 testcase for parsing the kind params of a character variable.
2560 However, it's not actually the length. this seems like it
2562 To see if the user used a C interop kind, test the expr
2563 of the so called length, and see if it's C interoperable. */
2564 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2570 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2571 structure to the matched specification. This is necessary for FUNCTION and
2572 IMPLICIT statements.
2574 If implicit_flag is nonzero, then we don't check for the optional
2575 kind specification. Not doing so is needed for matching an IMPLICIT
2576 statement correctly. */
2579 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2582 gfc_symbol
*sym
, *dt_sym
;
2585 bool seen_deferred_kind
, matched_type
;
2586 const char *dt_name
;
2588 /* A belt and braces check that the typespec is correctly being treated
2589 as a deferred characteristic association. */
2590 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2591 && (gfc_current_block ()->result
->ts
.kind
== -1)
2592 && (ts
->kind
== -1);
2594 if (seen_deferred_kind
)
2597 /* Clear the current binding label, in case one is given. */
2598 curr_binding_label
= NULL
;
2600 if (gfc_match (" byte") == MATCH_YES
)
2602 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2605 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2607 gfc_error ("BYTE type used at %C "
2608 "is not available on the target machine");
2612 ts
->type
= BT_INTEGER
;
2618 m
= gfc_match (" type (");
2619 matched_type
= (m
== MATCH_YES
);
2622 gfc_gobble_whitespace ();
2623 if (gfc_peek_ascii_char () == '*')
2625 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2627 if (gfc_current_state () == COMP_DERIVED
)
2629 gfc_error ("Assumed type at %C is not allowed for components");
2632 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2635 ts
->type
= BT_ASSUMED
;
2639 m
= gfc_match ("%n", name
);
2640 matched_type
= (m
== MATCH_YES
);
2643 if ((matched_type
&& strcmp ("integer", name
) == 0)
2644 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2646 ts
->type
= BT_INTEGER
;
2647 ts
->kind
= gfc_default_integer_kind
;
2651 if ((matched_type
&& strcmp ("character", name
) == 0)
2652 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2655 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2656 "intrinsic-type-spec at %C"))
2659 ts
->type
= BT_CHARACTER
;
2660 if (implicit_flag
== 0)
2661 m
= gfc_match_char_spec (ts
);
2665 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2671 if ((matched_type
&& strcmp ("real", name
) == 0)
2672 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2675 ts
->kind
= gfc_default_real_kind
;
2680 && (strcmp ("doubleprecision", name
) == 0
2681 || (strcmp ("double", name
) == 0
2682 && gfc_match (" precision") == MATCH_YES
)))
2683 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2686 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2687 "intrinsic-type-spec at %C"))
2689 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2693 ts
->kind
= gfc_default_double_kind
;
2697 if ((matched_type
&& strcmp ("complex", name
) == 0)
2698 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2700 ts
->type
= BT_COMPLEX
;
2701 ts
->kind
= gfc_default_complex_kind
;
2706 && (strcmp ("doublecomplex", name
) == 0
2707 || (strcmp ("double", name
) == 0
2708 && gfc_match (" complex") == MATCH_YES
)))
2709 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2711 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2715 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2716 "intrinsic-type-spec at %C"))
2719 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2722 ts
->type
= BT_COMPLEX
;
2723 ts
->kind
= gfc_default_double_kind
;
2727 if ((matched_type
&& strcmp ("logical", name
) == 0)
2728 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2730 ts
->type
= BT_LOGICAL
;
2731 ts
->kind
= gfc_default_logical_kind
;
2736 m
= gfc_match_char (')');
2739 ts
->type
= BT_DERIVED
;
2742 /* Match CLASS declarations. */
2743 m
= gfc_match (" class ( * )");
2744 if (m
== MATCH_ERROR
)
2746 else if (m
== MATCH_YES
)
2750 ts
->type
= BT_CLASS
;
2751 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2754 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2755 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2757 gfc_set_sym_referenced (upe
);
2759 upe
->ts
.type
= BT_VOID
;
2760 upe
->attr
.unlimited_polymorphic
= 1;
2761 /* This is essential to force the construction of
2762 unlimited polymorphic component class containers. */
2763 upe
->attr
.zero_comp
= 1;
2764 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2765 &gfc_current_locus
))
2770 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2772 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2776 ts
->u
.derived
= upe
;
2780 m
= gfc_match (" class ( %n )", name
);
2783 ts
->type
= BT_CLASS
;
2785 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2789 /* Defer association of the derived type until the end of the
2790 specification block. However, if the derived type can be
2791 found, add it to the typespec. */
2792 if (gfc_matching_function
)
2794 ts
->u
.derived
= NULL
;
2795 if (gfc_current_state () != COMP_INTERFACE
2796 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2798 sym
= gfc_find_dt_in_generic (sym
);
2799 ts
->u
.derived
= sym
;
2804 /* Search for the name but allow the components to be defined later. If
2805 type = -1, this typespec has been seen in a function declaration but
2806 the type could not be accessed at that point. The actual derived type is
2807 stored in a symtree with the first letter of the name capitalized; the
2808 symtree with the all lower-case name contains the associated
2809 generic function. */
2810 dt_name
= gfc_get_string ("%c%s",
2811 (char) TOUPPER ((unsigned char) name
[0]),
2812 (const char*)&name
[1]);
2817 gfc_get_ha_symbol (name
, &sym
);
2818 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2820 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2823 if (sym
->generic
&& !dt_sym
)
2824 dt_sym
= gfc_find_dt_in_generic (sym
);
2826 else if (ts
->kind
== -1)
2828 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2829 || gfc_current_ns
->has_import_set
;
2830 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2831 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2833 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2836 if (sym
&& sym
->generic
&& !dt_sym
)
2837 dt_sym
= gfc_find_dt_in_generic (sym
);
2844 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2845 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2846 || sym
->attr
.subroutine
)
2848 gfc_error ("Type name '%s' at %C conflicts with previously declared "
2849 "entity at %L, which has the same name", name
,
2854 gfc_save_symbol_data (sym
);
2855 gfc_set_sym_referenced (sym
);
2856 if (!sym
->attr
.generic
2857 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2860 if (!sym
->attr
.function
2861 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2866 gfc_interface
*intr
, *head
;
2868 /* Use upper case to save the actual derived-type symbol. */
2869 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2870 dt_sym
->name
= gfc_get_string (sym
->name
);
2871 head
= sym
->generic
;
2872 intr
= gfc_get_interface ();
2874 intr
->where
= gfc_current_locus
;
2876 sym
->generic
= intr
;
2877 sym
->attr
.if_source
= IFSRC_DECL
;
2880 gfc_save_symbol_data (dt_sym
);
2882 gfc_set_sym_referenced (dt_sym
);
2884 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2885 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2888 ts
->u
.derived
= dt_sym
;
2894 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2895 "intrinsic-type-spec at %C"))
2898 /* For all types except double, derived and character, look for an
2899 optional kind specifier. MATCH_NO is actually OK at this point. */
2900 if (implicit_flag
== 1)
2902 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2908 if (gfc_current_form
== FORM_FREE
)
2910 c
= gfc_peek_ascii_char ();
2911 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2912 && c
!= ':' && c
!= ',')
2914 if (matched_type
&& c
== ')')
2916 gfc_next_ascii_char ();
2923 m
= gfc_match_kind_spec (ts
, false);
2924 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2925 m
= gfc_match_old_kind_spec (ts
);
2927 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2930 /* Defer association of the KIND expression of function results
2931 until after USE and IMPORT statements. */
2932 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
2933 || gfc_matching_function
)
2937 m
= MATCH_YES
; /* No kind specifier found. */
2943 /* Match an IMPLICIT NONE statement. Actually, this statement is
2944 already matched in parse.c, or we would not end up here in the
2945 first place. So the only thing we need to check, is if there is
2946 trailing garbage. If not, the match is successful. */
2949 gfc_match_implicit_none (void)
2951 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
2955 /* Match the letter range(s) of an IMPLICIT statement. */
2958 match_implicit_range (void)
2964 cur_loc
= gfc_current_locus
;
2966 gfc_gobble_whitespace ();
2967 c
= gfc_next_ascii_char ();
2970 gfc_error ("Missing character range in IMPLICIT at %C");
2977 gfc_gobble_whitespace ();
2978 c1
= gfc_next_ascii_char ();
2982 gfc_gobble_whitespace ();
2983 c
= gfc_next_ascii_char ();
2988 inner
= 0; /* Fall through. */
2995 gfc_gobble_whitespace ();
2996 c2
= gfc_next_ascii_char ();
3000 gfc_gobble_whitespace ();
3001 c
= gfc_next_ascii_char ();
3003 if ((c
!= ',') && (c
!= ')'))
3016 gfc_error ("Letters must be in alphabetic order in "
3017 "IMPLICIT statement at %C");
3021 /* See if we can add the newly matched range to the pending
3022 implicits from this IMPLICIT statement. We do not check for
3023 conflicts with whatever earlier IMPLICIT statements may have
3024 set. This is done when we've successfully finished matching
3026 if (!gfc_add_new_implicit_range (c1
, c2
))
3033 gfc_syntax_error (ST_IMPLICIT
);
3035 gfc_current_locus
= cur_loc
;
3040 /* Match an IMPLICIT statement, storing the types for
3041 gfc_set_implicit() if the statement is accepted by the parser.
3042 There is a strange looking, but legal syntactic construction
3043 possible. It looks like:
3045 IMPLICIT INTEGER (a-b) (c-d)
3047 This is legal if "a-b" is a constant expression that happens to
3048 equal one of the legal kinds for integers. The real problem
3049 happens with an implicit specification that looks like:
3051 IMPLICIT INTEGER (a-b)
3053 In this case, a typespec matcher that is "greedy" (as most of the
3054 matchers are) gobbles the character range as a kindspec, leaving
3055 nothing left. We therefore have to go a bit more slowly in the
3056 matching process by inhibiting the kindspec checking during
3057 typespec matching and checking for a kind later. */
3060 gfc_match_implicit (void)
3069 /* We don't allow empty implicit statements. */
3070 if (gfc_match_eos () == MATCH_YES
)
3072 gfc_error ("Empty IMPLICIT statement at %C");
3078 /* First cleanup. */
3079 gfc_clear_new_implicit ();
3081 /* A basic type is mandatory here. */
3082 m
= gfc_match_decl_type_spec (&ts
, 1);
3083 if (m
== MATCH_ERROR
)
3088 cur_loc
= gfc_current_locus
;
3089 m
= match_implicit_range ();
3093 /* We may have <TYPE> (<RANGE>). */
3094 gfc_gobble_whitespace ();
3095 c
= gfc_next_ascii_char ();
3096 if ((c
== '\n') || (c
== ','))
3098 /* Check for CHARACTER with no length parameter. */
3099 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3101 ts
.kind
= gfc_default_character_kind
;
3102 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3103 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3107 /* Record the Successful match. */
3108 if (!gfc_merge_new_implicit (&ts
))
3113 gfc_current_locus
= cur_loc
;
3116 /* Discard the (incorrectly) matched range. */
3117 gfc_clear_new_implicit ();
3119 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3120 if (ts
.type
== BT_CHARACTER
)
3121 m
= gfc_match_char_spec (&ts
);
3124 m
= gfc_match_kind_spec (&ts
, false);
3127 m
= gfc_match_old_kind_spec (&ts
);
3128 if (m
== MATCH_ERROR
)
3134 if (m
== MATCH_ERROR
)
3137 m
= match_implicit_range ();
3138 if (m
== MATCH_ERROR
)
3143 gfc_gobble_whitespace ();
3144 c
= gfc_next_ascii_char ();
3145 if ((c
!= '\n') && (c
!= ','))
3148 if (!gfc_merge_new_implicit (&ts
))
3156 gfc_syntax_error (ST_IMPLICIT
);
3164 gfc_match_import (void)
3166 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3171 if (gfc_current_ns
->proc_name
== NULL
3172 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3174 gfc_error ("IMPORT statement at %C only permitted in "
3175 "an INTERFACE body");
3179 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3182 if (gfc_match_eos () == MATCH_YES
)
3184 /* All host variables should be imported. */
3185 gfc_current_ns
->has_import_set
= 1;
3189 if (gfc_match (" ::") == MATCH_YES
)
3191 if (gfc_match_eos () == MATCH_YES
)
3193 gfc_error ("Expecting list of named entities at %C");
3201 m
= gfc_match (" %n", name
);
3205 if (gfc_current_ns
->parent
!= NULL
3206 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3208 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3211 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3212 && gfc_find_symbol (name
,
3213 gfc_current_ns
->proc_name
->ns
->parent
,
3216 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3222 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
3223 "at %C - does not exist.", name
);
3227 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3229 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
3234 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3237 sym
->attr
.imported
= 1;
3239 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3241 /* The actual derived type is stored in a symtree with the first
3242 letter of the name capitalized; the symtree with the all
3243 lower-case name contains the associated generic function. */
3244 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3245 gfc_get_string ("%c%s",
3246 (char) TOUPPER ((unsigned char) name
[0]),
3250 sym
->attr
.imported
= 1;
3263 if (gfc_match_eos () == MATCH_YES
)
3265 if (gfc_match_char (',') != MATCH_YES
)
3272 gfc_error ("Syntax error in IMPORT statement at %C");
3277 /* A minimal implementation of gfc_match without whitespace, escape
3278 characters or variable arguments. Returns true if the next
3279 characters match the TARGET template exactly. */
3282 match_string_p (const char *target
)
3286 for (p
= target
; *p
; p
++)
3287 if ((char) gfc_next_ascii_char () != *p
)
3292 /* Matches an attribute specification including array specs. If
3293 successful, leaves the variables current_attr and current_as
3294 holding the specification. Also sets the colon_seen variable for
3295 later use by matchers associated with initializations.
3297 This subroutine is a little tricky in the sense that we don't know
3298 if we really have an attr-spec until we hit the double colon.
3299 Until that time, we can only return MATCH_NO. This forces us to
3300 check for duplicate specification at this level. */
3303 match_attr_spec (void)
3305 /* Modifiers that can exist in a type statement. */
3307 { GFC_DECL_BEGIN
= 0,
3308 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3309 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3310 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3311 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3312 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3313 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3316 /* GFC_DECL_END is the sentinel, index starts at 0. */
3317 #define NUM_DECL GFC_DECL_END
3319 locus start
, seen_at
[NUM_DECL
];
3326 gfc_clear_attr (¤t_attr
);
3327 start
= gfc_current_locus
;
3332 /* See if we get all of the keywords up to the final double colon. */
3333 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3341 gfc_gobble_whitespace ();
3343 ch
= gfc_next_ascii_char ();
3346 /* This is the successful exit condition for the loop. */
3347 if (gfc_next_ascii_char () == ':')
3352 gfc_gobble_whitespace ();
3353 switch (gfc_peek_ascii_char ())
3356 gfc_next_ascii_char ();
3357 switch (gfc_next_ascii_char ())
3360 if (match_string_p ("locatable"))
3362 /* Matched "allocatable". */
3363 d
= DECL_ALLOCATABLE
;
3368 if (match_string_p ("ynchronous"))
3370 /* Matched "asynchronous". */
3371 d
= DECL_ASYNCHRONOUS
;
3378 /* Try and match the bind(c). */
3379 m
= gfc_match_bind_c (NULL
, true);
3382 else if (m
== MATCH_ERROR
)
3387 gfc_next_ascii_char ();
3388 if ('o' != gfc_next_ascii_char ())
3390 switch (gfc_next_ascii_char ())
3393 if (match_string_p ("imension"))
3395 d
= DECL_CODIMENSION
;
3399 if (match_string_p ("tiguous"))
3401 d
= DECL_CONTIGUOUS
;
3408 if (match_string_p ("dimension"))
3413 if (match_string_p ("external"))
3418 if (match_string_p ("int"))
3420 ch
= gfc_next_ascii_char ();
3423 if (match_string_p ("nt"))
3425 /* Matched "intent". */
3426 /* TODO: Call match_intent_spec from here. */
3427 if (gfc_match (" ( in out )") == MATCH_YES
)
3429 else if (gfc_match (" ( in )") == MATCH_YES
)
3431 else if (gfc_match (" ( out )") == MATCH_YES
)
3437 if (match_string_p ("insic"))
3439 /* Matched "intrinsic". */
3447 if (match_string_p ("optional"))
3452 gfc_next_ascii_char ();
3453 switch (gfc_next_ascii_char ())
3456 if (match_string_p ("rameter"))
3458 /* Matched "parameter". */
3464 if (match_string_p ("inter"))
3466 /* Matched "pointer". */
3472 ch
= gfc_next_ascii_char ();
3475 if (match_string_p ("vate"))
3477 /* Matched "private". */
3483 if (match_string_p ("tected"))
3485 /* Matched "protected". */
3492 if (match_string_p ("blic"))
3494 /* Matched "public". */
3502 if (match_string_p ("save"))
3507 if (match_string_p ("target"))
3512 gfc_next_ascii_char ();
3513 ch
= gfc_next_ascii_char ();
3516 if (match_string_p ("lue"))
3518 /* Matched "value". */
3524 if (match_string_p ("latile"))
3526 /* Matched "volatile". */
3534 /* No double colon and no recognizable decl_type, so assume that
3535 we've been looking at something else the whole time. */
3542 /* Check to make sure any parens are paired up correctly. */
3543 if (gfc_match_parens () == MATCH_ERROR
)
3550 seen_at
[d
] = gfc_current_locus
;
3552 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3554 gfc_array_spec
*as
= NULL
;
3556 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3557 d
== DECL_CODIMENSION
);
3559 if (current_as
== NULL
)
3561 else if (m
== MATCH_YES
)
3563 if (!merge_array_spec (as
, current_as
, false))
3570 if (d
== DECL_CODIMENSION
)
3571 gfc_error ("Missing codimension specification at %C");
3573 gfc_error ("Missing dimension specification at %C");
3577 if (m
== MATCH_ERROR
)
3582 /* Since we've seen a double colon, we have to be looking at an
3583 attr-spec. This means that we can now issue errors. */
3584 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3589 case DECL_ALLOCATABLE
:
3590 attr
= "ALLOCATABLE";
3592 case DECL_ASYNCHRONOUS
:
3593 attr
= "ASYNCHRONOUS";
3595 case DECL_CODIMENSION
:
3596 attr
= "CODIMENSION";
3598 case DECL_CONTIGUOUS
:
3599 attr
= "CONTIGUOUS";
3601 case DECL_DIMENSION
:
3608 attr
= "INTENT (IN)";
3611 attr
= "INTENT (OUT)";
3614 attr
= "INTENT (IN OUT)";
3616 case DECL_INTRINSIC
:
3622 case DECL_PARAMETER
:
3628 case DECL_PROTECTED
:
3643 case DECL_IS_BIND_C
:
3653 attr
= NULL
; /* This shouldn't happen. */
3656 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3661 /* Now that we've dealt with duplicate attributes, add the attributes
3662 to the current attribute. */
3663 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3668 if (gfc_current_state () == COMP_DERIVED
3669 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3670 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3671 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3673 if (d
== DECL_ALLOCATABLE
)
3675 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3676 "attribute at %C in a TYPE definition"))
3684 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3691 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3692 && gfc_current_state () != COMP_MODULE
)
3694 if (d
== DECL_PRIVATE
)
3698 if (gfc_current_state () == COMP_DERIVED
3699 && gfc_state_stack
->previous
3700 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3702 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3703 "at %L in a TYPE definition", attr
,
3712 gfc_error ("%s attribute at %L is not allowed outside of the "
3713 "specification part of a module", attr
, &seen_at
[d
]);
3721 case DECL_ALLOCATABLE
:
3722 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3725 case DECL_ASYNCHRONOUS
:
3726 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3729 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3732 case DECL_CODIMENSION
:
3733 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3736 case DECL_CONTIGUOUS
:
3737 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3740 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3743 case DECL_DIMENSION
:
3744 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3748 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3752 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3756 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3760 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3763 case DECL_INTRINSIC
:
3764 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3768 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3771 case DECL_PARAMETER
:
3772 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3776 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3779 case DECL_PROTECTED
:
3780 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3782 gfc_error ("PROTECTED at %C only allowed in specification "
3783 "part of a module");
3788 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3791 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3795 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3800 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3805 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3809 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3812 case DECL_IS_BIND_C
:
3813 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3817 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3820 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3824 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3827 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3831 gfc_internal_error ("match_attr_spec(): Bad attribute");
3841 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3842 if (gfc_current_state () == COMP_MODULE
&& !current_attr
.save
3843 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3844 current_attr
.save
= SAVE_IMPLICIT
;
3850 gfc_current_locus
= start
;
3851 gfc_free_array_spec (current_as
);
3857 /* Set the binding label, dest_label, either with the binding label
3858 stored in the given gfc_typespec, ts, or if none was provided, it
3859 will be the symbol name in all lower case, as required by the draft
3860 (J3/04-007, section 15.4.1). If a binding label was given and
3861 there is more than one argument (num_idents), it is an error. */
3864 set_binding_label (const char **dest_label
, const char *sym_name
,
3867 if (num_idents
> 1 && has_name_equals
)
3869 gfc_error ("Multiple identifiers provided with "
3870 "single NAME= specifier at %C");
3874 if (curr_binding_label
)
3875 /* Binding label given; store in temp holder till have sym. */
3876 *dest_label
= curr_binding_label
;
3879 /* No binding label given, and the NAME= specifier did not exist,
3880 which means there was no NAME="". */
3881 if (sym_name
!= NULL
&& has_name_equals
== 0)
3882 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
3889 /* Set the status of the given common block as being BIND(C) or not,
3890 depending on the given parameter, is_bind_c. */
3893 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
3895 com_block
->is_bind_c
= is_bind_c
;
3900 /* Verify that the given gfc_typespec is for a C interoperable type. */
3903 gfc_verify_c_interop (gfc_typespec
*ts
)
3905 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
3906 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
3908 else if (ts
->type
== BT_CLASS
)
3910 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
3917 /* Verify that the variables of a given common block, which has been
3918 defined with the attribute specifier bind(c), to be of a C
3919 interoperable type. Errors will be reported here, if
3923 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
3925 gfc_symbol
*curr_sym
= NULL
;
3928 curr_sym
= com_block
->head
;
3930 /* Make sure we have at least one symbol. */
3931 if (curr_sym
== NULL
)
3934 /* Here we know we have a symbol, so we'll execute this loop
3938 /* The second to last param, 1, says this is in a common block. */
3939 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
3940 curr_sym
= curr_sym
->common_next
;
3941 } while (curr_sym
!= NULL
);
3947 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3948 an appropriate error message is reported. */
3951 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
3952 int is_in_common
, gfc_common_head
*com_block
)
3954 bool bind_c_function
= false;
3957 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
3958 bind_c_function
= true;
3960 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
3962 tmp_sym
= tmp_sym
->result
;
3963 /* Make sure it wasn't an implicitly typed result. */
3964 if (tmp_sym
->attr
.implicit_type
&& gfc_option
.warn_c_binding_type
)
3966 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3967 "%L may not be C interoperable", tmp_sym
->name
,
3968 &tmp_sym
->declared_at
);
3969 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
3970 /* Mark it as C interoperable to prevent duplicate warnings. */
3971 tmp_sym
->ts
.is_c_interop
= 1;
3972 tmp_sym
->attr
.is_c_interop
= 1;
3976 /* Here, we know we have the bind(c) attribute, so if we have
3977 enough type info, then verify that it's a C interop kind.
3978 The info could be in the symbol already, or possibly still in
3979 the given ts (current_ts), so look in both. */
3980 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
3982 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
3984 /* See if we're dealing with a sym in a common block or not. */
3985 if (is_in_common
== 1 && gfc_option
.warn_c_binding_type
)
3987 gfc_warning ("Variable '%s' in common block '%s' at %L "
3988 "may not be a C interoperable "
3989 "kind though common block '%s' is BIND(C)",
3990 tmp_sym
->name
, com_block
->name
,
3991 &(tmp_sym
->declared_at
), com_block
->name
);
3995 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
3996 gfc_error ("Type declaration '%s' at %L is not C "
3997 "interoperable but it is BIND(C)",
3998 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3999 else if (gfc_option
.warn_c_binding_type
)
4000 gfc_warning ("Variable '%s' at %L "
4001 "may not be a C interoperable "
4002 "kind but it is bind(c)",
4003 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4007 /* Variables declared w/in a common block can't be bind(c)
4008 since there's no way for C to see these variables, so there's
4009 semantically no reason for the attribute. */
4010 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4012 gfc_error ("Variable '%s' in common block '%s' at "
4013 "%L cannot be declared with BIND(C) "
4014 "since it is not a global",
4015 tmp_sym
->name
, com_block
->name
,
4016 &(tmp_sym
->declared_at
));
4020 /* Scalar variables that are bind(c) can not have the pointer
4021 or allocatable attributes. */
4022 if (tmp_sym
->attr
.is_bind_c
== 1)
4024 if (tmp_sym
->attr
.pointer
== 1)
4026 gfc_error ("Variable '%s' at %L cannot have both the "
4027 "POINTER and BIND(C) attributes",
4028 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4032 if (tmp_sym
->attr
.allocatable
== 1)
4034 gfc_error ("Variable '%s' at %L cannot have both the "
4035 "ALLOCATABLE and BIND(C) attributes",
4036 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4042 /* If it is a BIND(C) function, make sure the return value is a
4043 scalar value. The previous tests in this function made sure
4044 the type is interoperable. */
4045 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4046 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4047 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4049 /* BIND(C) functions can not return a character string. */
4050 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4051 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4052 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4053 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4054 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4055 "be a character string", tmp_sym
->name
,
4056 &(tmp_sym
->declared_at
));
4059 /* See if the symbol has been marked as private. If it has, make sure
4060 there is no binding label and warn the user if there is one. */
4061 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4062 && tmp_sym
->binding_label
)
4063 /* Use gfc_warning_now because we won't say that the symbol fails
4064 just because of this. */
4065 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
4066 "given the binding label '%s'", tmp_sym
->name
,
4067 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4073 /* Set the appropriate fields for a symbol that's been declared as
4074 BIND(C) (the is_bind_c flag and the binding label), and verify that
4075 the type is C interoperable. Errors are reported by the functions
4076 used to set/test these fields. */
4079 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4083 /* TODO: Do we need to make sure the vars aren't marked private? */
4085 /* Set the is_bind_c bit in symbol_attribute. */
4086 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4088 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4095 /* Set the fields marking the given common block as BIND(C), including
4096 a binding label, and report any errors encountered. */
4099 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4103 /* destLabel, common name, typespec (which may have binding label). */
4104 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4108 /* Set the given common block (com_block) to being bind(c) (1). */
4109 set_com_block_bind_c (com_block
, 1);
4115 /* Retrieve the list of one or more identifiers that the given bind(c)
4116 attribute applies to. */
4119 get_bind_c_idents (void)
4121 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4123 gfc_symbol
*tmp_sym
= NULL
;
4125 gfc_common_head
*com_block
= NULL
;
4127 if (gfc_match_name (name
) == MATCH_YES
)
4129 found_id
= MATCH_YES
;
4130 gfc_get_ha_symbol (name
, &tmp_sym
);
4132 else if (match_common_name (name
) == MATCH_YES
)
4134 found_id
= MATCH_YES
;
4135 com_block
= gfc_get_common (name
, 0);
4139 gfc_error ("Need either entity or common block name for "
4140 "attribute specification statement at %C");
4144 /* Save the current identifier and look for more. */
4147 /* Increment the number of identifiers found for this spec stmt. */
4150 /* Make sure we have a sym or com block, and verify that it can
4151 be bind(c). Set the appropriate field(s) and look for more
4153 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4155 if (tmp_sym
!= NULL
)
4157 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4162 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4166 /* Look to see if we have another identifier. */
4168 if (gfc_match_eos () == MATCH_YES
)
4169 found_id
= MATCH_NO
;
4170 else if (gfc_match_char (',') != MATCH_YES
)
4171 found_id
= MATCH_NO
;
4172 else if (gfc_match_name (name
) == MATCH_YES
)
4174 found_id
= MATCH_YES
;
4175 gfc_get_ha_symbol (name
, &tmp_sym
);
4177 else if (match_common_name (name
) == MATCH_YES
)
4179 found_id
= MATCH_YES
;
4180 com_block
= gfc_get_common (name
, 0);
4184 gfc_error ("Missing entity or common block name for "
4185 "attribute specification statement at %C");
4191 gfc_internal_error ("Missing symbol");
4193 } while (found_id
== MATCH_YES
);
4195 /* if we get here we were successful */
4200 /* Try and match a BIND(C) attribute specification statement. */
4203 gfc_match_bind_c_stmt (void)
4205 match found_match
= MATCH_NO
;
4210 /* This may not be necessary. */
4212 /* Clear the temporary binding label holder. */
4213 curr_binding_label
= NULL
;
4215 /* Look for the bind(c). */
4216 found_match
= gfc_match_bind_c (NULL
, true);
4218 if (found_match
== MATCH_YES
)
4220 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4223 /* Look for the :: now, but it is not required. */
4226 /* Get the identifier(s) that needs to be updated. This may need to
4227 change to hand the flag(s) for the attr specified so all identifiers
4228 found can have all appropriate parts updated (assuming that the same
4229 spec stmt can have multiple attrs, such as both bind(c) and
4231 if (!get_bind_c_idents ())
4232 /* Error message should have printed already. */
4240 /* Match a data declaration statement. */
4243 gfc_match_data_decl (void)
4249 num_idents_on_line
= 0;
4251 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4255 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4256 && gfc_current_state () != COMP_DERIVED
)
4258 sym
= gfc_use_derived (current_ts
.u
.derived
);
4266 current_ts
.u
.derived
= sym
;
4269 m
= match_attr_spec ();
4270 if (m
== MATCH_ERROR
)
4276 if (current_ts
.type
== BT_CLASS
4277 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4280 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4281 && current_ts
.u
.derived
->components
== NULL
4282 && !current_ts
.u
.derived
->attr
.zero_comp
)
4285 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4288 gfc_find_symbol (current_ts
.u
.derived
->name
,
4289 current_ts
.u
.derived
->ns
, 1, &sym
);
4291 /* Any symbol that we find had better be a type definition
4292 which has its components defined. */
4293 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4294 && (current_ts
.u
.derived
->components
!= NULL
4295 || current_ts
.u
.derived
->attr
.zero_comp
))
4298 gfc_error ("Derived type at %C has not been previously defined "
4299 "and so cannot appear in a derived type definition");
4305 /* If we have an old-style character declaration, and no new-style
4306 attribute specifications, then there a comma is optional between
4307 the type specification and the variable list. */
4308 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4309 gfc_match_char (',');
4311 /* Give the types/attributes to symbols that follow. Give the element
4312 a number so that repeat character length expressions can be copied. */
4316 num_idents_on_line
++;
4317 m
= variable_decl (elem
++);
4318 if (m
== MATCH_ERROR
)
4323 if (gfc_match_eos () == MATCH_YES
)
4325 if (gfc_match_char (',') != MATCH_YES
)
4329 if (gfc_error_flag_test () == 0)
4330 gfc_error ("Syntax error in data declaration at %C");
4333 gfc_free_data_all (gfc_current_ns
);
4336 gfc_free_array_spec (current_as
);
4342 /* Match a prefix associated with a function or subroutine
4343 declaration. If the typespec pointer is nonnull, then a typespec
4344 can be matched. Note that if nothing matches, MATCH_YES is
4345 returned (the null string was matched). */
4348 gfc_match_prefix (gfc_typespec
*ts
)
4354 gfc_clear_attr (¤t_attr
);
4356 seen_impure
= false;
4358 gcc_assert (!gfc_matching_prefix
);
4359 gfc_matching_prefix
= true;
4363 found_prefix
= false;
4365 if (!seen_type
&& ts
!= NULL
4366 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4367 && gfc_match_space () == MATCH_YES
)
4371 found_prefix
= true;
4374 if (gfc_match ("elemental% ") == MATCH_YES
)
4376 if (!gfc_add_elemental (¤t_attr
, NULL
))
4379 found_prefix
= true;
4382 if (gfc_match ("pure% ") == MATCH_YES
)
4384 if (!gfc_add_pure (¤t_attr
, NULL
))
4387 found_prefix
= true;
4390 if (gfc_match ("recursive% ") == MATCH_YES
)
4392 if (!gfc_add_recursive (¤t_attr
, NULL
))
4395 found_prefix
= true;
4398 /* IMPURE is a somewhat special case, as it needs not set an actual
4399 attribute but rather only prevents ELEMENTAL routines from being
4400 automatically PURE. */
4401 if (gfc_match ("impure% ") == MATCH_YES
)
4403 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4407 found_prefix
= true;
4410 while (found_prefix
);
4412 /* IMPURE and PURE must not both appear, of course. */
4413 if (seen_impure
&& current_attr
.pure
)
4415 gfc_error ("PURE and IMPURE must not appear both at %C");
4419 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4420 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4422 if (!gfc_add_pure (¤t_attr
, NULL
))
4426 /* At this point, the next item is not a prefix. */
4427 gcc_assert (gfc_matching_prefix
);
4428 gfc_matching_prefix
= false;
4432 gcc_assert (gfc_matching_prefix
);
4433 gfc_matching_prefix
= false;
4438 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4441 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4443 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4446 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4449 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4456 /* Match a formal argument list. */
4459 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4461 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4462 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4468 if (gfc_match_char ('(') != MATCH_YES
)
4475 if (gfc_match_char (')') == MATCH_YES
)
4480 if (gfc_match_char ('*') == MATCH_YES
)
4483 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4492 m
= gfc_match_name (name
);
4496 if (gfc_get_symbol (name
, NULL
, &sym
))
4500 p
= gfc_get_formal_arglist ();
4512 /* We don't add the VARIABLE flavor because the name could be a
4513 dummy procedure. We don't apply these attributes to formal
4514 arguments of statement functions. */
4515 if (sym
!= NULL
&& !st_flag
4516 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4517 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4523 /* The name of a program unit can be in a different namespace,
4524 so check for it explicitly. After the statement is accepted,
4525 the name is checked for especially in gfc_get_symbol(). */
4526 if (gfc_new_block
!= NULL
&& sym
!= NULL
4527 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4529 gfc_error ("Name '%s' at %C is the name of the procedure",
4535 if (gfc_match_char (')') == MATCH_YES
)
4538 m
= gfc_match_char (',');
4541 gfc_error ("Unexpected junk in formal argument list at %C");
4547 /* Check for duplicate symbols in the formal argument list. */
4550 for (p
= head
; p
->next
; p
= p
->next
)
4555 for (q
= p
->next
; q
; q
= q
->next
)
4556 if (p
->sym
== q
->sym
)
4558 gfc_error ("Duplicate symbol '%s' in formal argument list "
4559 "at %C", p
->sym
->name
);
4567 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4576 gfc_free_formal_arglist (head
);
4581 /* Match a RESULT specification following a function declaration or
4582 ENTRY statement. Also matches the end-of-statement. */
4585 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4587 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4591 if (gfc_match (" result (") != MATCH_YES
)
4594 m
= gfc_match_name (name
);
4598 /* Get the right paren, and that's it because there could be the
4599 bind(c) attribute after the result clause. */
4600 if (gfc_match_char (')') != MATCH_YES
)
4602 /* TODO: should report the missing right paren here. */
4606 if (strcmp (function
->name
, name
) == 0)
4608 gfc_error ("RESULT variable at %C must be different than function name");
4612 if (gfc_get_symbol (name
, NULL
, &r
))
4615 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4624 /* Match a function suffix, which could be a combination of a result
4625 clause and BIND(C), either one, or neither. The draft does not
4626 require them to come in a specific order. */
4629 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4631 match is_bind_c
; /* Found bind(c). */
4632 match is_result
; /* Found result clause. */
4633 match found_match
; /* Status of whether we've found a good match. */
4634 char peek_char
; /* Character we're going to peek at. */
4635 bool allow_binding_name
;
4637 /* Initialize to having found nothing. */
4638 found_match
= MATCH_NO
;
4639 is_bind_c
= MATCH_NO
;
4640 is_result
= MATCH_NO
;
4642 /* Get the next char to narrow between result and bind(c). */
4643 gfc_gobble_whitespace ();
4644 peek_char
= gfc_peek_ascii_char ();
4646 /* C binding names are not allowed for internal procedures. */
4647 if (gfc_current_state () == COMP_CONTAINS
4648 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4649 allow_binding_name
= false;
4651 allow_binding_name
= true;
4656 /* Look for result clause. */
4657 is_result
= match_result (sym
, result
);
4658 if (is_result
== MATCH_YES
)
4660 /* Now see if there is a bind(c) after it. */
4661 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4662 /* We've found the result clause and possibly bind(c). */
4663 found_match
= MATCH_YES
;
4666 /* This should only be MATCH_ERROR. */
4667 found_match
= is_result
;
4670 /* Look for bind(c) first. */
4671 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4672 if (is_bind_c
== MATCH_YES
)
4674 /* Now see if a result clause followed it. */
4675 is_result
= match_result (sym
, result
);
4676 found_match
= MATCH_YES
;
4680 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4681 found_match
= MATCH_ERROR
;
4685 gfc_error ("Unexpected junk after function declaration at %C");
4686 found_match
= MATCH_ERROR
;
4690 if (is_bind_c
== MATCH_YES
)
4692 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4693 if (gfc_current_state () == COMP_CONTAINS
4694 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4695 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4696 "at %L may not be specified for an internal "
4697 "procedure", &gfc_current_locus
))
4700 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4708 /* Procedure pointer return value without RESULT statement:
4709 Add "hidden" result variable named "ppr@". */
4712 add_hidden_procptr_result (gfc_symbol
*sym
)
4716 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4719 /* First usage case: PROCEDURE and EXTERNAL statements. */
4720 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4721 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4722 && sym
->attr
.external
;
4723 /* Second usage case: INTERFACE statements. */
4724 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4725 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4726 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4732 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4736 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4737 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4738 st2
->n
.sym
= stree
->n
.sym
;
4740 sym
->result
= stree
->n
.sym
;
4742 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4743 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4744 sym
->result
->attr
.external
= sym
->attr
.external
;
4745 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4746 sym
->result
->ts
= sym
->ts
;
4747 sym
->attr
.proc_pointer
= 0;
4748 sym
->attr
.pointer
= 0;
4749 sym
->attr
.external
= 0;
4750 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4752 sym
->result
->attr
.pointer
= 0;
4753 sym
->result
->attr
.proc_pointer
= 1;
4756 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4758 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4759 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4760 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4761 && sym
== gfc_current_ns
->proc_name
4762 && sym
== sym
->result
->ns
->proc_name
4763 && strcmp ("ppr@", sym
->result
->name
) == 0)
4765 sym
->result
->attr
.proc_pointer
= 1;
4766 sym
->attr
.pointer
= 0;
4774 /* Match the interface for a PROCEDURE declaration,
4775 including brackets (R1212). */
4778 match_procedure_interface (gfc_symbol
**proc_if
)
4782 locus old_loc
, entry_loc
;
4783 gfc_namespace
*old_ns
= gfc_current_ns
;
4784 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4786 old_loc
= entry_loc
= gfc_current_locus
;
4787 gfc_clear_ts (¤t_ts
);
4789 if (gfc_match (" (") != MATCH_YES
)
4791 gfc_current_locus
= entry_loc
;
4795 /* Get the type spec. for the procedure interface. */
4796 old_loc
= gfc_current_locus
;
4797 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4798 gfc_gobble_whitespace ();
4799 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4802 if (m
== MATCH_ERROR
)
4805 /* Procedure interface is itself a procedure. */
4806 gfc_current_locus
= old_loc
;
4807 m
= gfc_match_name (name
);
4809 /* First look to see if it is already accessible in the current
4810 namespace because it is use associated or contained. */
4812 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
4815 /* If it is still not found, then try the parent namespace, if it
4816 exists and create the symbol there if it is still not found. */
4817 if (gfc_current_ns
->parent
)
4818 gfc_current_ns
= gfc_current_ns
->parent
;
4819 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
4822 gfc_current_ns
= old_ns
;
4823 *proc_if
= st
->n
.sym
;
4828 /* Resolve interface if possible. That way, attr.procedure is only set
4829 if it is declared by a later procedure-declaration-stmt, which is
4830 invalid per F08:C1216 (cf. resolve_procedure_interface). */
4831 while ((*proc_if
)->ts
.interface
)
4832 *proc_if
= (*proc_if
)->ts
.interface
;
4834 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
4835 && (*proc_if
)->ts
.type
== BT_UNKNOWN
4836 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
4837 (*proc_if
)->name
, NULL
))
4842 if (gfc_match (" )") != MATCH_YES
)
4844 gfc_current_locus
= entry_loc
;
4852 /* Match a PROCEDURE declaration (R1211). */
4855 match_procedure_decl (void)
4858 gfc_symbol
*sym
, *proc_if
= NULL
;
4860 gfc_expr
*initializer
= NULL
;
4862 /* Parse interface (with brackets). */
4863 m
= match_procedure_interface (&proc_if
);
4867 /* Parse attributes (with colons). */
4868 m
= match_attr_spec();
4869 if (m
== MATCH_ERROR
)
4872 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
4874 current_attr
.is_bind_c
= 1;
4875 has_name_equals
= 0;
4876 curr_binding_label
= NULL
;
4879 /* Get procedure symbols. */
4882 m
= gfc_match_symbol (&sym
, 0);
4885 else if (m
== MATCH_ERROR
)
4888 /* Add current_attr to the symbol attributes. */
4889 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
4892 if (sym
->attr
.is_bind_c
)
4894 /* Check for C1218. */
4895 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
4897 gfc_error ("BIND(C) attribute at %C requires "
4898 "an interface with BIND(C)");
4901 /* Check for C1217. */
4902 if (has_name_equals
&& sym
->attr
.pointer
)
4904 gfc_error ("BIND(C) procedure with NAME may not have "
4905 "POINTER attribute at %C");
4908 if (has_name_equals
&& sym
->attr
.dummy
)
4910 gfc_error ("Dummy procedure at %C may not have "
4911 "BIND(C) attribute with NAME");
4914 /* Set binding label for BIND(C). */
4915 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
4919 if (!gfc_add_external (&sym
->attr
, NULL
))
4922 if (add_hidden_procptr_result (sym
))
4925 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
4928 /* Set interface. */
4929 if (proc_if
!= NULL
)
4931 if (sym
->ts
.type
!= BT_UNKNOWN
)
4933 gfc_error ("Procedure '%s' at %L already has basic type of %s",
4934 sym
->name
, &gfc_current_locus
,
4935 gfc_basic_typename (sym
->ts
.type
));
4938 sym
->ts
.interface
= proc_if
;
4939 sym
->attr
.untyped
= 1;
4940 sym
->attr
.if_source
= IFSRC_IFBODY
;
4942 else if (current_ts
.type
!= BT_UNKNOWN
)
4944 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
4946 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
4947 sym
->ts
.interface
->ts
= current_ts
;
4948 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
4949 sym
->ts
.interface
->attr
.function
= 1;
4950 sym
->attr
.function
= 1;
4951 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4954 if (gfc_match (" =>") == MATCH_YES
)
4956 if (!current_attr
.pointer
)
4958 gfc_error ("Initialization at %C isn't for a pointer variable");
4963 m
= match_pointer_init (&initializer
, 1);
4967 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
4972 if (gfc_match_eos () == MATCH_YES
)
4974 if (gfc_match_char (',') != MATCH_YES
)
4979 gfc_error ("Syntax error in PROCEDURE statement at %C");
4983 /* Free stuff up and return. */
4984 gfc_free_expr (initializer
);
4990 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
4993 /* Match a procedure pointer component declaration (R445). */
4996 match_ppc_decl (void)
4999 gfc_symbol
*proc_if
= NULL
;
5003 gfc_expr
*initializer
= NULL
;
5004 gfc_typebound_proc
* tb
;
5005 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5007 /* Parse interface (with brackets). */
5008 m
= match_procedure_interface (&proc_if
);
5012 /* Parse attributes. */
5013 tb
= XCNEW (gfc_typebound_proc
);
5014 tb
->where
= gfc_current_locus
;
5015 m
= match_binding_attributes (tb
, false, true);
5016 if (m
== MATCH_ERROR
)
5019 gfc_clear_attr (¤t_attr
);
5020 current_attr
.procedure
= 1;
5021 current_attr
.proc_pointer
= 1;
5022 current_attr
.access
= tb
->access
;
5023 current_attr
.flavor
= FL_PROCEDURE
;
5025 /* Match the colons (required). */
5026 if (gfc_match (" ::") != MATCH_YES
)
5028 gfc_error ("Expected '::' after binding-attributes at %C");
5032 /* Check for C450. */
5033 if (!tb
->nopass
&& proc_if
== NULL
)
5035 gfc_error("NOPASS or explicit interface required at %C");
5039 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5042 /* Match PPC names. */
5046 m
= gfc_match_name (name
);
5049 else if (m
== MATCH_ERROR
)
5052 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5055 /* Add current_attr to the symbol attributes. */
5056 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5059 if (!gfc_add_external (&c
->attr
, NULL
))
5062 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5069 c
->tb
= XCNEW (gfc_typebound_proc
);
5070 c
->tb
->where
= gfc_current_locus
;
5074 /* Set interface. */
5075 if (proc_if
!= NULL
)
5077 c
->ts
.interface
= proc_if
;
5078 c
->attr
.untyped
= 1;
5079 c
->attr
.if_source
= IFSRC_IFBODY
;
5081 else if (ts
.type
!= BT_UNKNOWN
)
5084 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5085 c
->ts
.interface
->result
= c
->ts
.interface
;
5086 c
->ts
.interface
->ts
= ts
;
5087 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5088 c
->ts
.interface
->attr
.function
= 1;
5089 c
->attr
.function
= 1;
5090 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5093 if (gfc_match (" =>") == MATCH_YES
)
5095 m
= match_pointer_init (&initializer
, 1);
5098 gfc_free_expr (initializer
);
5101 c
->initializer
= initializer
;
5104 if (gfc_match_eos () == MATCH_YES
)
5106 if (gfc_match_char (',') != MATCH_YES
)
5111 gfc_error ("Syntax error in procedure pointer component at %C");
5116 /* Match a PROCEDURE declaration inside an interface (R1206). */
5119 match_procedure_in_interface (void)
5123 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5126 if (current_interface
.type
== INTERFACE_NAMELESS
5127 || current_interface
.type
== INTERFACE_ABSTRACT
)
5129 gfc_error ("PROCEDURE at %C must be in a generic interface");
5133 /* Check if the F2008 optional double colon appears. */
5134 gfc_gobble_whitespace ();
5135 old_locus
= gfc_current_locus
;
5136 if (gfc_match ("::") == MATCH_YES
)
5138 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5139 "MODULE PROCEDURE statement at %L", &old_locus
))
5143 gfc_current_locus
= old_locus
;
5147 m
= gfc_match_name (name
);
5150 else if (m
== MATCH_ERROR
)
5152 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5155 if (!gfc_add_interface (sym
))
5158 if (gfc_match_eos () == MATCH_YES
)
5160 if (gfc_match_char (',') != MATCH_YES
)
5167 gfc_error ("Syntax error in PROCEDURE statement at %C");
5172 /* General matcher for PROCEDURE declarations. */
5174 static match
match_procedure_in_type (void);
5177 gfc_match_procedure (void)
5181 switch (gfc_current_state ())
5186 case COMP_SUBROUTINE
:
5189 m
= match_procedure_decl ();
5191 case COMP_INTERFACE
:
5192 m
= match_procedure_in_interface ();
5195 m
= match_ppc_decl ();
5197 case COMP_DERIVED_CONTAINS
:
5198 m
= match_procedure_in_type ();
5207 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5214 /* Warn if a matched procedure has the same name as an intrinsic; this is
5215 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5216 parser-state-stack to find out whether we're in a module. */
5219 warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5223 in_module
= (gfc_state_stack
->previous
5224 && gfc_state_stack
->previous
->state
== COMP_MODULE
);
5226 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5230 /* Match a function declaration. */
5233 gfc_match_function_decl (void)
5235 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5236 gfc_symbol
*sym
, *result
;
5240 match found_match
; /* Status returned by match func. */
5242 if (gfc_current_state () != COMP_NONE
5243 && gfc_current_state () != COMP_INTERFACE
5244 && gfc_current_state () != COMP_CONTAINS
)
5247 gfc_clear_ts (¤t_ts
);
5249 old_loc
= gfc_current_locus
;
5251 m
= gfc_match_prefix (¤t_ts
);
5254 gfc_current_locus
= old_loc
;
5258 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5260 gfc_current_locus
= old_loc
;
5263 if (get_proc_name (name
, &sym
, false))
5266 if (add_hidden_procptr_result (sym
))
5269 gfc_new_block
= sym
;
5271 m
= gfc_match_formal_arglist (sym
, 0, 0);
5274 gfc_error ("Expected formal argument list in function "
5275 "definition at %C");
5279 else if (m
== MATCH_ERROR
)
5284 /* According to the draft, the bind(c) and result clause can
5285 come in either order after the formal_arg_list (i.e., either
5286 can be first, both can exist together or by themselves or neither
5287 one). Therefore, the match_result can't match the end of the
5288 string, and check for the bind(c) or result clause in either order. */
5289 found_match
= gfc_match_eos ();
5291 /* Make sure that it isn't already declared as BIND(C). If it is, it
5292 must have been marked BIND(C) with a BIND(C) attribute and that is
5293 not allowed for procedures. */
5294 if (sym
->attr
.is_bind_c
== 1)
5296 sym
->attr
.is_bind_c
= 0;
5297 if (sym
->old_symbol
!= NULL
)
5298 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5299 "variables or common blocks",
5300 &(sym
->old_symbol
->declared_at
));
5302 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5303 "variables or common blocks", &gfc_current_locus
);
5306 if (found_match
!= MATCH_YES
)
5308 /* If we haven't found the end-of-statement, look for a suffix. */
5309 suffix_match
= gfc_match_suffix (sym
, &result
);
5310 if (suffix_match
== MATCH_YES
)
5311 /* Need to get the eos now. */
5312 found_match
= gfc_match_eos ();
5314 found_match
= suffix_match
;
5317 if(found_match
!= MATCH_YES
)
5321 /* Make changes to the symbol. */
5324 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5327 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5328 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5331 /* Delay matching the function characteristics until after the
5332 specification block by signalling kind=-1. */
5333 sym
->declared_at
= old_loc
;
5334 if (current_ts
.type
!= BT_UNKNOWN
)
5335 current_ts
.kind
= -1;
5337 current_ts
.kind
= 0;
5341 if (current_ts
.type
!= BT_UNKNOWN
5342 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5348 if (current_ts
.type
!= BT_UNKNOWN
5349 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5351 sym
->result
= result
;
5354 /* Warn if this procedure has the same name as an intrinsic. */
5355 warn_intrinsic_shadow (sym
, true);
5361 gfc_current_locus
= old_loc
;
5366 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5367 pass the name of the entry, rather than the gfc_current_block name, and
5368 to return false upon finding an existing global entry. */
5371 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5375 enum gfc_symbol_type type
;
5377 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5379 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5380 name is a global identifier. */
5381 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5383 s
= gfc_get_gsymbol (name
);
5385 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5387 gfc_global_used (s
, where
);
5396 s
->ns
= gfc_current_ns
;
5400 /* Don't add the symbol multiple times. */
5402 && (!gfc_notification_std (GFC_STD_F2008
)
5403 || strcmp (name
, binding_label
) != 0))
5405 s
= gfc_get_gsymbol (binding_label
);
5407 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5409 gfc_global_used (s
, where
);
5416 s
->binding_label
= binding_label
;
5419 s
->ns
= gfc_current_ns
;
5427 /* Match an ENTRY statement. */
5430 gfc_match_entry (void)
5435 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5436 gfc_compile_state state
;
5440 bool module_procedure
;
5444 m
= gfc_match_name (name
);
5448 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5451 state
= gfc_current_state ();
5452 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5457 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5460 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5462 case COMP_BLOCK_DATA
:
5463 gfc_error ("ENTRY statement at %C cannot appear within "
5466 case COMP_INTERFACE
:
5467 gfc_error ("ENTRY statement at %C cannot appear within "
5471 gfc_error ("ENTRY statement at %C cannot appear within "
5472 "a DERIVED TYPE block");
5475 gfc_error ("ENTRY statement at %C cannot appear within "
5476 "an IF-THEN block");
5479 case COMP_DO_CONCURRENT
:
5480 gfc_error ("ENTRY statement at %C cannot appear within "
5484 gfc_error ("ENTRY statement at %C cannot appear within "
5488 gfc_error ("ENTRY statement at %C cannot appear within "
5492 gfc_error ("ENTRY statement at %C cannot appear within "
5496 gfc_error ("ENTRY statement at %C cannot appear within "
5497 "a contained subprogram");
5500 gfc_internal_error ("gfc_match_entry(): Bad state");
5505 module_procedure
= gfc_current_ns
->parent
!= NULL
5506 && gfc_current_ns
->parent
->proc_name
5507 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5510 if (gfc_current_ns
->parent
!= NULL
5511 && gfc_current_ns
->parent
->proc_name
5512 && !module_procedure
)
5514 gfc_error("ENTRY statement at %C cannot appear in a "
5515 "contained procedure");
5519 /* Module function entries need special care in get_proc_name
5520 because previous references within the function will have
5521 created symbols attached to the current namespace. */
5522 if (get_proc_name (name
, &entry
,
5523 gfc_current_ns
->parent
!= NULL
5524 && module_procedure
))
5527 proc
= gfc_current_block ();
5529 /* Make sure that it isn't already declared as BIND(C). If it is, it
5530 must have been marked BIND(C) with a BIND(C) attribute and that is
5531 not allowed for procedures. */
5532 if (entry
->attr
.is_bind_c
== 1)
5534 entry
->attr
.is_bind_c
= 0;
5535 if (entry
->old_symbol
!= NULL
)
5536 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5537 "variables or common blocks",
5538 &(entry
->old_symbol
->declared_at
));
5540 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5541 "variables or common blocks", &gfc_current_locus
);
5544 /* Check what next non-whitespace character is so we can tell if there
5545 is the required parens if we have a BIND(C). */
5546 old_loc
= gfc_current_locus
;
5547 gfc_gobble_whitespace ();
5548 peek_char
= gfc_peek_ascii_char ();
5550 if (state
== COMP_SUBROUTINE
)
5552 m
= gfc_match_formal_arglist (entry
, 0, 1);
5556 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5557 never be an internal procedure. */
5558 is_bind_c
= gfc_match_bind_c (entry
, true);
5559 if (is_bind_c
== MATCH_ERROR
)
5561 if (is_bind_c
== MATCH_YES
)
5563 if (peek_char
!= '(')
5565 gfc_error ("Missing required parentheses before BIND(C) at %C");
5568 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5569 &(entry
->declared_at
), 1))
5573 if (!gfc_current_ns
->parent
5574 && !add_global_entry (name
, entry
->binding_label
, true,
5578 /* An entry in a subroutine. */
5579 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5580 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5585 /* An entry in a function.
5586 We need to take special care because writing
5591 ENTRY f() RESULT (r)
5593 ENTRY f RESULT (r). */
5594 if (gfc_match_eos () == MATCH_YES
)
5596 gfc_current_locus
= old_loc
;
5597 /* Match the empty argument list, and add the interface to
5599 m
= gfc_match_formal_arglist (entry
, 0, 1);
5602 m
= gfc_match_formal_arglist (entry
, 0, 0);
5609 if (gfc_match_eos () == MATCH_YES
)
5611 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5612 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5615 entry
->result
= entry
;
5619 m
= gfc_match_suffix (entry
, &result
);
5621 gfc_syntax_error (ST_ENTRY
);
5627 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5628 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5629 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5631 entry
->result
= result
;
5635 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5636 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5638 entry
->result
= entry
;
5642 if (!gfc_current_ns
->parent
5643 && !add_global_entry (name
, entry
->binding_label
, false,
5648 if (gfc_match_eos () != MATCH_YES
)
5650 gfc_syntax_error (ST_ENTRY
);
5654 entry
->attr
.recursive
= proc
->attr
.recursive
;
5655 entry
->attr
.elemental
= proc
->attr
.elemental
;
5656 entry
->attr
.pure
= proc
->attr
.pure
;
5658 el
= gfc_get_entry_list ();
5660 el
->next
= gfc_current_ns
->entries
;
5661 gfc_current_ns
->entries
= el
;
5663 el
->id
= el
->next
->id
+ 1;
5667 new_st
.op
= EXEC_ENTRY
;
5668 new_st
.ext
.entry
= el
;
5674 /* Match a subroutine statement, including optional prefixes. */
5677 gfc_match_subroutine (void)
5679 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5684 bool allow_binding_name
;
5686 if (gfc_current_state () != COMP_NONE
5687 && gfc_current_state () != COMP_INTERFACE
5688 && gfc_current_state () != COMP_CONTAINS
)
5691 m
= gfc_match_prefix (NULL
);
5695 m
= gfc_match ("subroutine% %n", name
);
5699 if (get_proc_name (name
, &sym
, false))
5702 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5703 the symbol existed before. */
5704 sym
->declared_at
= gfc_current_locus
;
5706 if (add_hidden_procptr_result (sym
))
5709 gfc_new_block
= sym
;
5711 /* Check what next non-whitespace character is so we can tell if there
5712 is the required parens if we have a BIND(C). */
5713 gfc_gobble_whitespace ();
5714 peek_char
= gfc_peek_ascii_char ();
5716 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5719 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5722 /* Make sure that it isn't already declared as BIND(C). If it is, it
5723 must have been marked BIND(C) with a BIND(C) attribute and that is
5724 not allowed for procedures. */
5725 if (sym
->attr
.is_bind_c
== 1)
5727 sym
->attr
.is_bind_c
= 0;
5728 if (sym
->old_symbol
!= NULL
)
5729 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5730 "variables or common blocks",
5731 &(sym
->old_symbol
->declared_at
));
5733 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5734 "variables or common blocks", &gfc_current_locus
);
5737 /* C binding names are not allowed for internal procedures. */
5738 if (gfc_current_state () == COMP_CONTAINS
5739 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5740 allow_binding_name
= false;
5742 allow_binding_name
= true;
5744 /* Here, we are just checking if it has the bind(c) attribute, and if
5745 so, then we need to make sure it's all correct. If it doesn't,
5746 we still need to continue matching the rest of the subroutine line. */
5747 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5748 if (is_bind_c
== MATCH_ERROR
)
5750 /* There was an attempt at the bind(c), but it was wrong. An
5751 error message should have been printed w/in the gfc_match_bind_c
5752 so here we'll just return the MATCH_ERROR. */
5756 if (is_bind_c
== MATCH_YES
)
5758 /* The following is allowed in the Fortran 2008 draft. */
5759 if (gfc_current_state () == COMP_CONTAINS
5760 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5761 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5762 "at %L may not be specified for an internal "
5763 "procedure", &gfc_current_locus
))
5766 if (peek_char
!= '(')
5768 gfc_error ("Missing required parentheses before BIND(C) at %C");
5771 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5772 &(sym
->declared_at
), 1))
5776 if (gfc_match_eos () != MATCH_YES
)
5778 gfc_syntax_error (ST_SUBROUTINE
);
5782 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5785 /* Warn if it has the same name as an intrinsic. */
5786 warn_intrinsic_shadow (sym
, false);
5792 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
5793 given, and set the binding label in either the given symbol (if not
5794 NULL), or in the current_ts. The symbol may be NULL because we may
5795 encounter the BIND(C) before the declaration itself. Return
5796 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
5797 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
5798 or MATCH_YES if the specifier was correct and the binding label and
5799 bind(c) fields were set correctly for the given symbol or the
5800 current_ts. If allow_binding_name is false, no binding name may be
5804 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
5806 /* binding label, if exists */
5807 const char* binding_label
= NULL
;
5811 /* Initialize the flag that specifies whether we encountered a NAME=
5812 specifier or not. */
5813 has_name_equals
= 0;
5815 /* This much we have to be able to match, in this order, if
5816 there is a bind(c) label. */
5817 if (gfc_match (" bind ( c ") != MATCH_YES
)
5820 /* Now see if there is a binding label, or if we've reached the
5821 end of the bind(c) attribute without one. */
5822 if (gfc_match_char (',') == MATCH_YES
)
5824 if (gfc_match (" name = ") != MATCH_YES
)
5826 gfc_error ("Syntax error in NAME= specifier for binding label "
5828 /* should give an error message here */
5832 has_name_equals
= 1;
5834 /* Get the opening quote. */
5835 double_quote
= MATCH_YES
;
5836 single_quote
= MATCH_YES
;
5837 double_quote
= gfc_match_char ('"');
5838 if (double_quote
!= MATCH_YES
)
5839 single_quote
= gfc_match_char ('\'');
5840 if (double_quote
!= MATCH_YES
&& single_quote
!= MATCH_YES
)
5842 gfc_error ("Syntax error in NAME= specifier for binding label "
5847 /* Grab the binding label, using functions that will not lower
5848 case the names automatically. */
5849 if (gfc_match_name_C (&binding_label
) != MATCH_YES
)
5852 /* Get the closing quotation. */
5853 if (double_quote
== MATCH_YES
)
5855 if (gfc_match_char ('"') != MATCH_YES
)
5857 gfc_error ("Missing closing quote '\"' for binding label at %C");
5858 /* User started string with '"' so looked to match it. */
5864 if (gfc_match_char ('\'') != MATCH_YES
)
5866 gfc_error ("Missing closing quote '\'' for binding label at %C");
5867 /* User started string with "'" char. */
5873 /* Get the required right paren. */
5874 if (gfc_match_char (')') != MATCH_YES
)
5876 gfc_error ("Missing closing paren for binding label at %C");
5880 if (has_name_equals
&& !allow_binding_name
)
5882 gfc_error ("No binding name is allowed in BIND(C) at %C");
5886 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
5888 gfc_error ("For dummy procedure %s, no binding name is "
5889 "allowed in BIND(C) at %C", sym
->name
);
5894 /* Save the binding label to the symbol. If sym is null, we're
5895 probably matching the typespec attributes of a declaration and
5896 haven't gotten the name yet, and therefore, no symbol yet. */
5900 sym
->binding_label
= binding_label
;
5902 curr_binding_label
= binding_label
;
5904 else if (allow_binding_name
)
5906 /* No binding label, but if symbol isn't null, we
5907 can set the label for it here.
5908 If name="" or allow_binding_name is false, no C binding name is
5910 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
5911 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
5914 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
5915 && current_interface
.type
== INTERFACE_ABSTRACT
)
5917 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
5925 /* Return nonzero if we're currently compiling a contained procedure. */
5928 contained_procedure (void)
5930 gfc_state_data
*s
= gfc_state_stack
;
5932 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
5933 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
5939 /* Set the kind of each enumerator. The kind is selected such that it is
5940 interoperable with the corresponding C enumeration type, making
5941 sure that -fshort-enums is honored. */
5946 enumerator_history
*current_history
= NULL
;
5950 if (max_enum
== NULL
|| enum_history
== NULL
)
5953 if (!flag_short_enums
)
5959 kind
= gfc_integer_kinds
[i
++].kind
;
5961 while (kind
< gfc_c_int_kind
5962 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
5965 current_history
= enum_history
;
5966 while (current_history
!= NULL
)
5968 current_history
->sym
->ts
.kind
= kind
;
5969 current_history
= current_history
->next
;
5974 /* Match any of the various end-block statements. Returns the type of
5975 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
5976 and END BLOCK statements cannot be replaced by a single END statement. */
5979 gfc_match_end (gfc_statement
*st
)
5981 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5982 gfc_compile_state state
;
5984 const char *block_name
;
5988 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
5989 gfc_namespace
**nsp
;
5991 old_loc
= gfc_current_locus
;
5992 if (gfc_match ("end") != MATCH_YES
)
5995 state
= gfc_current_state ();
5996 block_name
= gfc_current_block () == NULL
5997 ? NULL
: gfc_current_block ()->name
;
6001 case COMP_ASSOCIATE
:
6003 if (!strncmp (block_name
, "block@", strlen("block@")))
6008 case COMP_DERIVED_CONTAINS
:
6009 state
= gfc_state_stack
->previous
->state
;
6010 block_name
= gfc_state_stack
->previous
->sym
== NULL
6011 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6022 *st
= ST_END_PROGRAM
;
6023 target
= " program";
6027 case COMP_SUBROUTINE
:
6028 *st
= ST_END_SUBROUTINE
;
6029 target
= " subroutine";
6030 eos_ok
= !contained_procedure ();
6034 *st
= ST_END_FUNCTION
;
6035 target
= " function";
6036 eos_ok
= !contained_procedure ();
6039 case COMP_BLOCK_DATA
:
6040 *st
= ST_END_BLOCK_DATA
;
6041 target
= " block data";
6046 *st
= ST_END_MODULE
;
6051 case COMP_INTERFACE
:
6052 *st
= ST_END_INTERFACE
;
6053 target
= " interface";
6058 case COMP_DERIVED_CONTAINS
:
6064 case COMP_ASSOCIATE
:
6065 *st
= ST_END_ASSOCIATE
;
6066 target
= " associate";
6083 case COMP_DO_CONCURRENT
:
6090 *st
= ST_END_CRITICAL
;
6091 target
= " critical";
6096 case COMP_SELECT_TYPE
:
6097 *st
= ST_END_SELECT
;
6103 *st
= ST_END_FORALL
;
6118 last_initializer
= NULL
;
6120 gfc_free_enum_history ();
6124 gfc_error ("Unexpected END statement at %C");
6128 old_loc
= gfc_current_locus
;
6129 if (gfc_match_eos () == MATCH_YES
)
6131 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6133 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6134 "instead of %s statement at %L",
6135 gfc_ascii_statement(*st
), &old_loc
))
6140 /* We would have required END [something]. */
6141 gfc_error ("%s statement expected at %L",
6142 gfc_ascii_statement (*st
), &old_loc
);
6149 /* Verify that we've got the sort of end-block that we're expecting. */
6150 if (gfc_match (target
) != MATCH_YES
)
6152 gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st
),
6157 old_loc
= gfc_current_locus
;
6158 /* If we're at the end, make sure a block name wasn't required. */
6159 if (gfc_match_eos () == MATCH_YES
)
6162 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6163 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6164 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6170 gfc_error ("Expected block name of '%s' in %s statement at %L",
6171 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6176 /* END INTERFACE has a special handler for its several possible endings. */
6177 if (*st
== ST_END_INTERFACE
)
6178 return gfc_match_end_interface ();
6180 /* We haven't hit the end of statement, so what is left must be an
6182 m
= gfc_match_space ();
6184 m
= gfc_match_name (name
);
6187 gfc_error ("Expected terminating name at %C");
6191 if (block_name
== NULL
)
6194 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6196 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
6197 gfc_ascii_statement (*st
));
6200 /* Procedure pointer as function result. */
6201 else if (strcmp (block_name
, "ppr@") == 0
6202 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6204 gfc_error ("Expected label '%s' for %s statement at %C",
6205 gfc_current_block ()->ns
->proc_name
->name
,
6206 gfc_ascii_statement (*st
));
6210 if (gfc_match_eos () == MATCH_YES
)
6214 gfc_syntax_error (*st
);
6217 gfc_current_locus
= old_loc
;
6219 /* If we are missing an END BLOCK, we created a half-ready namespace.
6220 Remove it from the parent namespace's sibling list. */
6222 if (state
== COMP_BLOCK
)
6224 parent_ns
= gfc_current_ns
->parent
;
6226 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6232 if (ns
== gfc_current_ns
)
6234 if (prev_ns
== NULL
)
6237 prev_ns
->sibling
= ns
->sibling
;
6243 gfc_free_namespace (gfc_current_ns
);
6244 gfc_current_ns
= parent_ns
;
6252 /***************** Attribute declaration statements ****************/
6254 /* Set the attribute of a single variable. */
6259 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6267 m
= gfc_match_name (name
);
6271 if (find_special (name
, &sym
, false))
6274 if (!check_function_name (name
))
6280 var_locus
= gfc_current_locus
;
6282 /* Deal with possible array specification for certain attributes. */
6283 if (current_attr
.dimension
6284 || current_attr
.codimension
6285 || current_attr
.allocatable
6286 || current_attr
.pointer
6287 || current_attr
.target
)
6289 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6290 !current_attr
.dimension
6291 && !current_attr
.pointer
6292 && !current_attr
.target
);
6293 if (m
== MATCH_ERROR
)
6296 if (current_attr
.dimension
&& m
== MATCH_NO
)
6298 gfc_error ("Missing array specification at %L in DIMENSION "
6299 "statement", &var_locus
);
6304 if (current_attr
.dimension
&& sym
->value
)
6306 gfc_error ("Dimensions specified for %s at %L after its "
6307 "initialisation", sym
->name
, &var_locus
);
6312 if (current_attr
.codimension
&& m
== MATCH_NO
)
6314 gfc_error ("Missing array specification at %L in CODIMENSION "
6315 "statement", &var_locus
);
6320 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6321 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6323 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6329 /* Update symbol table. DIMENSION attribute is set in
6330 gfc_set_array_spec(). For CLASS variables, this must be applied
6331 to the first component, or '_data' field. */
6332 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6334 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6342 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6343 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6350 if (sym
->ts
.type
== BT_CLASS
6351 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6357 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6363 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6365 /* Fix the array spec. */
6366 m
= gfc_mod_pointee_as (sym
->as
);
6367 if (m
== MATCH_ERROR
)
6371 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6377 if ((current_attr
.external
|| current_attr
.intrinsic
)
6378 && sym
->attr
.flavor
!= FL_PROCEDURE
6379 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6385 add_hidden_procptr_result (sym
);
6390 gfc_free_array_spec (as
);
6395 /* Generic attribute declaration subroutine. Used for attributes that
6396 just have a list of names. */
6403 /* Gobble the optional double colon, by simply ignoring the result
6413 if (gfc_match_eos () == MATCH_YES
)
6419 if (gfc_match_char (',') != MATCH_YES
)
6421 gfc_error ("Unexpected character in variable list at %C");
6431 /* This routine matches Cray Pointer declarations of the form:
6432 pointer ( <pointer>, <pointee> )
6434 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6435 The pointer, if already declared, should be an integer. Otherwise, we
6436 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6437 be either a scalar, or an array declaration. No space is allocated for
6438 the pointee. For the statement
6439 pointer (ipt, ar(10))
6440 any subsequent uses of ar will be translated (in C-notation) as
6441 ar(i) => ((<type> *) ipt)(i)
6442 After gimplification, pointee variable will disappear in the code. */
6445 cray_pointer_decl (void)
6448 gfc_array_spec
*as
= NULL
;
6449 gfc_symbol
*cptr
; /* Pointer symbol. */
6450 gfc_symbol
*cpte
; /* Pointee symbol. */
6456 if (gfc_match_char ('(') != MATCH_YES
)
6458 gfc_error ("Expected '(' at %C");
6462 /* Match pointer. */
6463 var_locus
= gfc_current_locus
;
6464 gfc_clear_attr (¤t_attr
);
6465 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6466 current_ts
.type
= BT_INTEGER
;
6467 current_ts
.kind
= gfc_index_integer_kind
;
6469 m
= gfc_match_symbol (&cptr
, 0);
6472 gfc_error ("Expected variable name at %C");
6476 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6479 gfc_set_sym_referenced (cptr
);
6481 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6483 cptr
->ts
.type
= BT_INTEGER
;
6484 cptr
->ts
.kind
= gfc_index_integer_kind
;
6486 else if (cptr
->ts
.type
!= BT_INTEGER
)
6488 gfc_error ("Cray pointer at %C must be an integer");
6491 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6492 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
6493 " memory addresses require %d bytes",
6494 cptr
->ts
.kind
, gfc_index_integer_kind
);
6496 if (gfc_match_char (',') != MATCH_YES
)
6498 gfc_error ("Expected \",\" at %C");
6502 /* Match Pointee. */
6503 var_locus
= gfc_current_locus
;
6504 gfc_clear_attr (¤t_attr
);
6505 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6506 current_ts
.type
= BT_UNKNOWN
;
6507 current_ts
.kind
= 0;
6509 m
= gfc_match_symbol (&cpte
, 0);
6512 gfc_error ("Expected variable name at %C");
6516 /* Check for an optional array spec. */
6517 m
= gfc_match_array_spec (&as
, true, false);
6518 if (m
== MATCH_ERROR
)
6520 gfc_free_array_spec (as
);
6523 else if (m
== MATCH_NO
)
6525 gfc_free_array_spec (as
);
6529 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6532 gfc_set_sym_referenced (cpte
);
6534 if (cpte
->as
== NULL
)
6536 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6537 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6539 else if (as
!= NULL
)
6541 gfc_error ("Duplicate array spec for Cray pointee at %C");
6542 gfc_free_array_spec (as
);
6548 if (cpte
->as
!= NULL
)
6550 /* Fix array spec. */
6551 m
= gfc_mod_pointee_as (cpte
->as
);
6552 if (m
== MATCH_ERROR
)
6556 /* Point the Pointee at the Pointer. */
6557 cpte
->cp_pointer
= cptr
;
6559 if (gfc_match_char (')') != MATCH_YES
)
6561 gfc_error ("Expected \")\" at %C");
6564 m
= gfc_match_char (',');
6566 done
= true; /* Stop searching for more declarations. */
6570 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6571 || gfc_match_eos () != MATCH_YES
)
6573 gfc_error ("Expected \",\" or end of statement at %C");
6581 gfc_match_external (void)
6584 gfc_clear_attr (¤t_attr
);
6585 current_attr
.external
= 1;
6587 return attr_decl ();
6592 gfc_match_intent (void)
6596 /* This is not allowed within a BLOCK construct! */
6597 if (gfc_current_state () == COMP_BLOCK
)
6599 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6603 intent
= match_intent_spec ();
6604 if (intent
== INTENT_UNKNOWN
)
6607 gfc_clear_attr (¤t_attr
);
6608 current_attr
.intent
= intent
;
6610 return attr_decl ();
6615 gfc_match_intrinsic (void)
6618 gfc_clear_attr (¤t_attr
);
6619 current_attr
.intrinsic
= 1;
6621 return attr_decl ();
6626 gfc_match_optional (void)
6628 /* This is not allowed within a BLOCK construct! */
6629 if (gfc_current_state () == COMP_BLOCK
)
6631 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6635 gfc_clear_attr (¤t_attr
);
6636 current_attr
.optional
= 1;
6638 return attr_decl ();
6643 gfc_match_pointer (void)
6645 gfc_gobble_whitespace ();
6646 if (gfc_peek_ascii_char () == '(')
6648 if (!gfc_option
.flag_cray_pointer
)
6650 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6654 return cray_pointer_decl ();
6658 gfc_clear_attr (¤t_attr
);
6659 current_attr
.pointer
= 1;
6661 return attr_decl ();
6667 gfc_match_allocatable (void)
6669 gfc_clear_attr (¤t_attr
);
6670 current_attr
.allocatable
= 1;
6672 return attr_decl ();
6677 gfc_match_codimension (void)
6679 gfc_clear_attr (¤t_attr
);
6680 current_attr
.codimension
= 1;
6682 return attr_decl ();
6687 gfc_match_contiguous (void)
6689 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6692 gfc_clear_attr (¤t_attr
);
6693 current_attr
.contiguous
= 1;
6695 return attr_decl ();
6700 gfc_match_dimension (void)
6702 gfc_clear_attr (¤t_attr
);
6703 current_attr
.dimension
= 1;
6705 return attr_decl ();
6710 gfc_match_target (void)
6712 gfc_clear_attr (¤t_attr
);
6713 current_attr
.target
= 1;
6715 return attr_decl ();
6719 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6723 access_attr_decl (gfc_statement st
)
6725 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6726 interface_type type
;
6728 gfc_symbol
*sym
, *dt_sym
;
6729 gfc_intrinsic_op op
;
6732 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6737 m
= gfc_match_generic_spec (&type
, name
, &op
);
6740 if (m
== MATCH_ERROR
)
6745 case INTERFACE_NAMELESS
:
6746 case INTERFACE_ABSTRACT
:
6749 case INTERFACE_GENERIC
:
6750 if (gfc_get_symbol (name
, NULL
, &sym
))
6753 if (!gfc_add_access (&sym
->attr
,
6755 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6759 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
6760 && !gfc_add_access (&dt_sym
->attr
,
6762 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6768 case INTERFACE_INTRINSIC_OP
:
6769 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
6771 gfc_intrinsic_op other_op
;
6773 gfc_current_ns
->operator_access
[op
] =
6774 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6776 /* Handle the case if there is another op with the same
6777 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
6778 other_op
= gfc_equivalent_op (op
);
6780 if (other_op
!= INTRINSIC_NONE
)
6781 gfc_current_ns
->operator_access
[other_op
] =
6782 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6787 gfc_error ("Access specification of the %s operator at %C has "
6788 "already been specified", gfc_op2string (op
));
6794 case INTERFACE_USER_OP
:
6795 uop
= gfc_get_uop (name
);
6797 if (uop
->access
== ACCESS_UNKNOWN
)
6799 uop
->access
= (st
== ST_PUBLIC
)
6800 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6804 gfc_error ("Access specification of the .%s. operator at %C "
6805 "has already been specified", sym
->name
);
6812 if (gfc_match_char (',') == MATCH_NO
)
6816 if (gfc_match_eos () != MATCH_YES
)
6821 gfc_syntax_error (st
);
6829 gfc_match_protected (void)
6834 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6836 gfc_error ("PROTECTED at %C only allowed in specification "
6837 "part of a module");
6842 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
6845 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6850 if (gfc_match_eos () == MATCH_YES
)
6855 m
= gfc_match_symbol (&sym
, 0);
6859 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
6871 if (gfc_match_eos () == MATCH_YES
)
6873 if (gfc_match_char (',') != MATCH_YES
)
6880 gfc_error ("Syntax error in PROTECTED statement at %C");
6885 /* The PRIVATE statement is a bit weird in that it can be an attribute
6886 declaration, but also works as a standalone statement inside of a
6887 type declaration or a module. */
6890 gfc_match_private (gfc_statement
*st
)
6893 if (gfc_match ("private") != MATCH_YES
)
6896 if (gfc_current_state () != COMP_MODULE
6897 && !(gfc_current_state () == COMP_DERIVED
6898 && gfc_state_stack
->previous
6899 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
6900 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
6901 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
6902 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
6904 gfc_error ("PRIVATE statement at %C is only allowed in the "
6905 "specification part of a module");
6909 if (gfc_current_state () == COMP_DERIVED
)
6911 if (gfc_match_eos () == MATCH_YES
)
6917 gfc_syntax_error (ST_PRIVATE
);
6921 if (gfc_match_eos () == MATCH_YES
)
6928 return access_attr_decl (ST_PRIVATE
);
6933 gfc_match_public (gfc_statement
*st
)
6936 if (gfc_match ("public") != MATCH_YES
)
6939 if (gfc_current_state () != COMP_MODULE
)
6941 gfc_error ("PUBLIC statement at %C is only allowed in the "
6942 "specification part of a module");
6946 if (gfc_match_eos () == MATCH_YES
)
6953 return access_attr_decl (ST_PUBLIC
);
6957 /* Workhorse for gfc_match_parameter. */
6967 m
= gfc_match_symbol (&sym
, 0);
6969 gfc_error ("Expected variable name at %C in PARAMETER statement");
6974 if (gfc_match_char ('=') == MATCH_NO
)
6976 gfc_error ("Expected = sign in PARAMETER statement at %C");
6980 m
= gfc_match_init_expr (&init
);
6982 gfc_error ("Expected expression at %C in PARAMETER statement");
6986 if (sym
->ts
.type
== BT_UNKNOWN
6987 && !gfc_set_default_type (sym
, 1, NULL
))
6993 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
6994 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7002 gfc_error ("Initializing already initialized variable at %C");
7007 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7008 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7011 gfc_free_expr (init
);
7016 /* Match a parameter statement, with the weird syntax that these have. */
7019 gfc_match_parameter (void)
7023 if (gfc_match_char ('(') == MATCH_NO
)
7032 if (gfc_match (" )%t") == MATCH_YES
)
7035 if (gfc_match_char (',') != MATCH_YES
)
7037 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7047 /* Save statements have a special syntax. */
7050 gfc_match_save (void)
7052 char n
[GFC_MAX_SYMBOL_LEN
+1];
7057 if (gfc_match_eos () == MATCH_YES
)
7059 if (gfc_current_ns
->seen_save
)
7061 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7062 "follows previous SAVE statement"))
7066 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7070 if (gfc_current_ns
->save_all
)
7072 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7073 "blanket SAVE statement"))
7081 m
= gfc_match_symbol (&sym
, 0);
7085 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7086 &gfc_current_locus
))
7097 m
= gfc_match (" / %n /", &n
);
7098 if (m
== MATCH_ERROR
)
7103 c
= gfc_get_common (n
, 0);
7106 gfc_current_ns
->seen_save
= 1;
7109 if (gfc_match_eos () == MATCH_YES
)
7111 if (gfc_match_char (',') != MATCH_YES
)
7118 gfc_error ("Syntax error in SAVE statement at %C");
7124 gfc_match_value (void)
7129 /* This is not allowed within a BLOCK construct! */
7130 if (gfc_current_state () == COMP_BLOCK
)
7132 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7136 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7139 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7144 if (gfc_match_eos () == MATCH_YES
)
7149 m
= gfc_match_symbol (&sym
, 0);
7153 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7165 if (gfc_match_eos () == MATCH_YES
)
7167 if (gfc_match_char (',') != MATCH_YES
)
7174 gfc_error ("Syntax error in VALUE statement at %C");
7180 gfc_match_volatile (void)
7185 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7188 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7193 if (gfc_match_eos () == MATCH_YES
)
7198 /* VOLATILE is special because it can be added to host-associated
7199 symbols locally. Except for coarrays. */
7200 m
= gfc_match_symbol (&sym
, 1);
7204 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7205 for variable in a BLOCK which is defined outside of the BLOCK. */
7206 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7208 gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
7209 "%C, which is use-/host-associated", sym
->name
);
7212 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7224 if (gfc_match_eos () == MATCH_YES
)
7226 if (gfc_match_char (',') != MATCH_YES
)
7233 gfc_error ("Syntax error in VOLATILE statement at %C");
7239 gfc_match_asynchronous (void)
7244 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7247 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7252 if (gfc_match_eos () == MATCH_YES
)
7257 /* ASYNCHRONOUS is special because it can be added to host-associated
7259 m
= gfc_match_symbol (&sym
, 1);
7263 if (!gfc_add_asynchronous (&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 ASYNCHRONOUS statement at %C");
7289 /* Match a module procedure statement. Note that we have to modify
7290 symbols in the parent's namespace because the current one was there
7291 to receive symbols that are in an interface's formal argument list. */
7294 gfc_match_modproc (void)
7296 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7300 gfc_namespace
*module_ns
;
7301 gfc_interface
*old_interface_head
, *interface
;
7303 if (gfc_state_stack
->state
!= COMP_INTERFACE
7304 || gfc_state_stack
->previous
== NULL
7305 || current_interface
.type
== INTERFACE_NAMELESS
7306 || current_interface
.type
== INTERFACE_ABSTRACT
)
7308 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7313 module_ns
= gfc_current_ns
->parent
;
7314 for (; module_ns
; module_ns
= module_ns
->parent
)
7315 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7316 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7317 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7318 && !module_ns
->proc_name
->attr
.contained
))
7321 if (module_ns
== NULL
)
7324 /* Store the current state of the interface. We will need it if we
7325 end up with a syntax error and need to recover. */
7326 old_interface_head
= gfc_current_interface_head ();
7328 /* Check if the F2008 optional double colon appears. */
7329 gfc_gobble_whitespace ();
7330 old_locus
= gfc_current_locus
;
7331 if (gfc_match ("::") == MATCH_YES
)
7333 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7334 "MODULE PROCEDURE statement at %L", &old_locus
))
7338 gfc_current_locus
= old_locus
;
7343 old_locus
= gfc_current_locus
;
7345 m
= gfc_match_name (name
);
7351 /* Check for syntax error before starting to add symbols to the
7352 current namespace. */
7353 if (gfc_match_eos () == MATCH_YES
)
7356 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7359 /* Now we're sure the syntax is valid, we process this item
7361 if (gfc_get_symbol (name
, module_ns
, &sym
))
7364 if (sym
->attr
.intrinsic
)
7366 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7367 "PROCEDURE", &old_locus
);
7371 if (sym
->attr
.proc
!= PROC_MODULE
7372 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7375 if (!gfc_add_interface (sym
))
7378 sym
->attr
.mod_proc
= 1;
7379 sym
->declared_at
= old_locus
;
7388 /* Restore the previous state of the interface. */
7389 interface
= gfc_current_interface_head ();
7390 gfc_set_current_interface_head (old_interface_head
);
7392 /* Free the new interfaces. */
7393 while (interface
!= old_interface_head
)
7395 gfc_interface
*i
= interface
->next
;
7400 /* And issue a syntax error. */
7401 gfc_syntax_error (ST_MODULE_PROC
);
7406 /* Check a derived type that is being extended. */
7409 check_extended_derived_type (char *name
)
7411 gfc_symbol
*extended
;
7413 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7415 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7419 extended
= gfc_find_dt_in_generic (extended
);
7424 gfc_error ("Symbol '%s' at %C has not been previously defined", name
);
7428 if (extended
->attr
.flavor
!= FL_DERIVED
)
7430 gfc_error ("'%s' in EXTENDS expression at %C is not a "
7431 "derived type", name
);
7435 if (extended
->attr
.is_bind_c
)
7437 gfc_error ("'%s' cannot be extended at %C because it "
7438 "is BIND(C)", extended
->name
);
7442 if (extended
->attr
.sequence
)
7444 gfc_error ("'%s' cannot be extended at %C because it "
7445 "is a SEQUENCE type", extended
->name
);
7453 /* Match the optional attribute specifiers for a type declaration.
7454 Return MATCH_ERROR if an error is encountered in one of the handled
7455 attributes (public, private, bind(c)), MATCH_NO if what's found is
7456 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7457 checking on attribute conflicts needs to be done. */
7460 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7462 /* See if the derived type is marked as private. */
7463 if (gfc_match (" , private") == MATCH_YES
)
7465 if (gfc_current_state () != COMP_MODULE
)
7467 gfc_error ("Derived type at %C can only be PRIVATE in the "
7468 "specification part of a module");
7472 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7475 else if (gfc_match (" , public") == MATCH_YES
)
7477 if (gfc_current_state () != COMP_MODULE
)
7479 gfc_error ("Derived type at %C can only be PUBLIC in the "
7480 "specification part of a module");
7484 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7487 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7489 /* If the type is defined to be bind(c) it then needs to make
7490 sure that all fields are interoperable. This will
7491 need to be a semantic check on the finished derived type.
7492 See 15.2.3 (lines 9-12) of F2003 draft. */
7493 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7496 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7498 else if (gfc_match (" , abstract") == MATCH_YES
)
7500 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7503 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7506 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7508 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7514 /* If we get here, something matched. */
7519 /* Match the beginning of a derived type declaration. If a type name
7520 was the result of a function, then it is possible to have a symbol
7521 already to be known as a derived type yet have no components. */
7524 gfc_match_derived_decl (void)
7526 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7527 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7528 symbol_attribute attr
;
7529 gfc_symbol
*sym
, *gensym
;
7530 gfc_symbol
*extended
;
7532 match is_type_attr_spec
= MATCH_NO
;
7533 bool seen_attr
= false;
7534 gfc_interface
*intr
= NULL
, *head
;
7536 if (gfc_current_state () == COMP_DERIVED
)
7541 gfc_clear_attr (&attr
);
7546 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7547 if (is_type_attr_spec
== MATCH_ERROR
)
7549 if (is_type_attr_spec
== MATCH_YES
)
7551 } while (is_type_attr_spec
== MATCH_YES
);
7553 /* Deal with derived type extensions. The extension attribute has
7554 been added to 'attr' but now the parent type must be found and
7557 extended
= check_extended_derived_type (parent
);
7559 if (parent
[0] && !extended
)
7562 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7564 gfc_error ("Expected :: in TYPE definition at %C");
7568 m
= gfc_match (" %n%t", name
);
7572 /* Make sure the name is not the name of an intrinsic type. */
7573 if (gfc_is_intrinsic_typename (name
))
7575 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
7580 if (gfc_get_symbol (name
, NULL
, &gensym
))
7583 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7585 gfc_error ("Derived type name '%s' at %C already has a basic type "
7586 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7590 if (!gensym
->attr
.generic
7591 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7594 if (!gensym
->attr
.function
7595 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7598 sym
= gfc_find_dt_in_generic (gensym
);
7600 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7602 gfc_error ("Derived type definition of '%s' at %C has already been "
7603 "defined", sym
->name
);
7609 /* Use upper case to save the actual derived-type symbol. */
7610 gfc_get_symbol (gfc_get_string ("%c%s",
7611 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7612 &gensym
->name
[1]), NULL
, &sym
);
7613 sym
->name
= gfc_get_string (gensym
->name
);
7614 head
= gensym
->generic
;
7615 intr
= gfc_get_interface ();
7617 intr
->where
= gfc_current_locus
;
7618 intr
->sym
->declared_at
= gfc_current_locus
;
7620 gensym
->generic
= intr
;
7621 gensym
->attr
.if_source
= IFSRC_DECL
;
7624 /* The symbol may already have the derived attribute without the
7625 components. The ways this can happen is via a function
7626 definition, an INTRINSIC statement or a subtype in another
7627 derived type that is a pointer. The first part of the AND clause
7628 is true if the symbol is not the return value of a function. */
7629 if (sym
->attr
.flavor
!= FL_DERIVED
7630 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
7633 if (attr
.access
!= ACCESS_UNKNOWN
7634 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
7636 else if (sym
->attr
.access
== ACCESS_UNKNOWN
7637 && gensym
->attr
.access
!= ACCESS_UNKNOWN
7638 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
7642 if (sym
->attr
.access
!= ACCESS_UNKNOWN
7643 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
7644 gensym
->attr
.access
= sym
->attr
.access
;
7646 /* See if the derived type was labeled as bind(c). */
7647 if (attr
.is_bind_c
!= 0)
7648 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
7650 /* Construct the f2k_derived namespace if it is not yet there. */
7651 if (!sym
->f2k_derived
)
7652 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7654 if (extended
&& !sym
->components
)
7659 /* Add the extended derived type as the first component. */
7660 gfc_add_component (sym
, parent
, &p
);
7662 gfc_set_sym_referenced (extended
);
7664 p
->ts
.type
= BT_DERIVED
;
7665 p
->ts
.u
.derived
= extended
;
7666 p
->initializer
= gfc_default_initializer (&p
->ts
);
7668 /* Set extension level. */
7669 if (extended
->attr
.extension
== 255)
7671 /* Since the extension field is 8 bit wide, we can only have
7672 up to 255 extension levels. */
7673 gfc_error ("Maximum extension level reached with type '%s' at %L",
7674 extended
->name
, &extended
->declared_at
);
7677 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
7679 /* Provide the links between the extended type and its extension. */
7680 if (!extended
->f2k_derived
)
7681 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7682 st
= gfc_new_symtree (&extended
->f2k_derived
->sym_root
, sym
->name
);
7686 if (!sym
->hash_value
)
7687 /* Set the hash for the compound name for this type. */
7688 sym
->hash_value
= gfc_hash_value (sym
);
7690 /* Take over the ABSTRACT attribute. */
7691 sym
->attr
.abstract
= attr
.abstract
;
7693 gfc_new_block
= sym
;
7699 /* Cray Pointees can be declared as:
7700 pointer (ipt, a (n,m,...,*)) */
7703 gfc_mod_pointee_as (gfc_array_spec
*as
)
7705 as
->cray_pointee
= true; /* This will be useful to know later. */
7706 if (as
->type
== AS_ASSUMED_SIZE
)
7707 as
->cp_was_assumed
= true;
7708 else if (as
->type
== AS_ASSUMED_SHAPE
)
7710 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
7717 /* Match the enum definition statement, here we are trying to match
7718 the first line of enum definition statement.
7719 Returns MATCH_YES if match is found. */
7722 gfc_match_enum (void)
7726 m
= gfc_match_eos ();
7730 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
7737 /* Returns an initializer whose value is one higher than the value of the
7738 LAST_INITIALIZER argument. If the argument is NULL, the
7739 initializers value will be set to zero. The initializer's kind
7740 will be set to gfc_c_int_kind.
7742 If -fshort-enums is given, the appropriate kind will be selected
7743 later after all enumerators have been parsed. A warning is issued
7744 here if an initializer exceeds gfc_c_int_kind. */
7747 enum_initializer (gfc_expr
*last_initializer
, locus where
)
7750 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
7752 mpz_init (result
->value
.integer
);
7754 if (last_initializer
!= NULL
)
7756 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
7757 result
->where
= last_initializer
->where
;
7759 if (gfc_check_integer_range (result
->value
.integer
,
7760 gfc_c_int_kind
) != ARITH_OK
)
7762 gfc_error ("Enumerator exceeds the C integer type at %C");
7768 /* Control comes here, if it's the very first enumerator and no
7769 initializer has been given. It will be initialized to zero. */
7770 mpz_set_si (result
->value
.integer
, 0);
7777 /* Match a variable name with an optional initializer. When this
7778 subroutine is called, a variable is expected to be parsed next.
7779 Depending on what is happening at the moment, updates either the
7780 symbol table or the current interface. */
7783 enumerator_decl (void)
7785 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7786 gfc_expr
*initializer
;
7787 gfc_array_spec
*as
= NULL
;
7795 old_locus
= gfc_current_locus
;
7797 /* When we get here, we've just matched a list of attributes and
7798 maybe a type and a double colon. The next thing we expect to see
7799 is the name of the symbol. */
7800 m
= gfc_match_name (name
);
7804 var_locus
= gfc_current_locus
;
7806 /* OK, we've successfully matched the declaration. Now put the
7807 symbol in the current namespace. If we fail to create the symbol,
7809 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
7815 /* The double colon must be present in order to have initializers.
7816 Otherwise the statement is ambiguous with an assignment statement. */
7819 if (gfc_match_char ('=') == MATCH_YES
)
7821 m
= gfc_match_init_expr (&initializer
);
7824 gfc_error ("Expected an initialization expression at %C");
7833 /* If we do not have an initializer, the initialization value of the
7834 previous enumerator (stored in last_initializer) is incremented
7835 by 1 and is used to initialize the current enumerator. */
7836 if (initializer
== NULL
)
7837 initializer
= enum_initializer (last_initializer
, old_locus
);
7839 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
7841 gfc_error ("ENUMERATOR %L not initialized with integer expression",
7847 /* Store this current initializer, for the next enumerator variable
7848 to be parsed. add_init_expr_to_sym() zeros initializer, so we
7849 use last_initializer below. */
7850 last_initializer
= initializer
;
7851 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
7853 /* Maintain enumerator history. */
7854 gfc_find_symbol (name
, NULL
, 0, &sym
);
7855 create_enum_history (sym
, last_initializer
);
7857 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7860 /* Free stuff up and return. */
7861 gfc_free_expr (initializer
);
7867 /* Match the enumerator definition statement. */
7870 gfc_match_enumerator_def (void)
7875 gfc_clear_ts (¤t_ts
);
7877 m
= gfc_match (" enumerator");
7881 m
= gfc_match (" :: ");
7882 if (m
== MATCH_ERROR
)
7885 colon_seen
= (m
== MATCH_YES
);
7887 if (gfc_current_state () != COMP_ENUM
)
7889 gfc_error ("ENUM definition statement expected before %C");
7890 gfc_free_enum_history ();
7894 (¤t_ts
)->type
= BT_INTEGER
;
7895 (¤t_ts
)->kind
= gfc_c_int_kind
;
7897 gfc_clear_attr (¤t_attr
);
7898 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
7907 m
= enumerator_decl ();
7908 if (m
== MATCH_ERROR
)
7910 gfc_free_enum_history ();
7916 if (gfc_match_eos () == MATCH_YES
)
7918 if (gfc_match_char (',') != MATCH_YES
)
7922 if (gfc_current_state () == COMP_ENUM
)
7924 gfc_free_enum_history ();
7925 gfc_error ("Syntax error in ENUMERATOR definition at %C");
7930 gfc_free_array_spec (current_as
);
7937 /* Match binding attributes. */
7940 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
7942 bool found_passing
= false;
7943 bool seen_ptr
= false;
7944 match m
= MATCH_YES
;
7946 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
7947 this case the defaults are in there. */
7948 ba
->access
= ACCESS_UNKNOWN
;
7949 ba
->pass_arg
= NULL
;
7950 ba
->pass_arg_num
= 0;
7952 ba
->non_overridable
= 0;
7956 /* If we find a comma, we believe there are binding attributes. */
7957 m
= gfc_match_char (',');
7963 /* Access specifier. */
7965 m
= gfc_match (" public");
7966 if (m
== MATCH_ERROR
)
7970 if (ba
->access
!= ACCESS_UNKNOWN
)
7972 gfc_error ("Duplicate access-specifier at %C");
7976 ba
->access
= ACCESS_PUBLIC
;
7980 m
= gfc_match (" private");
7981 if (m
== MATCH_ERROR
)
7985 if (ba
->access
!= ACCESS_UNKNOWN
)
7987 gfc_error ("Duplicate access-specifier at %C");
7991 ba
->access
= ACCESS_PRIVATE
;
7995 /* If inside GENERIC, the following is not allowed. */
8000 m
= gfc_match (" nopass");
8001 if (m
== MATCH_ERROR
)
8007 gfc_error ("Binding attributes already specify passing,"
8008 " illegal NOPASS at %C");
8012 found_passing
= true;
8017 /* PASS possibly including argument. */
8018 m
= gfc_match (" pass");
8019 if (m
== MATCH_ERROR
)
8023 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8027 gfc_error ("Binding attributes already specify passing,"
8028 " illegal PASS at %C");
8032 m
= gfc_match (" ( %n )", arg
);
8033 if (m
== MATCH_ERROR
)
8036 ba
->pass_arg
= gfc_get_string (arg
);
8037 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8039 found_passing
= true;
8047 m
= gfc_match (" pointer");
8048 if (m
== MATCH_ERROR
)
8054 gfc_error ("Duplicate POINTER attribute at %C");
8064 /* NON_OVERRIDABLE flag. */
8065 m
= gfc_match (" non_overridable");
8066 if (m
== MATCH_ERROR
)
8070 if (ba
->non_overridable
)
8072 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8076 ba
->non_overridable
= 1;
8080 /* DEFERRED flag. */
8081 m
= gfc_match (" deferred");
8082 if (m
== MATCH_ERROR
)
8088 gfc_error ("Duplicate DEFERRED at %C");
8099 /* Nothing matching found. */
8101 gfc_error ("Expected access-specifier at %C");
8103 gfc_error ("Expected binding attribute at %C");
8106 while (gfc_match_char (',') == MATCH_YES
);
8108 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8109 if (ba
->non_overridable
&& ba
->deferred
)
8111 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8118 if (ba
->access
== ACCESS_UNKNOWN
)
8119 ba
->access
= gfc_typebound_default_access
;
8121 if (ppc
&& !seen_ptr
)
8123 gfc_error ("POINTER attribute is required for procedure pointer component"
8135 /* Match a PROCEDURE specific binding inside a derived type. */
8138 match_procedure_in_type (void)
8140 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8141 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8142 char* target
= NULL
, *ifc
= NULL
;
8143 gfc_typebound_proc tb
;
8152 /* Check current state. */
8153 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8154 block
= gfc_state_stack
->previous
->sym
;
8157 /* Try to match PROCEDURE(interface). */
8158 if (gfc_match (" (") == MATCH_YES
)
8160 m
= gfc_match_name (target_buf
);
8161 if (m
== MATCH_ERROR
)
8165 gfc_error ("Interface-name expected after '(' at %C");
8169 if (gfc_match (" )") != MATCH_YES
)
8171 gfc_error ("')' expected at %C");
8178 /* Construct the data structure. */
8179 memset (&tb
, 0, sizeof (tb
));
8180 tb
.where
= gfc_current_locus
;
8182 /* Match binding attributes. */
8183 m
= match_binding_attributes (&tb
, false, false);
8184 if (m
== MATCH_ERROR
)
8186 seen_attrs
= (m
== MATCH_YES
);
8188 /* Check that attribute DEFERRED is given if an interface is specified. */
8189 if (tb
.deferred
&& !ifc
)
8191 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8194 if (ifc
&& !tb
.deferred
)
8196 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8200 /* Match the colons. */
8201 m
= gfc_match (" ::");
8202 if (m
== MATCH_ERROR
)
8204 seen_colons
= (m
== MATCH_YES
);
8205 if (seen_attrs
&& !seen_colons
)
8207 gfc_error ("Expected '::' after binding-attributes at %C");
8211 /* Match the binding names. */
8214 m
= gfc_match_name (name
);
8215 if (m
== MATCH_ERROR
)
8219 gfc_error ("Expected binding name at %C");
8223 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8226 /* Try to match the '=> target', if it's there. */
8228 m
= gfc_match (" =>");
8229 if (m
== MATCH_ERROR
)
8235 gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
8241 gfc_error ("'::' needed in PROCEDURE binding with explicit target"
8246 m
= gfc_match_name (target_buf
);
8247 if (m
== MATCH_ERROR
)
8251 gfc_error ("Expected binding target after '=>' at %C");
8254 target
= target_buf
;
8257 /* If no target was found, it has the same name as the binding. */
8261 /* Get the namespace to insert the symbols into. */
8262 ns
= block
->f2k_derived
;
8265 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8266 if (tb
.deferred
&& !block
->attr
.abstract
)
8268 gfc_error ("Type '%s' containing DEFERRED binding at %C "
8269 "is not ABSTRACT", block
->name
);
8273 /* See if we already have a binding with this name in the symtree which
8274 would be an error. If a GENERIC already targeted this binding, it may
8275 be already there but then typebound is still NULL. */
8276 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8277 if (stree
&& stree
->n
.tb
)
8279 gfc_error ("There is already a procedure with binding name '%s' for "
8280 "the derived type '%s' at %C", name
, block
->name
);
8284 /* Insert it and set attributes. */
8288 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8291 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8293 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8296 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8298 if (gfc_match_eos () == MATCH_YES
)
8300 if (gfc_match_char (',') != MATCH_YES
)
8305 gfc_error ("Syntax error in PROCEDURE statement at %C");
8310 /* Match a GENERIC procedure binding inside a derived type. */
8313 gfc_match_generic (void)
8315 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8316 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8318 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8319 gfc_typebound_proc
* tb
;
8321 interface_type op_type
;
8322 gfc_intrinsic_op op
;
8325 /* Check current state. */
8326 if (gfc_current_state () == COMP_DERIVED
)
8328 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8331 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8333 block
= gfc_state_stack
->previous
->sym
;
8334 ns
= block
->f2k_derived
;
8335 gcc_assert (block
&& ns
);
8337 memset (&tbattr
, 0, sizeof (tbattr
));
8338 tbattr
.where
= gfc_current_locus
;
8340 /* See if we get an access-specifier. */
8341 m
= match_binding_attributes (&tbattr
, true, false);
8342 if (m
== MATCH_ERROR
)
8345 /* Now the colons, those are required. */
8346 if (gfc_match (" ::") != MATCH_YES
)
8348 gfc_error ("Expected '::' at %C");
8352 /* Match the binding name; depending on type (operator / generic) format
8353 it for future error messages into bind_name. */
8355 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8356 if (m
== MATCH_ERROR
)
8360 gfc_error ("Expected generic name or operator descriptor at %C");
8366 case INTERFACE_GENERIC
:
8367 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8370 case INTERFACE_USER_OP
:
8371 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8374 case INTERFACE_INTRINSIC_OP
:
8375 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8376 gfc_op2string (op
));
8383 /* Match the required =>. */
8384 if (gfc_match (" =>") != MATCH_YES
)
8386 gfc_error ("Expected '=>' at %C");
8390 /* Try to find existing GENERIC binding with this name / for this operator;
8391 if there is something, check that it is another GENERIC and then extend
8392 it rather than building a new node. Otherwise, create it and put it
8393 at the right position. */
8397 case INTERFACE_USER_OP
:
8398 case INTERFACE_GENERIC
:
8400 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8403 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8415 case INTERFACE_INTRINSIC_OP
:
8425 if (!tb
->is_generic
)
8427 gcc_assert (op_type
== INTERFACE_GENERIC
);
8428 gfc_error ("There's already a non-generic procedure with binding name"
8429 " '%s' for the derived type '%s' at %C",
8430 bind_name
, block
->name
);
8434 if (tb
->access
!= tbattr
.access
)
8436 gfc_error ("Binding at %C must have the same access as already"
8437 " defined binding '%s'", bind_name
);
8443 tb
= gfc_get_typebound_proc (NULL
);
8444 tb
->where
= gfc_current_locus
;
8445 tb
->access
= tbattr
.access
;
8447 tb
->u
.generic
= NULL
;
8451 case INTERFACE_GENERIC
:
8452 case INTERFACE_USER_OP
:
8454 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8457 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8465 case INTERFACE_INTRINSIC_OP
:
8474 /* Now, match all following names as specific targets. */
8477 gfc_symtree
* target_st
;
8478 gfc_tbp_generic
* target
;
8480 m
= gfc_match_name (name
);
8481 if (m
== MATCH_ERROR
)
8485 gfc_error ("Expected specific binding name at %C");
8489 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8491 /* See if this is a duplicate specification. */
8492 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8493 if (target_st
== target
->specific_st
)
8495 gfc_error ("'%s' already defined as specific binding for the"
8496 " generic '%s' at %C", name
, bind_name
);
8500 target
= gfc_get_tbp_generic ();
8501 target
->specific_st
= target_st
;
8502 target
->specific
= NULL
;
8503 target
->next
= tb
->u
.generic
;
8504 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8505 || (op_type
== INTERFACE_INTRINSIC_OP
));
8506 tb
->u
.generic
= target
;
8508 while (gfc_match (" ,") == MATCH_YES
);
8510 /* Here should be the end. */
8511 if (gfc_match_eos () != MATCH_YES
)
8513 gfc_error ("Junk after GENERIC binding at %C");
8524 /* Match a FINAL declaration inside a derived type. */
8527 gfc_match_final_decl (void)
8529 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8532 gfc_namespace
* module_ns
;
8536 if (gfc_current_form
== FORM_FREE
)
8538 char c
= gfc_peek_ascii_char ();
8539 if (!gfc_is_whitespace (c
) && c
!= ':')
8543 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8545 if (gfc_current_form
== FORM_FIXED
)
8548 gfc_error ("FINAL declaration at %C must be inside a derived type "
8549 "CONTAINS section");
8553 block
= gfc_state_stack
->previous
->sym
;
8556 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8557 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8559 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8560 " specification part of a MODULE");
8564 module_ns
= gfc_current_ns
;
8565 gcc_assert (module_ns
);
8566 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8568 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8569 if (gfc_match (" ::") == MATCH_ERROR
)
8572 /* Match the sequence of procedure names. */
8579 if (first
&& gfc_match_eos () == MATCH_YES
)
8581 gfc_error ("Empty FINAL at %C");
8585 m
= gfc_match_name (name
);
8588 gfc_error ("Expected module procedure name at %C");
8591 else if (m
!= MATCH_YES
)
8594 if (gfc_match_eos () == MATCH_YES
)
8596 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8598 gfc_error ("Expected ',' at %C");
8602 if (gfc_get_symbol (name
, module_ns
, &sym
))
8604 gfc_error ("Unknown procedure name \"%s\" at %C", name
);
8608 /* Mark the symbol as module procedure. */
8609 if (sym
->attr
.proc
!= PROC_MODULE
8610 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8613 /* Check if we already have this symbol in the list, this is an error. */
8614 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8615 if (f
->proc_sym
== sym
)
8617 gfc_error ("'%s' at %C is already defined as FINAL procedure!",
8622 /* Add this symbol to the list of finalizers. */
8623 gcc_assert (block
->f2k_derived
);
8625 f
= XCNEW (gfc_finalizer
);
8627 f
->proc_tree
= NULL
;
8628 f
->where
= gfc_current_locus
;
8629 f
->next
= block
->f2k_derived
->finalizers
;
8630 block
->f2k_derived
->finalizers
= f
;
8640 const ext_attr_t ext_attr_list
[] = {
8641 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
8642 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
8643 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
8644 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
8645 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
8646 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
8647 { NULL
, EXT_ATTR_LAST
, NULL
}
8650 /* Match a !GCC$ ATTRIBUTES statement of the form:
8651 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
8652 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
8654 TODO: We should support all GCC attributes using the same syntax for
8655 the attribute list, i.e. the list in C
8656 __attributes(( attribute-list ))
8658 !GCC$ ATTRIBUTES attribute-list ::
8659 Cf. c-parser.c's c_parser_attributes; the data can then directly be
8662 As there is absolutely no risk of confusion, we should never return
8665 gfc_match_gcc_attributes (void)
8667 symbol_attribute attr
;
8668 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8673 gfc_clear_attr (&attr
);
8678 if (gfc_match_name (name
) != MATCH_YES
)
8681 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
8682 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
8685 if (id
== EXT_ATTR_LAST
)
8687 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
8691 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
8694 gfc_gobble_whitespace ();
8695 ch
= gfc_next_ascii_char ();
8698 /* This is the successful exit condition for the loop. */
8699 if (gfc_next_ascii_char () == ':')
8709 if (gfc_match_eos () == MATCH_YES
)
8714 m
= gfc_match_name (name
);
8718 if (find_special (name
, &sym
, true))
8721 sym
->attr
.ext_attr
|= attr
.ext_attr
;
8723 if (gfc_match_eos () == MATCH_YES
)
8726 if (gfc_match_char (',') != MATCH_YES
)
8733 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");