1 /* Declaration statement matcher
2 Copyright (C) 2002-2013 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"
31 /* Macros to access allocate memory for gfc_data_variable,
32 gfc_data_value and gfc_data. */
33 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
34 #define gfc_get_data_value() XCNEW (gfc_data_value)
35 #define gfc_get_data() XCNEW (gfc_data)
38 static gfc_try
set_binding_label (const char **, const char *, int);
41 /* This flag is set if an old-style length selector is matched
42 during a type-declaration statement. */
44 static int old_char_selector
;
46 /* When variables acquire types and attributes from a declaration
47 statement, they get them from the following static variables. The
48 first part of a declaration sets these variables and the second
49 part copies these into symbol structures. */
51 static gfc_typespec current_ts
;
53 static symbol_attribute current_attr
;
54 static gfc_array_spec
*current_as
;
55 static int colon_seen
;
57 /* The current binding label (if any). */
58 static const char* curr_binding_label
;
59 /* Need to know how many identifiers are on the current data declaration
60 line in case we're given the BIND(C) attribute with a NAME= specifier. */
61 static int num_idents_on_line
;
62 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
63 can supply a name if the curr_binding_label is nil and NAME= was not. */
64 static int has_name_equals
= 0;
66 /* Initializer of the previous enumerator. */
68 static gfc_expr
*last_initializer
;
70 /* History of all the enumerators is maintained, so that
71 kind values of all the enumerators could be updated depending
72 upon the maximum initialized value. */
74 typedef struct enumerator_history
77 gfc_expr
*initializer
;
78 struct enumerator_history
*next
;
82 /* Header of enum history chain. */
84 static enumerator_history
*enum_history
= NULL
;
86 /* Pointer of enum history node containing largest initializer. */
88 static enumerator_history
*max_enum
= NULL
;
90 /* gfc_new_block points to the symbol of a newly matched block. */
92 gfc_symbol
*gfc_new_block
;
94 bool gfc_matching_function
;
97 /********************* DATA statement subroutines *********************/
99 static bool in_match_data
= false;
102 gfc_in_match_data (void)
104 return in_match_data
;
108 set_in_match_data (bool set_value
)
110 in_match_data
= set_value
;
113 /* Free a gfc_data_variable structure and everything beneath it. */
116 free_variable (gfc_data_variable
*p
)
118 gfc_data_variable
*q
;
123 gfc_free_expr (p
->expr
);
124 gfc_free_iterator (&p
->iter
, 0);
125 free_variable (p
->list
);
131 /* Free a gfc_data_value structure and everything beneath it. */
134 free_value (gfc_data_value
*p
)
141 mpz_clear (p
->repeat
);
142 gfc_free_expr (p
->expr
);
148 /* Free a list of gfc_data structures. */
151 gfc_free_data (gfc_data
*p
)
158 free_variable (p
->var
);
159 free_value (p
->value
);
165 /* Free all data in a namespace. */
168 gfc_free_data_all (gfc_namespace
*ns
)
181 static match
var_element (gfc_data_variable
*);
183 /* Match a list of variables terminated by an iterator and a right
187 var_list (gfc_data_variable
*parent
)
189 gfc_data_variable
*tail
, var
;
192 m
= var_element (&var
);
193 if (m
== MATCH_ERROR
)
198 tail
= gfc_get_data_variable ();
205 if (gfc_match_char (',') != MATCH_YES
)
208 m
= gfc_match_iterator (&parent
->iter
, 1);
211 if (m
== MATCH_ERROR
)
214 m
= var_element (&var
);
215 if (m
== MATCH_ERROR
)
220 tail
->next
= gfc_get_data_variable ();
226 if (gfc_match_char (')') != MATCH_YES
)
231 gfc_syntax_error (ST_DATA
);
236 /* Match a single element in a data variable list, which can be a
237 variable-iterator list. */
240 var_element (gfc_data_variable
*new_var
)
245 memset (new_var
, 0, sizeof (gfc_data_variable
));
247 if (gfc_match_char ('(') == MATCH_YES
)
248 return var_list (new_var
);
250 m
= gfc_match_variable (&new_var
->expr
, 0);
254 sym
= new_var
->expr
->symtree
->n
.sym
;
256 /* Symbol should already have an associated type. */
257 if (gfc_check_symbol_typed (sym
, gfc_current_ns
,
258 false, gfc_current_locus
) == FAILURE
)
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",
273 sym
->name
) == FAILURE
)
276 if (gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
) == FAILURE
)
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) == FAILURE
)
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) == FAILURE
)
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
) == FAILURE
)
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 "
686 "parameter at %C") == FAILURE
)
694 m
= gfc_match_expr (expr
);
697 && gfc_expr_check_typed (*expr
, gfc_current_ns
, false) == FAILURE
)
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
,
749 "Old-style character length at %C") == FAILURE
)
751 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
755 if (gfc_match_char ('(') == MATCH_NO
)
758 m
= char_len_param_value (expr
, deferred
);
759 if (m
!= MATCH_YES
&& gfc_matching_function
)
765 if (m
== MATCH_ERROR
)
770 if (gfc_match_char (')') == MATCH_NO
)
772 gfc_free_expr (*expr
);
780 gfc_error ("Syntax error in character length specification at %C");
785 /* Special subroutine for finding a symbol. Check if the name is found
786 in the current name space. If not, and we're compiling a function or
787 subroutine and the parent compilation unit is an interface, then check
788 to see if the name we've been given is the name of the interface
789 (located in another namespace). */
792 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
798 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
801 *result
= st
? st
->n
.sym
: NULL
;
805 if (gfc_current_state () != COMP_SUBROUTINE
806 && gfc_current_state () != COMP_FUNCTION
)
809 s
= gfc_state_stack
->previous
;
813 if (s
->state
!= COMP_INTERFACE
)
816 goto end
; /* Nameless interface. */
818 if (strcmp (name
, s
->sym
->name
) == 0)
829 /* Special subroutine for getting a symbol node associated with a
830 procedure name, used in SUBROUTINE and FUNCTION statements. The
831 symbol is created in the parent using with symtree node in the
832 child unit pointing to the symbol. If the current namespace has no
833 parent, then the symbol is just created in the current unit. */
836 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
842 /* Module functions have to be left in their own namespace because
843 they have potentially (almost certainly!) already been referenced.
844 In this sense, they are rather like external functions. This is
845 fixed up in resolve.c(resolve_entries), where the symbol name-
846 space is set to point to the master function, so that the fake
847 result mechanism can work. */
848 if (module_fcn_entry
)
850 /* Present if entry is declared to be a module procedure. */
851 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
854 rc
= gfc_get_symbol (name
, NULL
, result
);
855 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
856 && (*result
)->ts
.type
== BT_UNKNOWN
857 && sym
->attr
.flavor
== FL_UNKNOWN
)
858 /* Pick up the typespec for the entry, if declared in the function
859 body. Note that this symbol is FL_UNKNOWN because it will
860 only have appeared in a type declaration. The local symtree
861 is set to point to the module symbol and a unique symtree
862 to the local version. This latter ensures a correct clearing
865 /* If the ENTRY proceeds its specification, we need to ensure
866 that this does not raise a "has no IMPLICIT type" error. */
867 if (sym
->ts
.type
== BT_UNKNOWN
)
868 sym
->attr
.untyped
= 1;
870 (*result
)->ts
= sym
->ts
;
872 /* Put the symbol in the procedure namespace so that, should
873 the ENTRY precede its specification, the specification
875 (*result
)->ns
= gfc_current_ns
;
877 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
879 st
= gfc_get_unique_symtree (gfc_current_ns
);
884 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
891 if (sym
&& !sym
->gfc_new
&& gfc_current_state () != COMP_INTERFACE
)
893 /* Trap another encompassed procedure with the same name. All
894 these conditions are necessary to avoid picking up an entry
895 whose name clashes with that of the encompassing procedure;
896 this is handled using gsymbols to register unique,globally
898 if (sym
->attr
.flavor
!= 0
899 && sym
->attr
.proc
!= 0
900 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
901 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
902 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
903 name
, &sym
->declared_at
);
905 /* Trap a procedure with a name the same as interface in the
906 encompassing scope. */
907 if (sym
->attr
.generic
!= 0
908 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
909 && !sym
->attr
.mod_proc
)
910 gfc_error_now ("Name '%s' at %C is already defined"
911 " as a generic interface at %L",
912 name
, &sym
->declared_at
);
914 /* Trap declarations of attributes in encompassing scope. The
915 signature for this is that ts.kind is set. Legitimate
916 references only set ts.type. */
917 if (sym
->ts
.kind
!= 0
918 && !sym
->attr
.implicit_type
919 && sym
->attr
.proc
== 0
920 && gfc_current_ns
->parent
!= NULL
921 && sym
->attr
.access
== 0
922 && !module_fcn_entry
)
923 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
924 "and must not have attributes declared at %L",
925 name
, &sym
->declared_at
);
928 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
931 /* Module function entries will already have a symtree in
932 the current namespace but will need one at module level. */
933 if (module_fcn_entry
)
935 /* Present if entry is declared to be a module procedure. */
936 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
938 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
941 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
946 /* See if the procedure should be a module procedure. */
948 if (((sym
->ns
->proc_name
!= NULL
949 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
950 && sym
->attr
.proc
!= PROC_MODULE
)
951 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
952 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
953 sym
->name
, NULL
) == FAILURE
)
960 /* Verify that the given symbol representing a parameter is C
961 interoperable, by checking to see if it was marked as such after
962 its declaration. If the given symbol is not interoperable, a
963 warning is reported, thus removing the need to return the status to
964 the calling function. The standard does not require the user use
965 one of the iso_c_binding named constants to declare an
966 interoperable parameter, but we can't be sure if the param is C
967 interop or not if the user doesn't. For example, integer(4) may be
968 legal Fortran, but doesn't have meaning in C. It may interop with
969 a number of the C types, which causes a problem because the
970 compiler can't know which one. This code is almost certainly not
971 portable, and the user will get what they deserve if the C type
972 across platforms isn't always interoperable with integer(4). If
973 the user had used something like integer(c_int) or integer(c_long),
974 the compiler could have automatically handled the varying sizes
978 gfc_verify_c_interop_param (gfc_symbol
*sym
)
980 int is_c_interop
= 0;
981 gfc_try retval
= SUCCESS
;
983 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
984 Don't repeat the checks here. */
985 if (sym
->attr
.implicit_type
)
988 /* For subroutines or functions that are passed to a BIND(C) procedure,
989 they're interoperable if they're BIND(C) and their params are all
991 if (sym
->attr
.flavor
== FL_PROCEDURE
)
993 if (sym
->attr
.is_bind_c
== 0)
995 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
996 "attribute to be C interoperable", sym
->name
,
997 &(sym
->declared_at
));
1003 if (sym
->attr
.is_c_interop
== 1)
1004 /* We've already checked this procedure; don't check it again. */
1007 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1012 /* See if we've stored a reference to a procedure that owns sym. */
1013 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1015 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1017 is_c_interop
= (gfc_verify_c_interop (&(sym
->ts
)) == SUCCESS
? 1 : 0);
1019 if (is_c_interop
!= 1)
1021 /* Make personalized messages to give better feedback. */
1022 if (sym
->ts
.type
== BT_DERIVED
)
1023 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1024 "BIND(C) procedure '%s' but is not C interoperable "
1025 "because derived type '%s' is not C interoperable",
1026 sym
->name
, &(sym
->declared_at
),
1027 sym
->ns
->proc_name
->name
,
1028 sym
->ts
.u
.derived
->name
);
1029 else if (sym
->ts
.type
== BT_CLASS
)
1030 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1031 "BIND(C) procedure '%s' but is not C interoperable "
1032 "because it is polymorphic",
1033 sym
->name
, &(sym
->declared_at
),
1034 sym
->ns
->proc_name
->name
);
1035 else if (gfc_option
.warn_c_binding_type
)
1036 gfc_warning ("Variable '%s' at %L is a dummy argument of the "
1037 "BIND(C) procedure '%s' but may not be C "
1039 sym
->name
, &(sym
->declared_at
),
1040 sym
->ns
->proc_name
->name
);
1043 /* Character strings are only C interoperable if they have a
1045 if (sym
->ts
.type
== BT_CHARACTER
)
1047 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1048 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1049 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1051 gfc_error ("Character argument '%s' at %L "
1052 "must be length 1 because "
1053 "procedure '%s' is BIND(C)",
1054 sym
->name
, &sym
->declared_at
,
1055 sym
->ns
->proc_name
->name
);
1060 /* We have to make sure that any param to a bind(c) routine does
1061 not have the allocatable, pointer, or optional attributes,
1062 according to J3/04-007, section 5.1. */
1063 if (sym
->attr
.allocatable
== 1)
1065 gfc_error ("Variable '%s' at %L cannot have the "
1066 "ALLOCATABLE attribute because procedure '%s'"
1067 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
1068 sym
->ns
->proc_name
->name
);
1072 if (sym
->attr
.pointer
== 1)
1074 gfc_error ("Variable '%s' at %L cannot have the "
1075 "POINTER attribute because procedure '%s'"
1076 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
1077 sym
->ns
->proc_name
->name
);
1081 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1083 gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
1084 "and the VALUE attribute because procedure '%s' "
1085 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1086 sym
->ns
->proc_name
->name
);
1089 else if (sym
->attr
.optional
== 1
1090 && gfc_notify_std (GFC_STD_F2008_TS
, "Variable '%s' "
1091 "at %L with OPTIONAL attribute in "
1092 "procedure '%s' which is BIND(C)",
1093 sym
->name
, &(sym
->declared_at
),
1094 sym
->ns
->proc_name
->name
)
1098 /* Make sure that if it has the dimension attribute, that it is
1099 either assumed size or explicit shape. Deferred shape is already
1100 covered by the pointer/allocatable attribute. */
1101 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1102 && gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array '%s' "
1103 "at %L as dummy argument to the BIND(C) "
1104 "procedure '%s' at %L", sym
->name
,
1105 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
1106 &(sym
->ns
->proc_name
->declared_at
)) == FAILURE
)
1116 /* Function called by variable_decl() that adds a name to the symbol table. */
1119 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1120 gfc_array_spec
**as
, locus
*var_locus
)
1122 symbol_attribute attr
;
1125 if (gfc_get_symbol (name
, NULL
, &sym
))
1128 /* Start updating the symbol table. Add basic type attribute if present. */
1129 if (current_ts
.type
!= BT_UNKNOWN
1130 && (sym
->attr
.implicit_type
== 0
1131 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1132 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
1135 if (sym
->ts
.type
== BT_CHARACTER
)
1138 sym
->ts
.deferred
= cl_deferred
;
1141 /* Add dimension attribute if present. */
1142 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
1146 /* Add attribute to symbol. The copy is so that we can reset the
1147 dimension attribute. */
1148 attr
= current_attr
;
1150 attr
.codimension
= 0;
1152 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
1155 /* Finish any work that may need to be done for the binding label,
1156 if it's a bind(c). The bind(c) attr is found before the symbol
1157 is made, and before the symbol name (for data decls), so the
1158 current_ts is holding the binding label, or nothing if the
1159 name= attr wasn't given. Therefore, test here if we're dealing
1160 with a bind(c) and make sure the binding label is set correctly. */
1161 if (sym
->attr
.is_bind_c
== 1)
1163 if (!sym
->binding_label
)
1165 /* Set the binding label and verify that if a NAME= was specified
1166 then only one identifier was in the entity-decl-list. */
1167 if (set_binding_label (&sym
->binding_label
, sym
->name
,
1168 num_idents_on_line
) == FAILURE
)
1173 /* See if we know we're in a common block, and if it's a bind(c)
1174 common then we need to make sure we're an interoperable type. */
1175 if (sym
->attr
.in_common
== 1)
1177 /* Test the common block object. */
1178 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1179 && sym
->ts
.is_c_interop
!= 1)
1181 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1182 "must be declared with a C interoperable "
1183 "kind since common block '%s' is BIND(C)",
1184 sym
->name
, sym
->common_block
->name
,
1185 sym
->common_block
->name
);
1190 sym
->attr
.implied_index
= 0;
1192 if (sym
->ts
.type
== BT_CLASS
)
1193 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
, false);
1199 /* Set character constant to the given length. The constant will be padded or
1200 truncated. If we're inside an array constructor without a typespec, we
1201 additionally check that all elements have the same length; check_len -1
1202 means no checking. */
1205 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1210 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1211 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1213 slen
= expr
->value
.character
.length
;
1216 s
= gfc_get_wide_string (len
+ 1);
1217 memcpy (s
, expr
->value
.character
.string
,
1218 MIN (len
, slen
) * sizeof (gfc_char_t
));
1220 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1222 if (gfc_option
.warn_character_truncation
&& slen
> len
)
1223 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1224 "(%d/%d)", &expr
->where
, slen
, len
);
1226 /* Apply the standard by 'hand' otherwise it gets cleared for
1228 if (check_len
!= -1 && slen
!= check_len
1229 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1230 gfc_error_now ("The CHARACTER elements of the array constructor "
1231 "at %L must have the same length (%d/%d)",
1232 &expr
->where
, slen
, check_len
);
1235 free (expr
->value
.character
.string
);
1236 expr
->value
.character
.string
= s
;
1237 expr
->value
.character
.length
= len
;
1242 /* Function to create and update the enumerator history
1243 using the information passed as arguments.
1244 Pointer "max_enum" is also updated, to point to
1245 enum history node containing largest initializer.
1247 SYM points to the symbol node of enumerator.
1248 INIT points to its enumerator value. */
1251 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1253 enumerator_history
*new_enum_history
;
1254 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1256 new_enum_history
= XCNEW (enumerator_history
);
1258 new_enum_history
->sym
= sym
;
1259 new_enum_history
->initializer
= init
;
1260 new_enum_history
->next
= NULL
;
1262 if (enum_history
== NULL
)
1264 enum_history
= new_enum_history
;
1265 max_enum
= enum_history
;
1269 new_enum_history
->next
= enum_history
;
1270 enum_history
= new_enum_history
;
1272 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1273 new_enum_history
->initializer
->value
.integer
) < 0)
1274 max_enum
= new_enum_history
;
1279 /* Function to free enum kind history. */
1282 gfc_free_enum_history (void)
1284 enumerator_history
*current
= enum_history
;
1285 enumerator_history
*next
;
1287 while (current
!= NULL
)
1289 next
= current
->next
;
1294 enum_history
= NULL
;
1298 /* Function called by variable_decl() that adds an initialization
1299 expression to a symbol. */
1302 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1304 symbol_attribute attr
;
1309 if (find_special (name
, &sym
, false))
1314 /* If this symbol is confirming an implicit parameter type,
1315 then an initialization expression is not allowed. */
1316 if (attr
.flavor
== FL_PARAMETER
1317 && sym
->value
!= NULL
1320 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1327 /* An initializer is required for PARAMETER declarations. */
1328 if (attr
.flavor
== FL_PARAMETER
)
1330 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1336 /* If a variable appears in a DATA block, it cannot have an
1340 gfc_error ("Variable '%s' at %C with an initializer already "
1341 "appears in a DATA statement", sym
->name
);
1345 /* Check if the assignment can happen. This has to be put off
1346 until later for derived type variables and procedure pointers. */
1347 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1348 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1349 && !sym
->attr
.proc_pointer
1350 && gfc_check_assign_symbol (sym
, NULL
, init
) == FAILURE
)
1353 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1354 && init
->ts
.type
== BT_CHARACTER
)
1356 /* Update symbol character length according initializer. */
1357 if (gfc_check_assign_symbol (sym
, NULL
, init
) == FAILURE
)
1360 if (sym
->ts
.u
.cl
->length
== NULL
)
1363 /* If there are multiple CHARACTER variables declared on the
1364 same line, we don't want them to share the same length. */
1365 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1367 if (sym
->attr
.flavor
== FL_PARAMETER
)
1369 if (init
->expr_type
== EXPR_CONSTANT
)
1371 clen
= init
->value
.character
.length
;
1372 sym
->ts
.u
.cl
->length
1373 = gfc_get_int_expr (gfc_default_integer_kind
,
1376 else if (init
->expr_type
== EXPR_ARRAY
)
1379 c
= gfc_constructor_first (init
->value
.constructor
);
1380 clen
= c
->expr
->value
.character
.length
;
1381 sym
->ts
.u
.cl
->length
1382 = gfc_get_int_expr (gfc_default_integer_kind
,
1385 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1386 sym
->ts
.u
.cl
->length
=
1387 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1390 /* Update initializer character length according symbol. */
1391 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1393 int len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1395 if (init
->expr_type
== EXPR_CONSTANT
)
1396 gfc_set_constant_character_len (len
, init
, -1);
1397 else if (init
->expr_type
== EXPR_ARRAY
)
1401 /* Build a new charlen to prevent simplification from
1402 deleting the length before it is resolved. */
1403 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1404 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1406 for (c
= gfc_constructor_first (init
->value
.constructor
);
1407 c
; c
= gfc_constructor_next (c
))
1408 gfc_set_constant_character_len (len
, c
->expr
, -1);
1413 /* If sym is implied-shape, set its upper bounds from init. */
1414 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1415 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1419 if (init
->rank
== 0)
1421 gfc_error ("Can't initialize implied-shape array at %L"
1422 " with scalar", &sym
->declared_at
);
1425 gcc_assert (sym
->as
->rank
== init
->rank
);
1427 /* Shape should be present, we get an initialization expression. */
1428 gcc_assert (init
->shape
);
1430 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1436 lower
= sym
->as
->lower
[dim
];
1437 if (lower
->expr_type
!= EXPR_CONSTANT
)
1439 gfc_error ("Non-constant lower bound in implied-shape"
1440 " declaration at %L", &lower
->where
);
1444 /* All dimensions must be without upper bound. */
1445 gcc_assert (!sym
->as
->upper
[dim
]);
1448 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1449 mpz_add (e
->value
.integer
,
1450 lower
->value
.integer
, init
->shape
[dim
]);
1451 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1452 sym
->as
->upper
[dim
] = e
;
1455 sym
->as
->type
= AS_EXPLICIT
;
1458 /* Need to check if the expression we initialized this
1459 to was one of the iso_c_binding named constants. If so,
1460 and we're a parameter (constant), let it be iso_c.
1462 integer(c_int), parameter :: my_int = c_int
1463 integer(my_int) :: my_int_2
1464 If we mark my_int as iso_c (since we can see it's value
1465 is equal to one of the named constants), then my_int_2
1466 will be considered C interoperable. */
1467 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1469 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1470 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1471 /* attr bits needed for module files. */
1472 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1473 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1474 if (init
->ts
.is_iso_c
)
1475 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1478 /* Add initializer. Make sure we keep the ranks sane. */
1479 if (sym
->attr
.dimension
&& init
->rank
== 0)
1484 if (sym
->attr
.flavor
== FL_PARAMETER
1485 && init
->expr_type
== EXPR_CONSTANT
1486 && spec_size (sym
->as
, &size
) == SUCCESS
1487 && mpz_cmp_si (size
, 0) > 0)
1489 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1491 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1492 gfc_constructor_append_expr (&array
->value
.constructor
,
1495 : gfc_copy_expr (init
),
1498 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1499 for (n
= 0; n
< sym
->as
->rank
; n
++)
1500 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1505 init
->rank
= sym
->as
->rank
;
1509 if (sym
->attr
.save
== SAVE_NONE
)
1510 sym
->attr
.save
= SAVE_IMPLICIT
;
1518 /* Function called by variable_decl() that adds a name to a structure
1522 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1523 gfc_array_spec
**as
)
1526 gfc_try t
= SUCCESS
;
1528 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1529 constructing, it must have the pointer attribute. */
1530 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1531 && current_ts
.u
.derived
== gfc_current_block ()
1532 && current_attr
.pointer
== 0)
1534 gfc_error ("Component at %C must have the POINTER attribute");
1538 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1540 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1542 gfc_error ("Array component of structure at %C must have explicit "
1543 "or deferred shape");
1548 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
1552 if (c
->ts
.type
== BT_CHARACTER
)
1554 c
->attr
= current_attr
;
1556 c
->initializer
= *init
;
1563 c
->attr
.codimension
= 1;
1565 c
->attr
.dimension
= 1;
1569 /* Should this ever get more complicated, combine with similar section
1570 in add_init_expr_to_sym into a separate function. */
1571 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1573 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1577 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1578 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1579 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1581 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1583 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1584 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1585 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1586 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1588 gfc_constructor
*ctor
;
1589 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1594 bool has_ts
= (c
->initializer
->ts
.u
.cl
1595 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1597 /* Remember the length of the first element for checking
1598 that all elements *in the constructor* have the same
1599 length. This need not be the length of the LHS! */
1600 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1601 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1602 first_len
= ctor
->expr
->value
.character
.length
;
1604 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1605 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1607 gfc_set_constant_character_len (len
, ctor
->expr
,
1608 has_ts
? -1 : first_len
);
1609 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1615 /* Check array components. */
1616 if (!c
->attr
.dimension
)
1619 if (c
->attr
.pointer
)
1621 if (c
->as
->type
!= AS_DEFERRED
)
1623 gfc_error ("Pointer array component of structure at %C must have a "
1628 else if (c
->attr
.allocatable
)
1630 if (c
->as
->type
!= AS_DEFERRED
)
1632 gfc_error ("Allocatable component of structure at %C must have a "
1639 if (c
->as
->type
!= AS_EXPLICIT
)
1641 gfc_error ("Array component of structure at %C must have an "
1648 if (c
->ts
.type
== BT_CLASS
)
1650 bool delayed
= (gfc_state_stack
->sym
== c
->ts
.u
.derived
)
1651 || (!c
->ts
.u
.derived
->components
1652 && !c
->ts
.u
.derived
->attr
.zero_comp
);
1653 gfc_try t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
, delayed
);
1663 /* Match a 'NULL()', and possibly take care of some side effects. */
1666 gfc_match_null (gfc_expr
**result
)
1669 match m
, m2
= MATCH_NO
;
1671 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1677 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1679 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1682 old_loc
= gfc_current_locus
;
1683 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1686 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1690 gfc_current_locus
= old_loc
;
1695 /* The NULL symbol now has to be/become an intrinsic function. */
1696 if (gfc_get_symbol ("null", NULL
, &sym
))
1698 gfc_error ("NULL() initialization at %C is ambiguous");
1702 gfc_intrinsic_symbol (sym
);
1704 if (sym
->attr
.proc
!= PROC_INTRINSIC
1705 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1706 sym
->name
, NULL
) == FAILURE
1707 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1710 *result
= gfc_get_null_expr (&gfc_current_locus
);
1712 /* Invalid per F2008, C512. */
1713 if (m2
== MATCH_YES
)
1715 gfc_error ("NULL() initialization at %C may not have MOLD");
1723 /* Match the initialization expr for a data pointer or procedure pointer. */
1726 match_pointer_init (gfc_expr
**init
, int procptr
)
1730 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1732 gfc_error ("Initialization of pointer at %C is not allowed in "
1733 "a PURE procedure");
1736 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1738 /* Match NULL() initialization. */
1739 m
= gfc_match_null (init
);
1743 /* Match non-NULL initialization. */
1744 gfc_matching_ptr_assignment
= !procptr
;
1745 gfc_matching_procptr_assignment
= procptr
;
1746 m
= gfc_match_rvalue (init
);
1747 gfc_matching_ptr_assignment
= 0;
1748 gfc_matching_procptr_assignment
= 0;
1749 if (m
== MATCH_ERROR
)
1751 else if (m
== MATCH_NO
)
1753 gfc_error ("Error in pointer initialization at %C");
1758 gfc_resolve_expr (*init
);
1760 if (gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1761 "initialization at %C") == FAILURE
)
1769 check_function_name (char *name
)
1771 /* In functions that have a RESULT variable defined, the function name always
1772 refers to function calls. Therefore, the name is not allowed to appear in
1773 specification statements. When checking this, be careful about
1774 'hidden' procedure pointer results ('ppr@'). */
1776 if (gfc_current_state () == COMP_FUNCTION
)
1778 gfc_symbol
*block
= gfc_current_block ();
1779 if (block
&& block
->result
&& block
->result
!= block
1780 && strcmp (block
->result
->name
, "ppr@") != 0
1781 && strcmp (block
->name
, name
) == 0)
1783 gfc_error ("Function name '%s' not allowed at %C", name
);
1792 /* Match a variable name with an optional initializer. When this
1793 subroutine is called, a variable is expected to be parsed next.
1794 Depending on what is happening at the moment, updates either the
1795 symbol table or the current interface. */
1798 variable_decl (int elem
)
1800 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1801 gfc_expr
*initializer
, *char_len
;
1803 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1815 /* When we get here, we've just matched a list of attributes and
1816 maybe a type and a double colon. The next thing we expect to see
1817 is the name of the symbol. */
1818 m
= gfc_match_name (name
);
1822 var_locus
= gfc_current_locus
;
1824 /* Now we could see the optional array spec. or character length. */
1825 m
= gfc_match_array_spec (&as
, true, true);
1826 if (m
== MATCH_ERROR
)
1830 as
= gfc_copy_array_spec (current_as
);
1832 && merge_array_spec (current_as
, as
, true) == FAILURE
)
1838 if (gfc_option
.flag_cray_pointer
)
1839 cp_as
= gfc_copy_array_spec (as
);
1841 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1842 determine (and check) whether it can be implied-shape. If it
1843 was parsed as assumed-size, change it because PARAMETERs can not
1847 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1850 gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
1855 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1856 && current_attr
.flavor
== FL_PARAMETER
)
1857 as
->type
= AS_IMPLIED_SHAPE
;
1859 if (as
->type
== AS_IMPLIED_SHAPE
1860 && gfc_notify_std (GFC_STD_F2008
,
1861 "Implied-shape array at %L",
1862 &var_locus
) == FAILURE
)
1871 cl_deferred
= false;
1873 if (current_ts
.type
== BT_CHARACTER
)
1875 switch (match_char_length (&char_len
, &cl_deferred
, false))
1878 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1880 cl
->length
= char_len
;
1883 /* Non-constant lengths need to be copied after the first
1884 element. Also copy assumed lengths. */
1887 && (current_ts
.u
.cl
->length
== NULL
1888 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1890 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1891 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1894 cl
= current_ts
.u
.cl
;
1896 cl_deferred
= current_ts
.deferred
;
1905 /* If this symbol has already shown up in a Cray Pointer declaration,
1906 then we want to set the type & bail out. */
1907 if (gfc_option
.flag_cray_pointer
)
1909 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1910 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1912 sym
->ts
.type
= current_ts
.type
;
1913 sym
->ts
.kind
= current_ts
.kind
;
1915 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1916 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1917 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1920 /* Check to see if we have an array specification. */
1923 if (sym
->as
!= NULL
)
1925 gfc_error ("Duplicate array spec for Cray pointee at %C");
1926 gfc_free_array_spec (cp_as
);
1932 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1933 gfc_internal_error ("Couldn't set pointee array spec.");
1935 /* Fix the array spec. */
1936 m
= gfc_mod_pointee_as (sym
->as
);
1937 if (m
== MATCH_ERROR
)
1945 gfc_free_array_spec (cp_as
);
1949 /* Procedure pointer as function result. */
1950 if (gfc_current_state () == COMP_FUNCTION
1951 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
1952 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
1953 strcpy (name
, "ppr@");
1955 if (gfc_current_state () == COMP_FUNCTION
1956 && strcmp (name
, gfc_current_block ()->name
) == 0
1957 && gfc_current_block ()->result
1958 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
1959 strcpy (name
, "ppr@");
1961 /* OK, we've successfully matched the declaration. Now put the
1962 symbol in the current namespace, because it might be used in the
1963 optional initialization expression for this symbol, e.g. this is
1966 integer, parameter :: i = huge(i)
1968 This is only true for parameters or variables of a basic type.
1969 For components of derived types, it is not true, so we don't
1970 create a symbol for those yet. If we fail to create the symbol,
1972 if (gfc_current_state () != COMP_DERIVED
1973 && build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
) == FAILURE
)
1979 if (check_function_name (name
) == FAILURE
)
1985 /* We allow old-style initializations of the form
1986 integer i /2/, j(4) /3*3, 1/
1987 (if no colon has been seen). These are different from data
1988 statements in that initializers are only allowed to apply to the
1989 variable immediately preceding, i.e.
1991 is not allowed. Therefore we have to do some work manually, that
1992 could otherwise be left to the matchers for DATA statements. */
1994 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1996 if (gfc_notify_std (GFC_STD_GNU
, "Old-style "
1997 "initialization at %C") == FAILURE
)
1999 else if (gfc_current_state () == COMP_DERIVED
)
2001 gfc_error ("Invalid old style initialization for derived type "
2007 return match_old_style_init (name
);
2010 /* The double colon must be present in order to have initializers.
2011 Otherwise the statement is ambiguous with an assignment statement. */
2014 if (gfc_match (" =>") == MATCH_YES
)
2016 if (!current_attr
.pointer
)
2018 gfc_error ("Initialization at %C isn't for a pointer variable");
2023 m
= match_pointer_init (&initializer
, 0);
2027 else if (gfc_match_char ('=') == MATCH_YES
)
2029 if (current_attr
.pointer
)
2031 gfc_error ("Pointer initialization at %C requires '=>', "
2037 m
= gfc_match_init_expr (&initializer
);
2040 gfc_error ("Expected an initialization expression at %C");
2044 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2045 && gfc_state_stack
->state
!= COMP_DERIVED
)
2047 gfc_error ("Initialization of variable at %C is not allowed in "
2048 "a PURE procedure");
2052 if (current_attr
.flavor
!= FL_PARAMETER
2053 && gfc_state_stack
->state
!= COMP_DERIVED
)
2054 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2061 if (initializer
!= NULL
&& current_attr
.allocatable
2062 && gfc_current_state () == COMP_DERIVED
)
2064 gfc_error ("Initialization of allocatable component at %C is not "
2070 /* Add the initializer. Note that it is fine if initializer is
2071 NULL here, because we sometimes also need to check if a
2072 declaration *must* have an initialization expression. */
2073 if (gfc_current_state () != COMP_DERIVED
)
2074 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2077 if (current_ts
.type
== BT_DERIVED
2078 && !current_attr
.pointer
&& !initializer
)
2079 initializer
= gfc_default_initializer (¤t_ts
);
2080 t
= build_struct (name
, cl
, &initializer
, &as
);
2083 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
2086 /* Free stuff up and return. */
2087 gfc_free_expr (initializer
);
2088 gfc_free_array_spec (as
);
2094 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2095 This assumes that the byte size is equal to the kind number for
2096 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2099 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2104 if (gfc_match_char ('*') != MATCH_YES
)
2107 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2111 original_kind
= ts
->kind
;
2113 /* Massage the kind numbers for complex types. */
2114 if (ts
->type
== BT_COMPLEX
)
2118 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2119 gfc_basic_typename (ts
->type
), original_kind
);
2126 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2129 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2133 if (gfc_option
.flag_real4_kind
== 8)
2135 if (gfc_option
.flag_real4_kind
== 10)
2137 if (gfc_option
.flag_real4_kind
== 16)
2143 if (gfc_option
.flag_real8_kind
== 4)
2145 if (gfc_option
.flag_real8_kind
== 10)
2147 if (gfc_option
.flag_real8_kind
== 16)
2152 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2154 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2155 gfc_basic_typename (ts
->type
), original_kind
);
2159 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
2160 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
2167 /* Match a kind specification. Since kinds are generally optional, we
2168 usually return MATCH_NO if something goes wrong. If a "kind="
2169 string is found, then we know we have an error. */
2172 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2184 where
= loc
= gfc_current_locus
;
2189 if (gfc_match_char ('(') == MATCH_NO
)
2192 /* Also gobbles optional text. */
2193 if (gfc_match (" kind = ") == MATCH_YES
)
2196 loc
= gfc_current_locus
;
2199 n
= gfc_match_init_expr (&e
);
2203 if (gfc_matching_function
)
2205 /* The function kind expression might include use associated or
2206 imported parameters and try again after the specification
2208 if (gfc_match_char (')') != MATCH_YES
)
2210 gfc_error ("Missing right parenthesis at %C");
2216 gfc_undo_symbols ();
2221 /* ....or else, the match is real. */
2223 gfc_error ("Expected initialization expression at %C");
2231 gfc_error ("Expected scalar initialization expression at %C");
2236 msg
= gfc_extract_int (e
, &ts
->kind
);
2245 /* Before throwing away the expression, let's see if we had a
2246 C interoperable kind (and store the fact). */
2247 if (e
->ts
.is_c_interop
== 1)
2249 /* Mark this as C interoperable if being declared with one
2250 of the named constants from iso_c_binding. */
2251 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2252 ts
->f90_type
= e
->ts
.f90_type
;
2258 /* Ignore errors to this point, if we've gotten here. This means
2259 we ignore the m=MATCH_ERROR from above. */
2260 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2262 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2263 gfc_basic_typename (ts
->type
));
2264 gfc_current_locus
= where
;
2268 /* Warn if, e.g., c_int is used for a REAL variable, but not
2269 if, e.g., c_double is used for COMPLEX as the standard
2270 explicitly says that the kind type parameter for complex and real
2271 variable is the same, i.e. c_float == c_float_complex. */
2272 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2273 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2274 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2275 gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2276 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2277 gfc_basic_typename (ts
->type
));
2279 gfc_gobble_whitespace ();
2280 if ((c
= gfc_next_ascii_char ()) != ')'
2281 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2283 if (ts
->type
== BT_CHARACTER
)
2284 gfc_error ("Missing right parenthesis or comma at %C");
2286 gfc_error ("Missing right parenthesis at %C");
2290 /* All tests passed. */
2293 if(m
== MATCH_ERROR
)
2294 gfc_current_locus
= where
;
2296 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2299 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2303 if (gfc_option
.flag_real4_kind
== 8)
2305 if (gfc_option
.flag_real4_kind
== 10)
2307 if (gfc_option
.flag_real4_kind
== 16)
2313 if (gfc_option
.flag_real8_kind
== 4)
2315 if (gfc_option
.flag_real8_kind
== 10)
2317 if (gfc_option
.flag_real8_kind
== 16)
2322 /* Return what we know from the test(s). */
2327 gfc_current_locus
= where
;
2333 match_char_kind (int * kind
, int * is_iso_c
)
2342 where
= gfc_current_locus
;
2344 n
= gfc_match_init_expr (&e
);
2346 if (n
!= MATCH_YES
&& gfc_matching_function
)
2348 /* The expression might include use-associated or imported
2349 parameters and try again after the specification
2352 gfc_undo_symbols ();
2357 gfc_error ("Expected initialization expression at %C");
2363 gfc_error ("Expected scalar initialization expression at %C");
2368 msg
= gfc_extract_int (e
, kind
);
2369 *is_iso_c
= e
->ts
.is_iso_c
;
2379 /* Ignore errors to this point, if we've gotten here. This means
2380 we ignore the m=MATCH_ERROR from above. */
2381 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2383 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2387 /* All tests passed. */
2390 if (m
== MATCH_ERROR
)
2391 gfc_current_locus
= where
;
2393 /* Return what we know from the test(s). */
2398 gfc_current_locus
= where
;
2403 /* Match the various kind/length specifications in a CHARACTER
2404 declaration. We don't return MATCH_NO. */
2407 gfc_match_char_spec (gfc_typespec
*ts
)
2409 int kind
, seen_length
, is_iso_c
;
2421 /* Try the old-style specification first. */
2422 old_char_selector
= 0;
2424 m
= match_char_length (&len
, &deferred
, true);
2428 old_char_selector
= 1;
2433 m
= gfc_match_char ('(');
2436 m
= MATCH_YES
; /* Character without length is a single char. */
2440 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2441 if (gfc_match (" kind =") == MATCH_YES
)
2443 m
= match_char_kind (&kind
, &is_iso_c
);
2445 if (m
== MATCH_ERROR
)
2450 if (gfc_match (" , len =") == MATCH_NO
)
2453 m
= char_len_param_value (&len
, &deferred
);
2456 if (m
== MATCH_ERROR
)
2463 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2464 if (gfc_match (" len =") == MATCH_YES
)
2466 m
= char_len_param_value (&len
, &deferred
);
2469 if (m
== MATCH_ERROR
)
2473 if (gfc_match_char (')') == MATCH_YES
)
2476 if (gfc_match (" , kind =") != MATCH_YES
)
2479 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2485 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2486 m
= char_len_param_value (&len
, &deferred
);
2489 if (m
== MATCH_ERROR
)
2493 m
= gfc_match_char (')');
2497 if (gfc_match_char (',') != MATCH_YES
)
2500 gfc_match (" kind ="); /* Gobble optional text. */
2502 m
= match_char_kind (&kind
, &is_iso_c
);
2503 if (m
== MATCH_ERROR
)
2509 /* Require a right-paren at this point. */
2510 m
= gfc_match_char (')');
2515 gfc_error ("Syntax error in CHARACTER declaration at %C");
2517 gfc_free_expr (len
);
2521 /* Deal with character functions after USE and IMPORT statements. */
2522 if (gfc_matching_function
)
2524 gfc_free_expr (len
);
2525 gfc_undo_symbols ();
2531 gfc_free_expr (len
);
2535 /* Do some final massaging of the length values. */
2536 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2538 if (seen_length
== 0)
2539 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2544 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2545 ts
->deferred
= deferred
;
2547 /* We have to know if it was a C interoperable kind so we can
2548 do accurate type checking of bind(c) procs, etc. */
2550 /* Mark this as C interoperable if being declared with one
2551 of the named constants from iso_c_binding. */
2552 ts
->is_c_interop
= is_iso_c
;
2553 else if (len
!= NULL
)
2554 /* Here, we might have parsed something such as: character(c_char)
2555 In this case, the parsing code above grabs the c_char when
2556 looking for the length (line 1690, roughly). it's the last
2557 testcase for parsing the kind params of a character variable.
2558 However, it's not actually the length. this seems like it
2560 To see if the user used a C interop kind, test the expr
2561 of the so called length, and see if it's C interoperable. */
2562 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2568 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2569 structure to the matched specification. This is necessary for FUNCTION and
2570 IMPLICIT statements.
2572 If implicit_flag is nonzero, then we don't check for the optional
2573 kind specification. Not doing so is needed for matching an IMPLICIT
2574 statement correctly. */
2577 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2579 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2580 gfc_symbol
*sym
, *dt_sym
;
2583 bool seen_deferred_kind
, matched_type
;
2584 const char *dt_name
;
2586 /* A belt and braces check that the typespec is correctly being treated
2587 as a deferred characteristic association. */
2588 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2589 && (gfc_current_block ()->result
->ts
.kind
== -1)
2590 && (ts
->kind
== -1);
2592 if (seen_deferred_kind
)
2595 /* Clear the current binding label, in case one is given. */
2596 curr_binding_label
= NULL
;
2598 if (gfc_match (" byte") == MATCH_YES
)
2600 if (gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C")
2604 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2606 gfc_error ("BYTE type used at %C "
2607 "is not available on the target machine");
2611 ts
->type
= BT_INTEGER
;
2617 m
= gfc_match (" type (");
2618 matched_type
= (m
== MATCH_YES
);
2621 gfc_gobble_whitespace ();
2622 if (gfc_peek_ascii_char () == '*')
2624 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2626 if (gfc_current_state () == COMP_DERIVED
)
2628 gfc_error ("Assumed type at %C is not allowed for components");
2631 if (gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2632 "at %C") == FAILURE
)
2634 ts
->type
= BT_ASSUMED
;
2638 m
= gfc_match ("%n", name
);
2639 matched_type
= (m
== MATCH_YES
);
2642 if ((matched_type
&& strcmp ("integer", name
) == 0)
2643 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2645 ts
->type
= BT_INTEGER
;
2646 ts
->kind
= gfc_default_integer_kind
;
2650 if ((matched_type
&& strcmp ("character", name
) == 0)
2651 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2654 && gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2655 "intrinsic-type-spec at %C") == FAILURE
)
2658 ts
->type
= BT_CHARACTER
;
2659 if (implicit_flag
== 0)
2660 m
= gfc_match_char_spec (ts
);
2664 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2670 if ((matched_type
&& strcmp ("real", name
) == 0)
2671 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2674 ts
->kind
= gfc_default_real_kind
;
2679 && (strcmp ("doubleprecision", name
) == 0
2680 || (strcmp ("double", name
) == 0
2681 && gfc_match (" precision") == MATCH_YES
)))
2682 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2685 && gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2686 "intrinsic-type-spec at %C") == FAILURE
)
2688 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2692 ts
->kind
= gfc_default_double_kind
;
2696 if ((matched_type
&& strcmp ("complex", name
) == 0)
2697 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2699 ts
->type
= BT_COMPLEX
;
2700 ts
->kind
= gfc_default_complex_kind
;
2705 && (strcmp ("doublecomplex", name
) == 0
2706 || (strcmp ("double", name
) == 0
2707 && gfc_match (" complex") == MATCH_YES
)))
2708 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2710 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") == FAILURE
)
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
,
2765 NULL
, &gfc_current_locus
) == FAILURE
)
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")
2790 /* Defer association of the derived type until the end of the
2791 specification block. However, if the derived type can be
2792 found, add it to the typespec. */
2793 if (gfc_matching_function
)
2795 ts
->u
.derived
= NULL
;
2796 if (gfc_current_state () != COMP_INTERFACE
2797 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2799 sym
= gfc_find_dt_in_generic (sym
);
2800 ts
->u
.derived
= sym
;
2805 /* Search for the name but allow the components to be defined later. If
2806 type = -1, this typespec has been seen in a function declaration but
2807 the type could not be accessed at that point. The actual derived type is
2808 stored in a symtree with the first letter of the name capitalized; the
2809 symtree with the all lower-case name contains the associated
2810 generic function. */
2811 dt_name
= gfc_get_string ("%c%s",
2812 (char) TOUPPER ((unsigned char) name
[0]),
2813 (const char*)&name
[1]);
2818 gfc_get_ha_symbol (name
, &sym
);
2819 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2821 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2824 if (sym
->generic
&& !dt_sym
)
2825 dt_sym
= gfc_find_dt_in_generic (sym
);
2827 else if (ts
->kind
== -1)
2829 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2830 || gfc_current_ns
->has_import_set
;
2831 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2832 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2834 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2837 if (sym
&& sym
->generic
&& !dt_sym
)
2838 dt_sym
= gfc_find_dt_in_generic (sym
);
2845 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2846 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2847 || sym
->attr
.subroutine
)
2849 gfc_error ("Type name '%s' at %C conflicts with previously declared "
2850 "entity at %L, which has the same name", name
,
2855 gfc_save_symbol_data (sym
);
2856 gfc_set_sym_referenced (sym
);
2857 if (!sym
->attr
.generic
2858 && gfc_add_generic (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2861 if (!sym
->attr
.function
2862 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2867 gfc_interface
*intr
, *head
;
2869 /* Use upper case to save the actual derived-type symbol. */
2870 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2871 dt_sym
->name
= gfc_get_string (sym
->name
);
2872 head
= sym
->generic
;
2873 intr
= gfc_get_interface ();
2875 intr
->where
= gfc_current_locus
;
2877 sym
->generic
= intr
;
2878 sym
->attr
.if_source
= IFSRC_DECL
;
2881 gfc_save_symbol_data (dt_sym
);
2883 gfc_set_sym_referenced (dt_sym
);
2885 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2886 && gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
)
2890 ts
->u
.derived
= dt_sym
;
2896 && gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2897 "intrinsic-type-spec at %C") == FAILURE
)
2900 /* For all types except double, derived and character, look for an
2901 optional kind specifier. MATCH_NO is actually OK at this point. */
2902 if (implicit_flag
== 1)
2904 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2910 if (gfc_current_form
== FORM_FREE
)
2912 c
= gfc_peek_ascii_char ();
2913 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2914 && c
!= ':' && c
!= ',')
2916 if (matched_type
&& c
== ')')
2918 gfc_next_ascii_char ();
2925 m
= gfc_match_kind_spec (ts
, false);
2926 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2927 m
= gfc_match_old_kind_spec (ts
);
2929 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2932 /* Defer association of the KIND expression of function results
2933 until after USE and IMPORT statements. */
2934 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
2935 || gfc_matching_function
)
2939 m
= MATCH_YES
; /* No kind specifier found. */
2945 /* Match an IMPLICIT NONE statement. Actually, this statement is
2946 already matched in parse.c, or we would not end up here in the
2947 first place. So the only thing we need to check, is if there is
2948 trailing garbage. If not, the match is successful. */
2951 gfc_match_implicit_none (void)
2953 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
2957 /* Match the letter range(s) of an IMPLICIT statement. */
2960 match_implicit_range (void)
2966 cur_loc
= gfc_current_locus
;
2968 gfc_gobble_whitespace ();
2969 c
= gfc_next_ascii_char ();
2972 gfc_error ("Missing character range in IMPLICIT at %C");
2979 gfc_gobble_whitespace ();
2980 c1
= gfc_next_ascii_char ();
2984 gfc_gobble_whitespace ();
2985 c
= gfc_next_ascii_char ();
2990 inner
= 0; /* Fall through. */
2997 gfc_gobble_whitespace ();
2998 c2
= gfc_next_ascii_char ();
3002 gfc_gobble_whitespace ();
3003 c
= gfc_next_ascii_char ();
3005 if ((c
!= ',') && (c
!= ')'))
3018 gfc_error ("Letters must be in alphabetic order in "
3019 "IMPLICIT statement at %C");
3023 /* See if we can add the newly matched range to the pending
3024 implicits from this IMPLICIT statement. We do not check for
3025 conflicts with whatever earlier IMPLICIT statements may have
3026 set. This is done when we've successfully finished matching
3028 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
3035 gfc_syntax_error (ST_IMPLICIT
);
3037 gfc_current_locus
= cur_loc
;
3042 /* Match an IMPLICIT statement, storing the types for
3043 gfc_set_implicit() if the statement is accepted by the parser.
3044 There is a strange looking, but legal syntactic construction
3045 possible. It looks like:
3047 IMPLICIT INTEGER (a-b) (c-d)
3049 This is legal if "a-b" is a constant expression that happens to
3050 equal one of the legal kinds for integers. The real problem
3051 happens with an implicit specification that looks like:
3053 IMPLICIT INTEGER (a-b)
3055 In this case, a typespec matcher that is "greedy" (as most of the
3056 matchers are) gobbles the character range as a kindspec, leaving
3057 nothing left. We therefore have to go a bit more slowly in the
3058 matching process by inhibiting the kindspec checking during
3059 typespec matching and checking for a kind later. */
3062 gfc_match_implicit (void)
3071 /* We don't allow empty implicit statements. */
3072 if (gfc_match_eos () == MATCH_YES
)
3074 gfc_error ("Empty IMPLICIT statement at %C");
3080 /* First cleanup. */
3081 gfc_clear_new_implicit ();
3083 /* A basic type is mandatory here. */
3084 m
= gfc_match_decl_type_spec (&ts
, 1);
3085 if (m
== MATCH_ERROR
)
3090 cur_loc
= gfc_current_locus
;
3091 m
= match_implicit_range ();
3095 /* We may have <TYPE> (<RANGE>). */
3096 gfc_gobble_whitespace ();
3097 c
= gfc_next_ascii_char ();
3098 if ((c
== '\n') || (c
== ','))
3100 /* Check for CHARACTER with no length parameter. */
3101 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3103 ts
.kind
= gfc_default_character_kind
;
3104 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3105 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3109 /* Record the Successful match. */
3110 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
3115 gfc_current_locus
= cur_loc
;
3118 /* Discard the (incorrectly) matched range. */
3119 gfc_clear_new_implicit ();
3121 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3122 if (ts
.type
== BT_CHARACTER
)
3123 m
= gfc_match_char_spec (&ts
);
3126 m
= gfc_match_kind_spec (&ts
, false);
3129 m
= gfc_match_old_kind_spec (&ts
);
3130 if (m
== MATCH_ERROR
)
3136 if (m
== MATCH_ERROR
)
3139 m
= match_implicit_range ();
3140 if (m
== MATCH_ERROR
)
3145 gfc_gobble_whitespace ();
3146 c
= gfc_next_ascii_char ();
3147 if ((c
!= '\n') && (c
!= ','))
3150 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
3158 gfc_syntax_error (ST_IMPLICIT
);
3166 gfc_match_import (void)
3168 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3173 if (gfc_current_ns
->proc_name
== NULL
3174 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3176 gfc_error ("IMPORT statement at %C only permitted in "
3177 "an INTERFACE body");
3181 if (gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C")
3185 if (gfc_match_eos () == MATCH_YES
)
3187 /* All host variables should be imported. */
3188 gfc_current_ns
->has_import_set
= 1;
3192 if (gfc_match (" ::") == MATCH_YES
)
3194 if (gfc_match_eos () == MATCH_YES
)
3196 gfc_error ("Expecting list of named entities at %C");
3204 m
= gfc_match (" %n", name
);
3208 if (gfc_current_ns
->parent
!= NULL
3209 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3211 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3214 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3215 && gfc_find_symbol (name
,
3216 gfc_current_ns
->proc_name
->ns
->parent
,
3219 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3225 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
3226 "at %C - does not exist.", name
);
3230 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3232 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
3237 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3240 sym
->attr
.imported
= 1;
3242 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3244 /* The actual derived type is stored in a symtree with the first
3245 letter of the name capitalized; the symtree with the all
3246 lower-case name contains the associated generic function. */
3247 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3248 gfc_get_string ("%c%s",
3249 (char) TOUPPER ((unsigned char) name
[0]),
3253 sym
->attr
.imported
= 1;
3266 if (gfc_match_eos () == MATCH_YES
)
3268 if (gfc_match_char (',') != MATCH_YES
)
3275 gfc_error ("Syntax error in IMPORT statement at %C");
3280 /* A minimal implementation of gfc_match without whitespace, escape
3281 characters or variable arguments. Returns true if the next
3282 characters match the TARGET template exactly. */
3285 match_string_p (const char *target
)
3289 for (p
= target
; *p
; p
++)
3290 if ((char) gfc_next_ascii_char () != *p
)
3295 /* Matches an attribute specification including array specs. If
3296 successful, leaves the variables current_attr and current_as
3297 holding the specification. Also sets the colon_seen variable for
3298 later use by matchers associated with initializations.
3300 This subroutine is a little tricky in the sense that we don't know
3301 if we really have an attr-spec until we hit the double colon.
3302 Until that time, we can only return MATCH_NO. This forces us to
3303 check for duplicate specification at this level. */
3306 match_attr_spec (void)
3308 /* Modifiers that can exist in a type statement. */
3310 { GFC_DECL_BEGIN
= 0,
3311 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3312 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3313 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3314 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3315 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3316 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3319 /* GFC_DECL_END is the sentinel, index starts at 0. */
3320 #define NUM_DECL GFC_DECL_END
3322 locus start
, seen_at
[NUM_DECL
];
3329 gfc_clear_attr (¤t_attr
);
3330 start
= gfc_current_locus
;
3335 /* See if we get all of the keywords up to the final double colon. */
3336 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3344 gfc_gobble_whitespace ();
3346 ch
= gfc_next_ascii_char ();
3349 /* This is the successful exit condition for the loop. */
3350 if (gfc_next_ascii_char () == ':')
3355 gfc_gobble_whitespace ();
3356 switch (gfc_peek_ascii_char ())
3359 gfc_next_ascii_char ();
3360 switch (gfc_next_ascii_char ())
3363 if (match_string_p ("locatable"))
3365 /* Matched "allocatable". */
3366 d
= DECL_ALLOCATABLE
;
3371 if (match_string_p ("ynchronous"))
3373 /* Matched "asynchronous". */
3374 d
= DECL_ASYNCHRONOUS
;
3381 /* Try and match the bind(c). */
3382 m
= gfc_match_bind_c (NULL
, true);
3385 else if (m
== MATCH_ERROR
)
3390 gfc_next_ascii_char ();
3391 if ('o' != gfc_next_ascii_char ())
3393 switch (gfc_next_ascii_char ())
3396 if (match_string_p ("imension"))
3398 d
= DECL_CODIMENSION
;
3402 if (match_string_p ("tiguous"))
3404 d
= DECL_CONTIGUOUS
;
3411 if (match_string_p ("dimension"))
3416 if (match_string_p ("external"))
3421 if (match_string_p ("int"))
3423 ch
= gfc_next_ascii_char ();
3426 if (match_string_p ("nt"))
3428 /* Matched "intent". */
3429 /* TODO: Call match_intent_spec from here. */
3430 if (gfc_match (" ( in out )") == MATCH_YES
)
3432 else if (gfc_match (" ( in )") == MATCH_YES
)
3434 else if (gfc_match (" ( out )") == MATCH_YES
)
3440 if (match_string_p ("insic"))
3442 /* Matched "intrinsic". */
3450 if (match_string_p ("optional"))
3455 gfc_next_ascii_char ();
3456 switch (gfc_next_ascii_char ())
3459 if (match_string_p ("rameter"))
3461 /* Matched "parameter". */
3467 if (match_string_p ("inter"))
3469 /* Matched "pointer". */
3475 ch
= gfc_next_ascii_char ();
3478 if (match_string_p ("vate"))
3480 /* Matched "private". */
3486 if (match_string_p ("tected"))
3488 /* Matched "protected". */
3495 if (match_string_p ("blic"))
3497 /* Matched "public". */
3505 if (match_string_p ("save"))
3510 if (match_string_p ("target"))
3515 gfc_next_ascii_char ();
3516 ch
= gfc_next_ascii_char ();
3519 if (match_string_p ("lue"))
3521 /* Matched "value". */
3527 if (match_string_p ("latile"))
3529 /* Matched "volatile". */
3537 /* No double colon and no recognizable decl_type, so assume that
3538 we've been looking at something else the whole time. */
3545 /* Check to make sure any parens are paired up correctly. */
3546 if (gfc_match_parens () == MATCH_ERROR
)
3553 seen_at
[d
] = gfc_current_locus
;
3555 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3557 gfc_array_spec
*as
= NULL
;
3559 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3560 d
== DECL_CODIMENSION
);
3562 if (current_as
== NULL
)
3564 else if (m
== MATCH_YES
)
3566 if (merge_array_spec (as
, current_as
, false) == FAILURE
)
3573 if (d
== DECL_CODIMENSION
)
3574 gfc_error ("Missing codimension specification at %C");
3576 gfc_error ("Missing dimension specification at %C");
3580 if (m
== MATCH_ERROR
)
3585 /* Since we've seen a double colon, we have to be looking at an
3586 attr-spec. This means that we can now issue errors. */
3587 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3592 case DECL_ALLOCATABLE
:
3593 attr
= "ALLOCATABLE";
3595 case DECL_ASYNCHRONOUS
:
3596 attr
= "ASYNCHRONOUS";
3598 case DECL_CODIMENSION
:
3599 attr
= "CODIMENSION";
3601 case DECL_CONTIGUOUS
:
3602 attr
= "CONTIGUOUS";
3604 case DECL_DIMENSION
:
3611 attr
= "INTENT (IN)";
3614 attr
= "INTENT (OUT)";
3617 attr
= "INTENT (IN OUT)";
3619 case DECL_INTRINSIC
:
3625 case DECL_PARAMETER
:
3631 case DECL_PROTECTED
:
3646 case DECL_IS_BIND_C
:
3656 attr
= NULL
; /* This shouldn't happen. */
3659 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3664 /* Now that we've dealt with duplicate attributes, add the attributes
3665 to the current attribute. */
3666 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3671 if (gfc_current_state () == COMP_DERIVED
3672 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3673 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3674 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3676 if (d
== DECL_ALLOCATABLE
)
3678 if (gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3679 "attribute at %C in a TYPE definition")
3688 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3695 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3696 && gfc_current_state () != COMP_MODULE
)
3698 if (d
== DECL_PRIVATE
)
3702 if (gfc_current_state () == COMP_DERIVED
3703 && gfc_state_stack
->previous
3704 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3706 if (gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3707 "at %L in a TYPE definition", attr
,
3717 gfc_error ("%s attribute at %L is not allowed outside of the "
3718 "specification part of a module", attr
, &seen_at
[d
]);
3726 case DECL_ALLOCATABLE
:
3727 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3730 case DECL_ASYNCHRONOUS
:
3731 if (gfc_notify_std (GFC_STD_F2003
,
3732 "ASYNCHRONOUS attribute at %C")
3736 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3739 case DECL_CODIMENSION
:
3740 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3743 case DECL_CONTIGUOUS
:
3744 if (gfc_notify_std (GFC_STD_F2008
,
3745 "CONTIGUOUS attribute at %C")
3749 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3752 case DECL_DIMENSION
:
3753 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3757 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3761 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3765 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3769 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3772 case DECL_INTRINSIC
:
3773 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3777 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3780 case DECL_PARAMETER
:
3781 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3785 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3788 case DECL_PROTECTED
:
3789 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3791 gfc_error ("PROTECTED at %C only allowed in specification "
3792 "part of a module");
3797 if (gfc_notify_std (GFC_STD_F2003
, "PROTECTED "
3802 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3806 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3811 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3816 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3820 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3823 case DECL_IS_BIND_C
:
3824 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3828 if (gfc_notify_std (GFC_STD_F2003
, "VALUE attribute "
3833 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3837 if (gfc_notify_std (GFC_STD_F2003
,
3838 "VOLATILE attribute at %C")
3842 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3846 gfc_internal_error ("match_attr_spec(): Bad attribute");
3856 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3857 if (gfc_current_state () == COMP_MODULE
&& !current_attr
.save
3858 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3859 current_attr
.save
= SAVE_IMPLICIT
;
3865 gfc_current_locus
= start
;
3866 gfc_free_array_spec (current_as
);
3872 /* Set the binding label, dest_label, either with the binding label
3873 stored in the given gfc_typespec, ts, or if none was provided, it
3874 will be the symbol name in all lower case, as required by the draft
3875 (J3/04-007, section 15.4.1). If a binding label was given and
3876 there is more than one argument (num_idents), it is an error. */
3879 set_binding_label (const char **dest_label
, const char *sym_name
,
3882 if (num_idents
> 1 && has_name_equals
)
3884 gfc_error ("Multiple identifiers provided with "
3885 "single NAME= specifier at %C");
3889 if (curr_binding_label
)
3890 /* Binding label given; store in temp holder till have sym. */
3891 *dest_label
= curr_binding_label
;
3894 /* No binding label given, and the NAME= specifier did not exist,
3895 which means there was no NAME="". */
3896 if (sym_name
!= NULL
&& has_name_equals
== 0)
3897 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
3904 /* Set the status of the given common block as being BIND(C) or not,
3905 depending on the given parameter, is_bind_c. */
3908 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
3910 com_block
->is_bind_c
= is_bind_c
;
3915 /* Verify that the given gfc_typespec is for a C interoperable type. */
3918 gfc_verify_c_interop (gfc_typespec
*ts
)
3920 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
3921 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
3922 ? SUCCESS
: FAILURE
;
3923 else if (ts
->type
== BT_CLASS
)
3925 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
3932 /* Verify that the variables of a given common block, which has been
3933 defined with the attribute specifier bind(c), to be of a C
3934 interoperable type. Errors will be reported here, if
3938 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
3940 gfc_symbol
*curr_sym
= NULL
;
3941 gfc_try retval
= SUCCESS
;
3943 curr_sym
= com_block
->head
;
3945 /* Make sure we have at least one symbol. */
3946 if (curr_sym
== NULL
)
3949 /* Here we know we have a symbol, so we'll execute this loop
3953 /* The second to last param, 1, says this is in a common block. */
3954 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
3955 curr_sym
= curr_sym
->common_next
;
3956 } while (curr_sym
!= NULL
);
3962 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3963 an appropriate error message is reported. */
3966 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
3967 int is_in_common
, gfc_common_head
*com_block
)
3969 bool bind_c_function
= false;
3970 gfc_try retval
= SUCCESS
;
3972 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
3973 bind_c_function
= true;
3975 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
3977 tmp_sym
= tmp_sym
->result
;
3978 /* Make sure it wasn't an implicitly typed result. */
3979 if (tmp_sym
->attr
.implicit_type
&& gfc_option
.warn_c_binding_type
)
3981 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3982 "%L may not be C interoperable", tmp_sym
->name
,
3983 &tmp_sym
->declared_at
);
3984 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
3985 /* Mark it as C interoperable to prevent duplicate warnings. */
3986 tmp_sym
->ts
.is_c_interop
= 1;
3987 tmp_sym
->attr
.is_c_interop
= 1;
3991 /* Here, we know we have the bind(c) attribute, so if we have
3992 enough type info, then verify that it's a C interop kind.
3993 The info could be in the symbol already, or possibly still in
3994 the given ts (current_ts), so look in both. */
3995 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
3997 if (gfc_verify_c_interop (&(tmp_sym
->ts
)) != SUCCESS
)
3999 /* See if we're dealing with a sym in a common block or not. */
4000 if (is_in_common
== 1 && gfc_option
.warn_c_binding_type
)
4002 gfc_warning ("Variable '%s' in common block '%s' at %L "
4003 "may not be a C interoperable "
4004 "kind though common block '%s' is BIND(C)",
4005 tmp_sym
->name
, com_block
->name
,
4006 &(tmp_sym
->declared_at
), com_block
->name
);
4010 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4011 gfc_error ("Type declaration '%s' at %L is not C "
4012 "interoperable but it is BIND(C)",
4013 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4014 else if (gfc_option
.warn_c_binding_type
)
4015 gfc_warning ("Variable '%s' at %L "
4016 "may not be a C interoperable "
4017 "kind but it is bind(c)",
4018 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4022 /* Variables declared w/in a common block can't be bind(c)
4023 since there's no way for C to see these variables, so there's
4024 semantically no reason for the attribute. */
4025 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4027 gfc_error ("Variable '%s' in common block '%s' at "
4028 "%L cannot be declared with BIND(C) "
4029 "since it is not a global",
4030 tmp_sym
->name
, com_block
->name
,
4031 &(tmp_sym
->declared_at
));
4035 /* Scalar variables that are bind(c) can not have the pointer
4036 or allocatable attributes. */
4037 if (tmp_sym
->attr
.is_bind_c
== 1)
4039 if (tmp_sym
->attr
.pointer
== 1)
4041 gfc_error ("Variable '%s' at %L cannot have both the "
4042 "POINTER and BIND(C) attributes",
4043 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4047 if (tmp_sym
->attr
.allocatable
== 1)
4049 gfc_error ("Variable '%s' at %L cannot have both the "
4050 "ALLOCATABLE and BIND(C) attributes",
4051 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4057 /* If it is a BIND(C) function, make sure the return value is a
4058 scalar value. The previous tests in this function made sure
4059 the type is interoperable. */
4060 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4061 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4062 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4064 /* BIND(C) functions can not return a character string. */
4065 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4066 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4067 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4068 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4069 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4070 "be a character string", tmp_sym
->name
,
4071 &(tmp_sym
->declared_at
));
4074 /* See if the symbol has been marked as private. If it has, make sure
4075 there is no binding label and warn the user if there is one. */
4076 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4077 && tmp_sym
->binding_label
)
4078 /* Use gfc_warning_now because we won't say that the symbol fails
4079 just because of this. */
4080 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
4081 "given the binding label '%s'", tmp_sym
->name
,
4082 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4088 /* Set the appropriate fields for a symbol that's been declared as
4089 BIND(C) (the is_bind_c flag and the binding label), and verify that
4090 the type is C interoperable. Errors are reported by the functions
4091 used to set/test these fields. */
4094 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4096 gfc_try retval
= SUCCESS
;
4098 /* TODO: Do we need to make sure the vars aren't marked private? */
4100 /* Set the is_bind_c bit in symbol_attribute. */
4101 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4103 if (set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
,
4104 num_idents
) != SUCCESS
)
4111 /* Set the fields marking the given common block as BIND(C), including
4112 a binding label, and report any errors encountered. */
4115 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4117 gfc_try retval
= SUCCESS
;
4119 /* destLabel, common name, typespec (which may have binding label). */
4120 if (set_binding_label (&com_block
->binding_label
, com_block
->name
,
4125 /* Set the given common block (com_block) to being bind(c) (1). */
4126 set_com_block_bind_c (com_block
, 1);
4132 /* Retrieve the list of one or more identifiers that the given bind(c)
4133 attribute applies to. */
4136 get_bind_c_idents (void)
4138 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4140 gfc_symbol
*tmp_sym
= NULL
;
4142 gfc_common_head
*com_block
= NULL
;
4144 if (gfc_match_name (name
) == MATCH_YES
)
4146 found_id
= MATCH_YES
;
4147 gfc_get_ha_symbol (name
, &tmp_sym
);
4149 else if (match_common_name (name
) == MATCH_YES
)
4151 found_id
= MATCH_YES
;
4152 com_block
= gfc_get_common (name
, 0);
4156 gfc_error ("Need either entity or common block name for "
4157 "attribute specification statement at %C");
4161 /* Save the current identifier and look for more. */
4164 /* Increment the number of identifiers found for this spec stmt. */
4167 /* Make sure we have a sym or com block, and verify that it can
4168 be bind(c). Set the appropriate field(s) and look for more
4170 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4172 if (tmp_sym
!= NULL
)
4174 if (set_verify_bind_c_sym (tmp_sym
, num_idents
)
4180 if (set_verify_bind_c_com_block(com_block
, num_idents
)
4185 /* Look to see if we have another identifier. */
4187 if (gfc_match_eos () == MATCH_YES
)
4188 found_id
= MATCH_NO
;
4189 else if (gfc_match_char (',') != MATCH_YES
)
4190 found_id
= MATCH_NO
;
4191 else if (gfc_match_name (name
) == MATCH_YES
)
4193 found_id
= MATCH_YES
;
4194 gfc_get_ha_symbol (name
, &tmp_sym
);
4196 else if (match_common_name (name
) == MATCH_YES
)
4198 found_id
= MATCH_YES
;
4199 com_block
= gfc_get_common (name
, 0);
4203 gfc_error ("Missing entity or common block name for "
4204 "attribute specification statement at %C");
4210 gfc_internal_error ("Missing symbol");
4212 } while (found_id
== MATCH_YES
);
4214 /* if we get here we were successful */
4219 /* Try and match a BIND(C) attribute specification statement. */
4222 gfc_match_bind_c_stmt (void)
4224 match found_match
= MATCH_NO
;
4229 /* This may not be necessary. */
4231 /* Clear the temporary binding label holder. */
4232 curr_binding_label
= NULL
;
4234 /* Look for the bind(c). */
4235 found_match
= gfc_match_bind_c (NULL
, true);
4237 if (found_match
== MATCH_YES
)
4239 /* Look for the :: now, but it is not required. */
4242 /* Get the identifier(s) that needs to be updated. This may need to
4243 change to hand the flag(s) for the attr specified so all identifiers
4244 found can have all appropriate parts updated (assuming that the same
4245 spec stmt can have multiple attrs, such as both bind(c) and
4247 if (get_bind_c_idents () != SUCCESS
)
4248 /* Error message should have printed already. */
4256 /* Match a data declaration statement. */
4259 gfc_match_data_decl (void)
4265 num_idents_on_line
= 0;
4267 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4271 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4272 && gfc_current_state () != COMP_DERIVED
)
4274 sym
= gfc_use_derived (current_ts
.u
.derived
);
4282 current_ts
.u
.derived
= sym
;
4285 m
= match_attr_spec ();
4286 if (m
== MATCH_ERROR
)
4292 if (current_ts
.type
== BT_CLASS
4293 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4296 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4297 && current_ts
.u
.derived
->components
== NULL
4298 && !current_ts
.u
.derived
->attr
.zero_comp
)
4301 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4304 gfc_find_symbol (current_ts
.u
.derived
->name
,
4305 current_ts
.u
.derived
->ns
, 1, &sym
);
4307 /* Any symbol that we find had better be a type definition
4308 which has its components defined. */
4309 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4310 && (current_ts
.u
.derived
->components
!= NULL
4311 || current_ts
.u
.derived
->attr
.zero_comp
))
4314 /* Now we have an error, which we signal, and then fix up
4315 because the knock-on is plain and simple confusing. */
4316 gfc_error_now ("Derived type at %C has not been previously defined "
4317 "and so cannot appear in a derived type definition");
4318 current_attr
.pointer
= 1;
4323 /* If we have an old-style character declaration, and no new-style
4324 attribute specifications, then there a comma is optional between
4325 the type specification and the variable list. */
4326 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4327 gfc_match_char (',');
4329 /* Give the types/attributes to symbols that follow. Give the element
4330 a number so that repeat character length expressions can be copied. */
4334 num_idents_on_line
++;
4335 m
= variable_decl (elem
++);
4336 if (m
== MATCH_ERROR
)
4341 if (gfc_match_eos () == MATCH_YES
)
4343 if (gfc_match_char (',') != MATCH_YES
)
4347 if (gfc_error_flag_test () == 0)
4348 gfc_error ("Syntax error in data declaration at %C");
4351 gfc_free_data_all (gfc_current_ns
);
4354 gfc_free_array_spec (current_as
);
4360 /* Match a prefix associated with a function or subroutine
4361 declaration. If the typespec pointer is nonnull, then a typespec
4362 can be matched. Note that if nothing matches, MATCH_YES is
4363 returned (the null string was matched). */
4366 gfc_match_prefix (gfc_typespec
*ts
)
4372 gfc_clear_attr (¤t_attr
);
4374 seen_impure
= false;
4376 gcc_assert (!gfc_matching_prefix
);
4377 gfc_matching_prefix
= true;
4381 found_prefix
= false;
4383 if (!seen_type
&& ts
!= NULL
4384 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4385 && gfc_match_space () == MATCH_YES
)
4389 found_prefix
= true;
4392 if (gfc_match ("elemental% ") == MATCH_YES
)
4394 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
4397 found_prefix
= true;
4400 if (gfc_match ("pure% ") == MATCH_YES
)
4402 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
4405 found_prefix
= true;
4408 if (gfc_match ("recursive% ") == MATCH_YES
)
4410 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
4413 found_prefix
= true;
4416 /* IMPURE is a somewhat special case, as it needs not set an actual
4417 attribute but rather only prevents ELEMENTAL routines from being
4418 automatically PURE. */
4419 if (gfc_match ("impure% ") == MATCH_YES
)
4421 if (gfc_notify_std (GFC_STD_F2008
,
4422 "IMPURE procedure at %C")
4427 found_prefix
= true;
4430 while (found_prefix
);
4432 /* IMPURE and PURE must not both appear, of course. */
4433 if (seen_impure
&& current_attr
.pure
)
4435 gfc_error ("PURE and IMPURE must not appear both at %C");
4439 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4440 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4442 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
4446 /* At this point, the next item is not a prefix. */
4447 gcc_assert (gfc_matching_prefix
);
4448 gfc_matching_prefix
= false;
4452 gcc_assert (gfc_matching_prefix
);
4453 gfc_matching_prefix
= false;
4458 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4461 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4463 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
4466 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
4469 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
4476 /* Match a formal argument list. */
4479 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4481 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4482 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4488 if (gfc_match_char ('(') != MATCH_YES
)
4495 if (gfc_match_char (')') == MATCH_YES
)
4500 if (gfc_match_char ('*') == MATCH_YES
)
4504 m
= gfc_match_name (name
);
4508 if (gfc_get_symbol (name
, NULL
, &sym
))
4512 p
= gfc_get_formal_arglist ();
4524 /* We don't add the VARIABLE flavor because the name could be a
4525 dummy procedure. We don't apply these attributes to formal
4526 arguments of statement functions. */
4527 if (sym
!= NULL
&& !st_flag
4528 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
4529 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
4535 /* The name of a program unit can be in a different namespace,
4536 so check for it explicitly. After the statement is accepted,
4537 the name is checked for especially in gfc_get_symbol(). */
4538 if (gfc_new_block
!= NULL
&& sym
!= NULL
4539 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4541 gfc_error ("Name '%s' at %C is the name of the procedure",
4547 if (gfc_match_char (')') == MATCH_YES
)
4550 m
= gfc_match_char (',');
4553 gfc_error ("Unexpected junk in formal argument list at %C");
4559 /* Check for duplicate symbols in the formal argument list. */
4562 for (p
= head
; p
->next
; p
= p
->next
)
4567 for (q
= p
->next
; q
; q
= q
->next
)
4568 if (p
->sym
== q
->sym
)
4570 gfc_error ("Duplicate symbol '%s' in formal argument list "
4571 "at %C", p
->sym
->name
);
4579 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
)
4589 gfc_free_formal_arglist (head
);
4594 /* Match a RESULT specification following a function declaration or
4595 ENTRY statement. Also matches the end-of-statement. */
4598 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4600 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4604 if (gfc_match (" result (") != MATCH_YES
)
4607 m
= gfc_match_name (name
);
4611 /* Get the right paren, and that's it because there could be the
4612 bind(c) attribute after the result clause. */
4613 if (gfc_match_char(')') != MATCH_YES
)
4615 /* TODO: should report the missing right paren here. */
4619 if (strcmp (function
->name
, name
) == 0)
4621 gfc_error ("RESULT variable at %C must be different than function name");
4625 if (gfc_get_symbol (name
, NULL
, &r
))
4628 if (gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
4637 /* Match a function suffix, which could be a combination of a result
4638 clause and BIND(C), either one, or neither. The draft does not
4639 require them to come in a specific order. */
4642 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4644 match is_bind_c
; /* Found bind(c). */
4645 match is_result
; /* Found result clause. */
4646 match found_match
; /* Status of whether we've found a good match. */
4647 char peek_char
; /* Character we're going to peek at. */
4648 bool allow_binding_name
;
4650 /* Initialize to having found nothing. */
4651 found_match
= MATCH_NO
;
4652 is_bind_c
= MATCH_NO
;
4653 is_result
= MATCH_NO
;
4655 /* Get the next char to narrow between result and bind(c). */
4656 gfc_gobble_whitespace ();
4657 peek_char
= gfc_peek_ascii_char ();
4659 /* C binding names are not allowed for internal procedures. */
4660 if (gfc_current_state () == COMP_CONTAINS
4661 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4662 allow_binding_name
= false;
4664 allow_binding_name
= true;
4669 /* Look for result clause. */
4670 is_result
= match_result (sym
, result
);
4671 if (is_result
== MATCH_YES
)
4673 /* Now see if there is a bind(c) after it. */
4674 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4675 /* We've found the result clause and possibly bind(c). */
4676 found_match
= MATCH_YES
;
4679 /* This should only be MATCH_ERROR. */
4680 found_match
= is_result
;
4683 /* Look for bind(c) first. */
4684 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4685 if (is_bind_c
== MATCH_YES
)
4687 /* Now see if a result clause followed it. */
4688 is_result
= match_result (sym
, result
);
4689 found_match
= MATCH_YES
;
4693 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4694 found_match
= MATCH_ERROR
;
4698 gfc_error ("Unexpected junk after function declaration at %C");
4699 found_match
= MATCH_ERROR
;
4703 if (is_bind_c
== MATCH_YES
)
4705 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4706 if (gfc_current_state () == COMP_CONTAINS
4707 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4708 && gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4709 "at %L may not be specified for an internal "
4710 "procedure", &gfc_current_locus
)
4714 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1)
4723 /* Procedure pointer return value without RESULT statement:
4724 Add "hidden" result variable named "ppr@". */
4727 add_hidden_procptr_result (gfc_symbol
*sym
)
4731 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4734 /* First usage case: PROCEDURE and EXTERNAL statements. */
4735 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4736 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4737 && sym
->attr
.external
;
4738 /* Second usage case: INTERFACE statements. */
4739 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4740 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4741 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4747 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4751 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4752 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4753 st2
->n
.sym
= stree
->n
.sym
;
4755 sym
->result
= stree
->n
.sym
;
4757 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4758 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4759 sym
->result
->attr
.external
= sym
->attr
.external
;
4760 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4761 sym
->result
->ts
= sym
->ts
;
4762 sym
->attr
.proc_pointer
= 0;
4763 sym
->attr
.pointer
= 0;
4764 sym
->attr
.external
= 0;
4765 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4767 sym
->result
->attr
.pointer
= 0;
4768 sym
->result
->attr
.proc_pointer
= 1;
4771 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4773 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4774 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4775 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4776 && sym
== gfc_current_ns
->proc_name
4777 && sym
== sym
->result
->ns
->proc_name
4778 && strcmp ("ppr@", sym
->result
->name
) == 0)
4780 sym
->result
->attr
.proc_pointer
= 1;
4781 sym
->attr
.pointer
= 0;
4789 /* Match the interface for a PROCEDURE declaration,
4790 including brackets (R1212). */
4793 match_procedure_interface (gfc_symbol
**proc_if
)
4797 locus old_loc
, entry_loc
;
4798 gfc_namespace
*old_ns
= gfc_current_ns
;
4799 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4801 old_loc
= entry_loc
= gfc_current_locus
;
4802 gfc_clear_ts (¤t_ts
);
4804 if (gfc_match (" (") != MATCH_YES
)
4806 gfc_current_locus
= entry_loc
;
4810 /* Get the type spec. for the procedure interface. */
4811 old_loc
= gfc_current_locus
;
4812 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4813 gfc_gobble_whitespace ();
4814 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4817 if (m
== MATCH_ERROR
)
4820 /* Procedure interface is itself a procedure. */
4821 gfc_current_locus
= old_loc
;
4822 m
= gfc_match_name (name
);
4824 /* First look to see if it is already accessible in the current
4825 namespace because it is use associated or contained. */
4827 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
4830 /* If it is still not found, then try the parent namespace, if it
4831 exists and create the symbol there if it is still not found. */
4832 if (gfc_current_ns
->parent
)
4833 gfc_current_ns
= gfc_current_ns
->parent
;
4834 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
4837 gfc_current_ns
= old_ns
;
4838 *proc_if
= st
->n
.sym
;
4843 /* Resolve interface if possible. That way, attr.procedure is only set
4844 if it is declared by a later procedure-declaration-stmt, which is
4845 invalid per F08:C1216 (cf. resolve_procedure_interface). */
4846 while ((*proc_if
)->ts
.interface
)
4847 *proc_if
= (*proc_if
)->ts
.interface
;
4849 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
4850 && (*proc_if
)->ts
.type
== BT_UNKNOWN
4851 && gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
4852 (*proc_if
)->name
, NULL
) == FAILURE
)
4857 if (gfc_match (" )") != MATCH_YES
)
4859 gfc_current_locus
= entry_loc
;
4867 /* Match a PROCEDURE declaration (R1211). */
4870 match_procedure_decl (void)
4873 gfc_symbol
*sym
, *proc_if
= NULL
;
4875 gfc_expr
*initializer
= NULL
;
4877 /* Parse interface (with brackets). */
4878 m
= match_procedure_interface (&proc_if
);
4882 /* Parse attributes (with colons). */
4883 m
= match_attr_spec();
4884 if (m
== MATCH_ERROR
)
4887 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
4889 current_attr
.is_bind_c
= 1;
4890 has_name_equals
= 0;
4891 curr_binding_label
= NULL
;
4894 /* Get procedure symbols. */
4897 m
= gfc_match_symbol (&sym
, 0);
4900 else if (m
== MATCH_ERROR
)
4903 /* Add current_attr to the symbol attributes. */
4904 if (gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
4907 if (sym
->attr
.is_bind_c
)
4909 /* Check for C1218. */
4910 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
4912 gfc_error ("BIND(C) attribute at %C requires "
4913 "an interface with BIND(C)");
4916 /* Check for C1217. */
4917 if (has_name_equals
&& sym
->attr
.pointer
)
4919 gfc_error ("BIND(C) procedure with NAME may not have "
4920 "POINTER attribute at %C");
4923 if (has_name_equals
&& sym
->attr
.dummy
)
4925 gfc_error ("Dummy procedure at %C may not have "
4926 "BIND(C) attribute with NAME");
4929 /* Set binding label for BIND(C). */
4930 if (set_binding_label (&sym
->binding_label
, sym
->name
, num
)
4935 if (gfc_add_external (&sym
->attr
, NULL
) == FAILURE
)
4938 if (add_hidden_procptr_result (sym
) == SUCCESS
)
4941 if (gfc_add_proc (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
4944 /* Set interface. */
4945 if (proc_if
!= NULL
)
4947 if (sym
->ts
.type
!= BT_UNKNOWN
)
4949 gfc_error ("Procedure '%s' at %L already has basic type of %s",
4950 sym
->name
, &gfc_current_locus
,
4951 gfc_basic_typename (sym
->ts
.type
));
4954 sym
->ts
.interface
= proc_if
;
4955 sym
->attr
.untyped
= 1;
4956 sym
->attr
.if_source
= IFSRC_IFBODY
;
4958 else if (current_ts
.type
!= BT_UNKNOWN
)
4960 if (gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
) == FAILURE
)
4962 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
4963 sym
->ts
.interface
->ts
= current_ts
;
4964 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
4965 sym
->ts
.interface
->attr
.function
= 1;
4966 sym
->attr
.function
= 1;
4967 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4970 if (gfc_match (" =>") == MATCH_YES
)
4972 if (!current_attr
.pointer
)
4974 gfc_error ("Initialization at %C isn't for a pointer variable");
4979 m
= match_pointer_init (&initializer
, 1);
4983 if (add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
)
4989 if (gfc_match_eos () == MATCH_YES
)
4991 if (gfc_match_char (',') != MATCH_YES
)
4996 gfc_error ("Syntax error in PROCEDURE statement at %C");
5000 /* Free stuff up and return. */
5001 gfc_free_expr (initializer
);
5007 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5010 /* Match a procedure pointer component declaration (R445). */
5013 match_ppc_decl (void)
5016 gfc_symbol
*proc_if
= NULL
;
5020 gfc_expr
*initializer
= NULL
;
5021 gfc_typebound_proc
* tb
;
5022 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5024 /* Parse interface (with brackets). */
5025 m
= match_procedure_interface (&proc_if
);
5029 /* Parse attributes. */
5030 tb
= XCNEW (gfc_typebound_proc
);
5031 tb
->where
= gfc_current_locus
;
5032 m
= match_binding_attributes (tb
, false, true);
5033 if (m
== MATCH_ERROR
)
5036 gfc_clear_attr (¤t_attr
);
5037 current_attr
.procedure
= 1;
5038 current_attr
.proc_pointer
= 1;
5039 current_attr
.access
= tb
->access
;
5040 current_attr
.flavor
= FL_PROCEDURE
;
5042 /* Match the colons (required). */
5043 if (gfc_match (" ::") != MATCH_YES
)
5045 gfc_error ("Expected '::' after binding-attributes at %C");
5049 /* Check for C450. */
5050 if (!tb
->nopass
&& proc_if
== NULL
)
5052 gfc_error("NOPASS or explicit interface required at %C");
5056 if (gfc_notify_std (GFC_STD_F2003
, "Procedure pointer "
5057 "component at %C") == FAILURE
)
5060 /* Match PPC names. */
5064 m
= gfc_match_name (name
);
5067 else if (m
== MATCH_ERROR
)
5070 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
5073 /* Add current_attr to the symbol attributes. */
5074 if (gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
) == FAILURE
)
5077 if (gfc_add_external (&c
->attr
, NULL
) == FAILURE
)
5080 if (gfc_add_proc (&c
->attr
, name
, NULL
) == FAILURE
)
5087 c
->tb
= XCNEW (gfc_typebound_proc
);
5088 c
->tb
->where
= gfc_current_locus
;
5092 /* Set interface. */
5093 if (proc_if
!= NULL
)
5095 c
->ts
.interface
= proc_if
;
5096 c
->attr
.untyped
= 1;
5097 c
->attr
.if_source
= IFSRC_IFBODY
;
5099 else if (ts
.type
!= BT_UNKNOWN
)
5102 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5103 c
->ts
.interface
->result
= c
->ts
.interface
;
5104 c
->ts
.interface
->ts
= ts
;
5105 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5106 c
->ts
.interface
->attr
.function
= 1;
5107 c
->attr
.function
= 1;
5108 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5111 if (gfc_match (" =>") == MATCH_YES
)
5113 m
= match_pointer_init (&initializer
, 1);
5116 gfc_free_expr (initializer
);
5119 c
->initializer
= initializer
;
5122 if (gfc_match_eos () == MATCH_YES
)
5124 if (gfc_match_char (',') != MATCH_YES
)
5129 gfc_error ("Syntax error in procedure pointer component at %C");
5134 /* Match a PROCEDURE declaration inside an interface (R1206). */
5137 match_procedure_in_interface (void)
5141 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5144 if (current_interface
.type
== INTERFACE_NAMELESS
5145 || current_interface
.type
== INTERFACE_ABSTRACT
)
5147 gfc_error ("PROCEDURE at %C must be in a generic interface");
5151 /* Check if the F2008 optional double colon appears. */
5152 gfc_gobble_whitespace ();
5153 old_locus
= gfc_current_locus
;
5154 if (gfc_match ("::") == MATCH_YES
)
5156 if (gfc_notify_std (GFC_STD_F2008
, "double colon in "
5157 "MODULE PROCEDURE statement at %L", &old_locus
)
5162 gfc_current_locus
= old_locus
;
5166 m
= gfc_match_name (name
);
5169 else if (m
== MATCH_ERROR
)
5171 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5174 if (gfc_add_interface (sym
) == FAILURE
)
5177 if (gfc_match_eos () == MATCH_YES
)
5179 if (gfc_match_char (',') != MATCH_YES
)
5186 gfc_error ("Syntax error in PROCEDURE statement at %C");
5191 /* General matcher for PROCEDURE declarations. */
5193 static match
match_procedure_in_type (void);
5196 gfc_match_procedure (void)
5200 switch (gfc_current_state ())
5205 case COMP_SUBROUTINE
:
5208 m
= match_procedure_decl ();
5210 case COMP_INTERFACE
:
5211 m
= match_procedure_in_interface ();
5214 m
= match_ppc_decl ();
5216 case COMP_DERIVED_CONTAINS
:
5217 m
= match_procedure_in_type ();
5226 if (gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C")
5234 /* Warn if a matched procedure has the same name as an intrinsic; this is
5235 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5236 parser-state-stack to find out whether we're in a module. */
5239 warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5243 in_module
= (gfc_state_stack
->previous
5244 && gfc_state_stack
->previous
->state
== COMP_MODULE
);
5246 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5250 /* Match a function declaration. */
5253 gfc_match_function_decl (void)
5255 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5256 gfc_symbol
*sym
, *result
;
5260 match found_match
; /* Status returned by match func. */
5262 if (gfc_current_state () != COMP_NONE
5263 && gfc_current_state () != COMP_INTERFACE
5264 && gfc_current_state () != COMP_CONTAINS
)
5267 gfc_clear_ts (¤t_ts
);
5269 old_loc
= gfc_current_locus
;
5271 m
= gfc_match_prefix (¤t_ts
);
5274 gfc_current_locus
= old_loc
;
5278 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5280 gfc_current_locus
= old_loc
;
5283 if (get_proc_name (name
, &sym
, false))
5286 if (add_hidden_procptr_result (sym
) == SUCCESS
)
5289 gfc_new_block
= sym
;
5291 m
= gfc_match_formal_arglist (sym
, 0, 0);
5294 gfc_error ("Expected formal argument list in function "
5295 "definition at %C");
5299 else if (m
== MATCH_ERROR
)
5304 /* According to the draft, the bind(c) and result clause can
5305 come in either order after the formal_arg_list (i.e., either
5306 can be first, both can exist together or by themselves or neither
5307 one). Therefore, the match_result can't match the end of the
5308 string, and check for the bind(c) or result clause in either order. */
5309 found_match
= gfc_match_eos ();
5311 /* Make sure that it isn't already declared as BIND(C). If it is, it
5312 must have been marked BIND(C) with a BIND(C) attribute and that is
5313 not allowed for procedures. */
5314 if (sym
->attr
.is_bind_c
== 1)
5316 sym
->attr
.is_bind_c
= 0;
5317 if (sym
->old_symbol
!= NULL
)
5318 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5319 "variables or common blocks",
5320 &(sym
->old_symbol
->declared_at
));
5322 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5323 "variables or common blocks", &gfc_current_locus
);
5326 if (found_match
!= MATCH_YES
)
5328 /* If we haven't found the end-of-statement, look for a suffix. */
5329 suffix_match
= gfc_match_suffix (sym
, &result
);
5330 if (suffix_match
== MATCH_YES
)
5331 /* Need to get the eos now. */
5332 found_match
= gfc_match_eos ();
5334 found_match
= suffix_match
;
5337 if(found_match
!= MATCH_YES
)
5341 /* Make changes to the symbol. */
5344 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
5347 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
5348 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
5351 /* Delay matching the function characteristics until after the
5352 specification block by signalling kind=-1. */
5353 sym
->declared_at
= old_loc
;
5354 if (current_ts
.type
!= BT_UNKNOWN
)
5355 current_ts
.kind
= -1;
5357 current_ts
.kind
= 0;
5361 if (current_ts
.type
!= BT_UNKNOWN
5362 && gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
) == FAILURE
)
5368 if (current_ts
.type
!= BT_UNKNOWN
5369 && gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
)
5372 sym
->result
= result
;
5375 /* Warn if this procedure has the same name as an intrinsic. */
5376 warn_intrinsic_shadow (sym
, true);
5382 gfc_current_locus
= old_loc
;
5387 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5388 pass the name of the entry, rather than the gfc_current_block name, and
5389 to return false upon finding an existing global entry. */
5392 add_global_entry (const char *name
, int sub
)
5395 enum gfc_symbol_type type
;
5397 s
= gfc_get_gsymbol(name
);
5398 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5401 || (s
->type
!= GSYM_UNKNOWN
5402 && s
->type
!= type
))
5403 gfc_global_used(s
, NULL
);
5407 s
->where
= gfc_current_locus
;
5409 s
->ns
= gfc_current_ns
;
5416 /* Match an ENTRY statement. */
5419 gfc_match_entry (void)
5424 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5425 gfc_compile_state state
;
5429 bool module_procedure
;
5433 m
= gfc_match_name (name
);
5437 if (gfc_notify_std (GFC_STD_F2008_OBS
,
5438 "ENTRY statement at %C") == FAILURE
)
5441 state
= gfc_current_state ();
5442 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5447 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5450 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5452 case COMP_BLOCK_DATA
:
5453 gfc_error ("ENTRY statement at %C cannot appear within "
5456 case COMP_INTERFACE
:
5457 gfc_error ("ENTRY statement at %C cannot appear within "
5461 gfc_error ("ENTRY statement at %C cannot appear within "
5462 "a DERIVED TYPE block");
5465 gfc_error ("ENTRY statement at %C cannot appear within "
5466 "an IF-THEN block");
5469 case COMP_DO_CONCURRENT
:
5470 gfc_error ("ENTRY statement at %C cannot appear within "
5474 gfc_error ("ENTRY statement at %C cannot appear within "
5478 gfc_error ("ENTRY statement at %C cannot appear within "
5482 gfc_error ("ENTRY statement at %C cannot appear within "
5486 gfc_error ("ENTRY statement at %C cannot appear within "
5487 "a contained subprogram");
5490 gfc_internal_error ("gfc_match_entry(): Bad state");
5495 module_procedure
= gfc_current_ns
->parent
!= NULL
5496 && gfc_current_ns
->parent
->proc_name
5497 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5500 if (gfc_current_ns
->parent
!= NULL
5501 && gfc_current_ns
->parent
->proc_name
5502 && !module_procedure
)
5504 gfc_error("ENTRY statement at %C cannot appear in a "
5505 "contained procedure");
5509 /* Module function entries need special care in get_proc_name
5510 because previous references within the function will have
5511 created symbols attached to the current namespace. */
5512 if (get_proc_name (name
, &entry
,
5513 gfc_current_ns
->parent
!= NULL
5514 && module_procedure
))
5517 proc
= gfc_current_block ();
5519 /* Make sure that it isn't already declared as BIND(C). If it is, it
5520 must have been marked BIND(C) with a BIND(C) attribute and that is
5521 not allowed for procedures. */
5522 if (entry
->attr
.is_bind_c
== 1)
5524 entry
->attr
.is_bind_c
= 0;
5525 if (entry
->old_symbol
!= NULL
)
5526 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5527 "variables or common blocks",
5528 &(entry
->old_symbol
->declared_at
));
5530 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5531 "variables or common blocks", &gfc_current_locus
);
5534 /* Check what next non-whitespace character is so we can tell if there
5535 is the required parens if we have a BIND(C). */
5536 gfc_gobble_whitespace ();
5537 peek_char
= gfc_peek_ascii_char ();
5539 if (state
== COMP_SUBROUTINE
)
5541 /* An entry in a subroutine. */
5542 if (!gfc_current_ns
->parent
&& !add_global_entry (name
, 1))
5545 m
= gfc_match_formal_arglist (entry
, 0, 1);
5549 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5550 never be an internal procedure. */
5551 is_bind_c
= gfc_match_bind_c (entry
, true);
5552 if (is_bind_c
== MATCH_ERROR
)
5554 if (is_bind_c
== MATCH_YES
)
5556 if (peek_char
!= '(')
5558 gfc_error ("Missing required parentheses before BIND(C) at %C");
5561 if (gfc_add_is_bind_c (&(entry
->attr
), entry
->name
, &(entry
->declared_at
), 1)
5566 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
5567 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
5572 /* An entry in a function.
5573 We need to take special care because writing
5578 ENTRY f() RESULT (r)
5580 ENTRY f RESULT (r). */
5581 if (!gfc_current_ns
->parent
&& !add_global_entry (name
, 0))
5584 old_loc
= gfc_current_locus
;
5585 if (gfc_match_eos () == MATCH_YES
)
5587 gfc_current_locus
= old_loc
;
5588 /* Match the empty argument list, and add the interface to
5590 m
= gfc_match_formal_arglist (entry
, 0, 1);
5593 m
= gfc_match_formal_arglist (entry
, 0, 0);
5600 if (gfc_match_eos () == MATCH_YES
)
5602 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
5603 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
5606 entry
->result
= entry
;
5610 m
= gfc_match_suffix (entry
, &result
);
5612 gfc_syntax_error (ST_ENTRY
);
5618 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
5619 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
5620 || gfc_add_function (&entry
->attr
, result
->name
, NULL
)
5623 entry
->result
= result
;
5627 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
5628 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
5630 entry
->result
= entry
;
5635 if (gfc_match_eos () != MATCH_YES
)
5637 gfc_syntax_error (ST_ENTRY
);
5641 entry
->attr
.recursive
= proc
->attr
.recursive
;
5642 entry
->attr
.elemental
= proc
->attr
.elemental
;
5643 entry
->attr
.pure
= proc
->attr
.pure
;
5645 el
= gfc_get_entry_list ();
5647 el
->next
= gfc_current_ns
->entries
;
5648 gfc_current_ns
->entries
= el
;
5650 el
->id
= el
->next
->id
+ 1;
5654 new_st
.op
= EXEC_ENTRY
;
5655 new_st
.ext
.entry
= el
;
5661 /* Match a subroutine statement, including optional prefixes. */
5664 gfc_match_subroutine (void)
5666 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5671 bool allow_binding_name
;
5673 if (gfc_current_state () != COMP_NONE
5674 && gfc_current_state () != COMP_INTERFACE
5675 && gfc_current_state () != COMP_CONTAINS
)
5678 m
= gfc_match_prefix (NULL
);
5682 m
= gfc_match ("subroutine% %n", name
);
5686 if (get_proc_name (name
, &sym
, false))
5689 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5690 the symbol existed before. */
5691 sym
->declared_at
= gfc_current_locus
;
5693 if (add_hidden_procptr_result (sym
) == SUCCESS
)
5696 gfc_new_block
= sym
;
5698 /* Check what next non-whitespace character is so we can tell if there
5699 is the required parens if we have a BIND(C). */
5700 gfc_gobble_whitespace ();
5701 peek_char
= gfc_peek_ascii_char ();
5703 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
5706 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5709 /* Make sure that it isn't already declared as BIND(C). If it is, it
5710 must have been marked BIND(C) with a BIND(C) attribute and that is
5711 not allowed for procedures. */
5712 if (sym
->attr
.is_bind_c
== 1)
5714 sym
->attr
.is_bind_c
= 0;
5715 if (sym
->old_symbol
!= NULL
)
5716 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5717 "variables or common blocks",
5718 &(sym
->old_symbol
->declared_at
));
5720 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5721 "variables or common blocks", &gfc_current_locus
);
5724 /* C binding names are not allowed for internal procedures. */
5725 if (gfc_current_state () == COMP_CONTAINS
5726 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5727 allow_binding_name
= false;
5729 allow_binding_name
= true;
5731 /* Here, we are just checking if it has the bind(c) attribute, and if
5732 so, then we need to make sure it's all correct. If it doesn't,
5733 we still need to continue matching the rest of the subroutine line. */
5734 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5735 if (is_bind_c
== MATCH_ERROR
)
5737 /* There was an attempt at the bind(c), but it was wrong. An
5738 error message should have been printed w/in the gfc_match_bind_c
5739 so here we'll just return the MATCH_ERROR. */
5743 if (is_bind_c
== MATCH_YES
)
5745 /* The following is allowed in the Fortran 2008 draft. */
5746 if (gfc_current_state () == COMP_CONTAINS
5747 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5748 && gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5749 "at %L may not be specified for an internal "
5750 "procedure", &gfc_current_locus
)
5754 if (peek_char
!= '(')
5756 gfc_error ("Missing required parentheses before BIND(C) at %C");
5759 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1)
5764 if (gfc_match_eos () != MATCH_YES
)
5766 gfc_syntax_error (ST_SUBROUTINE
);
5770 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
5773 /* Warn if it has the same name as an intrinsic. */
5774 warn_intrinsic_shadow (sym
, false);
5780 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
5781 given, and set the binding label in either the given symbol (if not
5782 NULL), or in the current_ts. The symbol may be NULL because we may
5783 encounter the BIND(C) before the declaration itself. Return
5784 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
5785 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
5786 or MATCH_YES if the specifier was correct and the binding label and
5787 bind(c) fields were set correctly for the given symbol or the
5788 current_ts. If allow_binding_name is false, no binding name may be
5792 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
5794 /* binding label, if exists */
5795 const char* binding_label
= NULL
;
5799 /* Initialize the flag that specifies whether we encountered a NAME=
5800 specifier or not. */
5801 has_name_equals
= 0;
5803 /* This much we have to be able to match, in this order, if
5804 there is a bind(c) label. */
5805 if (gfc_match (" bind ( c ") != MATCH_YES
)
5808 /* Now see if there is a binding label, or if we've reached the
5809 end of the bind(c) attribute without one. */
5810 if (gfc_match_char (',') == MATCH_YES
)
5812 if (gfc_match (" name = ") != MATCH_YES
)
5814 gfc_error ("Syntax error in NAME= specifier for binding label "
5816 /* should give an error message here */
5820 has_name_equals
= 1;
5822 /* Get the opening quote. */
5823 double_quote
= MATCH_YES
;
5824 single_quote
= MATCH_YES
;
5825 double_quote
= gfc_match_char ('"');
5826 if (double_quote
!= MATCH_YES
)
5827 single_quote
= gfc_match_char ('\'');
5828 if (double_quote
!= MATCH_YES
&& single_quote
!= MATCH_YES
)
5830 gfc_error ("Syntax error in NAME= specifier for binding label "
5835 /* Grab the binding label, using functions that will not lower
5836 case the names automatically. */
5837 if (gfc_match_name_C (&binding_label
) != MATCH_YES
)
5840 /* Get the closing quotation. */
5841 if (double_quote
== MATCH_YES
)
5843 if (gfc_match_char ('"') != MATCH_YES
)
5845 gfc_error ("Missing closing quote '\"' for binding label at %C");
5846 /* User started string with '"' so looked to match it. */
5852 if (gfc_match_char ('\'') != MATCH_YES
)
5854 gfc_error ("Missing closing quote '\'' for binding label at %C");
5855 /* User started string with "'" char. */
5861 /* Get the required right paren. */
5862 if (gfc_match_char (')') != MATCH_YES
)
5864 gfc_error ("Missing closing paren for binding label at %C");
5868 if (has_name_equals
&& !allow_binding_name
)
5870 gfc_error ("No binding name is allowed in BIND(C) at %C");
5874 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
5876 gfc_error ("For dummy procedure %s, no binding name is "
5877 "allowed in BIND(C) at %C", sym
->name
);
5882 /* Save the binding label to the symbol. If sym is null, we're
5883 probably matching the typespec attributes of a declaration and
5884 haven't gotten the name yet, and therefore, no symbol yet. */
5888 sym
->binding_label
= binding_label
;
5890 curr_binding_label
= binding_label
;
5892 else if (allow_binding_name
)
5894 /* No binding label, but if symbol isn't null, we
5895 can set the label for it here.
5896 If name="" or allow_binding_name is false, no C binding name is
5898 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
5899 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
5902 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
5903 && current_interface
.type
== INTERFACE_ABSTRACT
)
5905 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
5913 /* Return nonzero if we're currently compiling a contained procedure. */
5916 contained_procedure (void)
5918 gfc_state_data
*s
= gfc_state_stack
;
5920 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
5921 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
5927 /* Set the kind of each enumerator. The kind is selected such that it is
5928 interoperable with the corresponding C enumeration type, making
5929 sure that -fshort-enums is honored. */
5934 enumerator_history
*current_history
= NULL
;
5938 if (max_enum
== NULL
|| enum_history
== NULL
)
5941 if (!flag_short_enums
)
5947 kind
= gfc_integer_kinds
[i
++].kind
;
5949 while (kind
< gfc_c_int_kind
5950 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
5953 current_history
= enum_history
;
5954 while (current_history
!= NULL
)
5956 current_history
->sym
->ts
.kind
= kind
;
5957 current_history
= current_history
->next
;
5962 /* Match any of the various end-block statements. Returns the type of
5963 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
5964 and END BLOCK statements cannot be replaced by a single END statement. */
5967 gfc_match_end (gfc_statement
*st
)
5969 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5970 gfc_compile_state state
;
5972 const char *block_name
;
5976 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
5977 gfc_namespace
**nsp
;
5979 old_loc
= gfc_current_locus
;
5980 if (gfc_match ("end") != MATCH_YES
)
5983 state
= gfc_current_state ();
5984 block_name
= gfc_current_block () == NULL
5985 ? NULL
: gfc_current_block ()->name
;
5989 case COMP_ASSOCIATE
:
5991 if (!strncmp (block_name
, "block@", strlen("block@")))
5996 case COMP_DERIVED_CONTAINS
:
5997 state
= gfc_state_stack
->previous
->state
;
5998 block_name
= gfc_state_stack
->previous
->sym
== NULL
5999 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6010 *st
= ST_END_PROGRAM
;
6011 target
= " program";
6015 case COMP_SUBROUTINE
:
6016 *st
= ST_END_SUBROUTINE
;
6017 target
= " subroutine";
6018 eos_ok
= !contained_procedure ();
6022 *st
= ST_END_FUNCTION
;
6023 target
= " function";
6024 eos_ok
= !contained_procedure ();
6027 case COMP_BLOCK_DATA
:
6028 *st
= ST_END_BLOCK_DATA
;
6029 target
= " block data";
6034 *st
= ST_END_MODULE
;
6039 case COMP_INTERFACE
:
6040 *st
= ST_END_INTERFACE
;
6041 target
= " interface";
6046 case COMP_DERIVED_CONTAINS
:
6052 case COMP_ASSOCIATE
:
6053 *st
= ST_END_ASSOCIATE
;
6054 target
= " associate";
6071 case COMP_DO_CONCURRENT
:
6078 *st
= ST_END_CRITICAL
;
6079 target
= " critical";
6084 case COMP_SELECT_TYPE
:
6085 *st
= ST_END_SELECT
;
6091 *st
= ST_END_FORALL
;
6106 last_initializer
= NULL
;
6108 gfc_free_enum_history ();
6112 gfc_error ("Unexpected END statement at %C");
6116 if (gfc_match_eos () == MATCH_YES
)
6118 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6120 if (gfc_notify_std (GFC_STD_F2008
, "END statement "
6121 "instead of %s statement at %L",
6122 gfc_ascii_statement (*st
), &old_loc
) == FAILURE
)
6127 /* We would have required END [something]. */
6128 gfc_error ("%s statement expected at %L",
6129 gfc_ascii_statement (*st
), &old_loc
);
6136 /* Verify that we've got the sort of end-block that we're expecting. */
6137 if (gfc_match (target
) != MATCH_YES
)
6139 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
6143 /* If we're at the end, make sure a block name wasn't required. */
6144 if (gfc_match_eos () == MATCH_YES
)
6147 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6148 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6149 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6155 gfc_error ("Expected block name of '%s' in %s statement at %C",
6156 block_name
, gfc_ascii_statement (*st
));
6161 /* END INTERFACE has a special handler for its several possible endings. */
6162 if (*st
== ST_END_INTERFACE
)
6163 return gfc_match_end_interface ();
6165 /* We haven't hit the end of statement, so what is left must be an
6167 m
= gfc_match_space ();
6169 m
= gfc_match_name (name
);
6172 gfc_error ("Expected terminating name at %C");
6176 if (block_name
== NULL
)
6179 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6181 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
6182 gfc_ascii_statement (*st
));
6185 /* Procedure pointer as function result. */
6186 else if (strcmp (block_name
, "ppr@") == 0
6187 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6189 gfc_error ("Expected label '%s' for %s statement at %C",
6190 gfc_current_block ()->ns
->proc_name
->name
,
6191 gfc_ascii_statement (*st
));
6195 if (gfc_match_eos () == MATCH_YES
)
6199 gfc_syntax_error (*st
);
6202 gfc_current_locus
= old_loc
;
6204 /* If we are missing an END BLOCK, we created a half-ready namespace.
6205 Remove it from the parent namespace's sibling list. */
6207 if (state
== COMP_BLOCK
)
6209 parent_ns
= gfc_current_ns
->parent
;
6211 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6217 if (ns
== gfc_current_ns
)
6219 if (prev_ns
== NULL
)
6222 prev_ns
->sibling
= ns
->sibling
;
6228 gfc_free_namespace (gfc_current_ns
);
6229 gfc_current_ns
= parent_ns
;
6237 /***************** Attribute declaration statements ****************/
6239 /* Set the attribute of a single variable. */
6244 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6252 m
= gfc_match_name (name
);
6256 if (find_special (name
, &sym
, false))
6259 if (check_function_name (name
) == FAILURE
)
6265 var_locus
= gfc_current_locus
;
6267 /* Deal with possible array specification for certain attributes. */
6268 if (current_attr
.dimension
6269 || current_attr
.codimension
6270 || current_attr
.allocatable
6271 || current_attr
.pointer
6272 || current_attr
.target
)
6274 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6275 !current_attr
.dimension
6276 && !current_attr
.pointer
6277 && !current_attr
.target
);
6278 if (m
== MATCH_ERROR
)
6281 if (current_attr
.dimension
&& m
== MATCH_NO
)
6283 gfc_error ("Missing array specification at %L in DIMENSION "
6284 "statement", &var_locus
);
6289 if (current_attr
.dimension
&& sym
->value
)
6291 gfc_error ("Dimensions specified for %s at %L after its "
6292 "initialisation", sym
->name
, &var_locus
);
6297 if (current_attr
.codimension
&& m
== MATCH_NO
)
6299 gfc_error ("Missing array specification at %L in CODIMENSION "
6300 "statement", &var_locus
);
6305 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6306 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6308 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6314 /* Update symbol table. DIMENSION attribute is set in
6315 gfc_set_array_spec(). For CLASS variables, this must be applied
6316 to the first component, or '_data' field. */
6317 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6319 if (gfc_copy_attr (&CLASS_DATA (sym
)->attr
, ¤t_attr
, &var_locus
)
6328 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6329 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
) == FAILURE
)
6336 if (sym
->ts
.type
== BT_CLASS
6337 && gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
, false) == FAILURE
)
6343 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
6349 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6351 /* Fix the array spec. */
6352 m
= gfc_mod_pointee_as (sym
->as
);
6353 if (m
== MATCH_ERROR
)
6357 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
6363 if ((current_attr
.external
|| current_attr
.intrinsic
)
6364 && sym
->attr
.flavor
!= FL_PROCEDURE
6365 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
6371 add_hidden_procptr_result (sym
);
6376 gfc_free_array_spec (as
);
6381 /* Generic attribute declaration subroutine. Used for attributes that
6382 just have a list of names. */
6389 /* Gobble the optional double colon, by simply ignoring the result
6399 if (gfc_match_eos () == MATCH_YES
)
6405 if (gfc_match_char (',') != MATCH_YES
)
6407 gfc_error ("Unexpected character in variable list at %C");
6417 /* This routine matches Cray Pointer declarations of the form:
6418 pointer ( <pointer>, <pointee> )
6420 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6421 The pointer, if already declared, should be an integer. Otherwise, we
6422 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6423 be either a scalar, or an array declaration. No space is allocated for
6424 the pointee. For the statement
6425 pointer (ipt, ar(10))
6426 any subsequent uses of ar will be translated (in C-notation) as
6427 ar(i) => ((<type> *) ipt)(i)
6428 After gimplification, pointee variable will disappear in the code. */
6431 cray_pointer_decl (void)
6434 gfc_array_spec
*as
= NULL
;
6435 gfc_symbol
*cptr
; /* Pointer symbol. */
6436 gfc_symbol
*cpte
; /* Pointee symbol. */
6442 if (gfc_match_char ('(') != MATCH_YES
)
6444 gfc_error ("Expected '(' at %C");
6448 /* Match pointer. */
6449 var_locus
= gfc_current_locus
;
6450 gfc_clear_attr (¤t_attr
);
6451 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6452 current_ts
.type
= BT_INTEGER
;
6453 current_ts
.kind
= gfc_index_integer_kind
;
6455 m
= gfc_match_symbol (&cptr
, 0);
6458 gfc_error ("Expected variable name at %C");
6462 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
6465 gfc_set_sym_referenced (cptr
);
6467 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6469 cptr
->ts
.type
= BT_INTEGER
;
6470 cptr
->ts
.kind
= gfc_index_integer_kind
;
6472 else if (cptr
->ts
.type
!= BT_INTEGER
)
6474 gfc_error ("Cray pointer at %C must be an integer");
6477 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6478 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
6479 " memory addresses require %d bytes",
6480 cptr
->ts
.kind
, gfc_index_integer_kind
);
6482 if (gfc_match_char (',') != MATCH_YES
)
6484 gfc_error ("Expected \",\" at %C");
6488 /* Match Pointee. */
6489 var_locus
= gfc_current_locus
;
6490 gfc_clear_attr (¤t_attr
);
6491 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6492 current_ts
.type
= BT_UNKNOWN
;
6493 current_ts
.kind
= 0;
6495 m
= gfc_match_symbol (&cpte
, 0);
6498 gfc_error ("Expected variable name at %C");
6502 /* Check for an optional array spec. */
6503 m
= gfc_match_array_spec (&as
, true, false);
6504 if (m
== MATCH_ERROR
)
6506 gfc_free_array_spec (as
);
6509 else if (m
== MATCH_NO
)
6511 gfc_free_array_spec (as
);
6515 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
6518 gfc_set_sym_referenced (cpte
);
6520 if (cpte
->as
== NULL
)
6522 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
6523 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6525 else if (as
!= NULL
)
6527 gfc_error ("Duplicate array spec for Cray pointee at %C");
6528 gfc_free_array_spec (as
);
6534 if (cpte
->as
!= NULL
)
6536 /* Fix array spec. */
6537 m
= gfc_mod_pointee_as (cpte
->as
);
6538 if (m
== MATCH_ERROR
)
6542 /* Point the Pointee at the Pointer. */
6543 cpte
->cp_pointer
= cptr
;
6545 if (gfc_match_char (')') != MATCH_YES
)
6547 gfc_error ("Expected \")\" at %C");
6550 m
= gfc_match_char (',');
6552 done
= true; /* Stop searching for more declarations. */
6556 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6557 || gfc_match_eos () != MATCH_YES
)
6559 gfc_error ("Expected \",\" or end of statement at %C");
6567 gfc_match_external (void)
6570 gfc_clear_attr (¤t_attr
);
6571 current_attr
.external
= 1;
6573 return attr_decl ();
6578 gfc_match_intent (void)
6582 /* This is not allowed within a BLOCK construct! */
6583 if (gfc_current_state () == COMP_BLOCK
)
6585 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6589 intent
= match_intent_spec ();
6590 if (intent
== INTENT_UNKNOWN
)
6593 gfc_clear_attr (¤t_attr
);
6594 current_attr
.intent
= intent
;
6596 return attr_decl ();
6601 gfc_match_intrinsic (void)
6604 gfc_clear_attr (¤t_attr
);
6605 current_attr
.intrinsic
= 1;
6607 return attr_decl ();
6612 gfc_match_optional (void)
6614 /* This is not allowed within a BLOCK construct! */
6615 if (gfc_current_state () == COMP_BLOCK
)
6617 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6621 gfc_clear_attr (¤t_attr
);
6622 current_attr
.optional
= 1;
6624 return attr_decl ();
6629 gfc_match_pointer (void)
6631 gfc_gobble_whitespace ();
6632 if (gfc_peek_ascii_char () == '(')
6634 if (!gfc_option
.flag_cray_pointer
)
6636 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6640 return cray_pointer_decl ();
6644 gfc_clear_attr (¤t_attr
);
6645 current_attr
.pointer
= 1;
6647 return attr_decl ();
6653 gfc_match_allocatable (void)
6655 gfc_clear_attr (¤t_attr
);
6656 current_attr
.allocatable
= 1;
6658 return attr_decl ();
6663 gfc_match_codimension (void)
6665 gfc_clear_attr (¤t_attr
);
6666 current_attr
.codimension
= 1;
6668 return attr_decl ();
6673 gfc_match_contiguous (void)
6675 if (gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C")
6679 gfc_clear_attr (¤t_attr
);
6680 current_attr
.contiguous
= 1;
6682 return attr_decl ();
6687 gfc_match_dimension (void)
6689 gfc_clear_attr (¤t_attr
);
6690 current_attr
.dimension
= 1;
6692 return attr_decl ();
6697 gfc_match_target (void)
6699 gfc_clear_attr (¤t_attr
);
6700 current_attr
.target
= 1;
6702 return attr_decl ();
6706 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6710 access_attr_decl (gfc_statement st
)
6712 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6713 interface_type type
;
6715 gfc_symbol
*sym
, *dt_sym
;
6716 gfc_intrinsic_op op
;
6719 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6724 m
= gfc_match_generic_spec (&type
, name
, &op
);
6727 if (m
== MATCH_ERROR
)
6732 case INTERFACE_NAMELESS
:
6733 case INTERFACE_ABSTRACT
:
6736 case INTERFACE_GENERIC
:
6737 if (gfc_get_symbol (name
, NULL
, &sym
))
6740 if (gfc_add_access (&sym
->attr
, (st
== ST_PUBLIC
)
6741 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6742 sym
->name
, NULL
) == FAILURE
)
6745 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
6746 && gfc_add_access (&dt_sym
->attr
,
6747 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
6749 sym
->name
, NULL
) == FAILURE
)
6754 case INTERFACE_INTRINSIC_OP
:
6755 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
6757 gfc_intrinsic_op other_op
;
6759 gfc_current_ns
->operator_access
[op
] =
6760 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6762 /* Handle the case if there is another op with the same
6763 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
6764 other_op
= gfc_equivalent_op (op
);
6766 if (other_op
!= INTRINSIC_NONE
)
6767 gfc_current_ns
->operator_access
[other_op
] =
6768 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6773 gfc_error ("Access specification of the %s operator at %C has "
6774 "already been specified", gfc_op2string (op
));
6780 case INTERFACE_USER_OP
:
6781 uop
= gfc_get_uop (name
);
6783 if (uop
->access
== ACCESS_UNKNOWN
)
6785 uop
->access
= (st
== ST_PUBLIC
)
6786 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6790 gfc_error ("Access specification of the .%s. operator at %C "
6791 "has already been specified", sym
->name
);
6798 if (gfc_match_char (',') == MATCH_NO
)
6802 if (gfc_match_eos () != MATCH_YES
)
6807 gfc_syntax_error (st
);
6815 gfc_match_protected (void)
6820 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6822 gfc_error ("PROTECTED at %C only allowed in specification "
6823 "part of a module");
6828 if (gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C")
6832 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6837 if (gfc_match_eos () == MATCH_YES
)
6842 m
= gfc_match_symbol (&sym
, 0);
6846 if (gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
)
6859 if (gfc_match_eos () == MATCH_YES
)
6861 if (gfc_match_char (',') != MATCH_YES
)
6868 gfc_error ("Syntax error in PROTECTED statement at %C");
6873 /* The PRIVATE statement is a bit weird in that it can be an attribute
6874 declaration, but also works as a standalone statement inside of a
6875 type declaration or a module. */
6878 gfc_match_private (gfc_statement
*st
)
6881 if (gfc_match ("private") != MATCH_YES
)
6884 if (gfc_current_state () != COMP_MODULE
6885 && !(gfc_current_state () == COMP_DERIVED
6886 && gfc_state_stack
->previous
6887 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
6888 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
6889 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
6890 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
6892 gfc_error ("PRIVATE statement at %C is only allowed in the "
6893 "specification part of a module");
6897 if (gfc_current_state () == COMP_DERIVED
)
6899 if (gfc_match_eos () == MATCH_YES
)
6905 gfc_syntax_error (ST_PRIVATE
);
6909 if (gfc_match_eos () == MATCH_YES
)
6916 return access_attr_decl (ST_PRIVATE
);
6921 gfc_match_public (gfc_statement
*st
)
6924 if (gfc_match ("public") != MATCH_YES
)
6927 if (gfc_current_state () != COMP_MODULE
)
6929 gfc_error ("PUBLIC statement at %C is only allowed in the "
6930 "specification part of a module");
6934 if (gfc_match_eos () == MATCH_YES
)
6941 return access_attr_decl (ST_PUBLIC
);
6945 /* Workhorse for gfc_match_parameter. */
6955 m
= gfc_match_symbol (&sym
, 0);
6957 gfc_error ("Expected variable name at %C in PARAMETER statement");
6962 if (gfc_match_char ('=') == MATCH_NO
)
6964 gfc_error ("Expected = sign in PARAMETER statement at %C");
6968 m
= gfc_match_init_expr (&init
);
6970 gfc_error ("Expected expression at %C in PARAMETER statement");
6974 if (sym
->ts
.type
== BT_UNKNOWN
6975 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
6981 if (gfc_check_assign_symbol (sym
, NULL
, init
) == FAILURE
6982 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
6990 gfc_error ("Initializing already initialized variable at %C");
6995 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
6996 return (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
6999 gfc_free_expr (init
);
7004 /* Match a parameter statement, with the weird syntax that these have. */
7007 gfc_match_parameter (void)
7011 if (gfc_match_char ('(') == MATCH_NO
)
7020 if (gfc_match (" )%t") == MATCH_YES
)
7023 if (gfc_match_char (',') != MATCH_YES
)
7025 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7035 /* Save statements have a special syntax. */
7038 gfc_match_save (void)
7040 char n
[GFC_MAX_SYMBOL_LEN
+1];
7045 if (gfc_match_eos () == MATCH_YES
)
7047 if (gfc_current_ns
->seen_save
)
7049 if (gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7050 "follows previous SAVE statement")
7055 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7059 if (gfc_current_ns
->save_all
)
7061 if (gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7062 "blanket SAVE statement")
7071 m
= gfc_match_symbol (&sym
, 0);
7075 if (gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7076 &gfc_current_locus
) == FAILURE
)
7087 m
= gfc_match (" / %n /", &n
);
7088 if (m
== MATCH_ERROR
)
7093 c
= gfc_get_common (n
, 0);
7096 gfc_current_ns
->seen_save
= 1;
7099 if (gfc_match_eos () == MATCH_YES
)
7101 if (gfc_match_char (',') != MATCH_YES
)
7108 gfc_error ("Syntax error in SAVE statement at %C");
7114 gfc_match_value (void)
7119 /* This is not allowed within a BLOCK construct! */
7120 if (gfc_current_state () == COMP_BLOCK
)
7122 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7126 if (gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C")
7130 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7135 if (gfc_match_eos () == MATCH_YES
)
7140 m
= gfc_match_symbol (&sym
, 0);
7144 if (gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
)
7157 if (gfc_match_eos () == MATCH_YES
)
7159 if (gfc_match_char (',') != MATCH_YES
)
7166 gfc_error ("Syntax error in VALUE statement at %C");
7172 gfc_match_volatile (void)
7177 if (gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C")
7181 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7186 if (gfc_match_eos () == MATCH_YES
)
7191 /* VOLATILE is special because it can be added to host-associated
7192 symbols locally. Except for coarrays. */
7193 m
= gfc_match_symbol (&sym
, 1);
7197 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7198 for variable in a BLOCK which is defined outside of the BLOCK. */
7199 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7201 gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
7202 "%C, which is use-/host-associated", sym
->name
);
7205 if (gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
)
7218 if (gfc_match_eos () == MATCH_YES
)
7220 if (gfc_match_char (',') != MATCH_YES
)
7227 gfc_error ("Syntax error in VOLATILE statement at %C");
7233 gfc_match_asynchronous (void)
7238 if (gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C")
7242 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7247 if (gfc_match_eos () == MATCH_YES
)
7252 /* ASYNCHRONOUS is special because it can be added to host-associated
7254 m
= gfc_match_symbol (&sym
, 1);
7258 if (gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
)
7271 if (gfc_match_eos () == MATCH_YES
)
7273 if (gfc_match_char (',') != MATCH_YES
)
7280 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7285 /* Match a module procedure statement. Note that we have to modify
7286 symbols in the parent's namespace because the current one was there
7287 to receive symbols that are in an interface's formal argument list. */
7290 gfc_match_modproc (void)
7292 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7296 gfc_namespace
*module_ns
;
7297 gfc_interface
*old_interface_head
, *interface
;
7299 if (gfc_state_stack
->state
!= COMP_INTERFACE
7300 || gfc_state_stack
->previous
== NULL
7301 || current_interface
.type
== INTERFACE_NAMELESS
7302 || current_interface
.type
== INTERFACE_ABSTRACT
)
7304 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7309 module_ns
= gfc_current_ns
->parent
;
7310 for (; module_ns
; module_ns
= module_ns
->parent
)
7311 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7312 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7313 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7314 && !module_ns
->proc_name
->attr
.contained
))
7317 if (module_ns
== NULL
)
7320 /* Store the current state of the interface. We will need it if we
7321 end up with a syntax error and need to recover. */
7322 old_interface_head
= gfc_current_interface_head ();
7324 /* Check if the F2008 optional double colon appears. */
7325 gfc_gobble_whitespace ();
7326 old_locus
= gfc_current_locus
;
7327 if (gfc_match ("::") == MATCH_YES
)
7329 if (gfc_notify_std (GFC_STD_F2008
, "double colon in "
7330 "MODULE PROCEDURE statement at %L", &old_locus
)
7335 gfc_current_locus
= old_locus
;
7340 old_locus
= gfc_current_locus
;
7342 m
= gfc_match_name (name
);
7348 /* Check for syntax error before starting to add symbols to the
7349 current namespace. */
7350 if (gfc_match_eos () == MATCH_YES
)
7353 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7356 /* Now we're sure the syntax is valid, we process this item
7358 if (gfc_get_symbol (name
, module_ns
, &sym
))
7361 if (sym
->attr
.intrinsic
)
7363 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7364 "PROCEDURE", &old_locus
);
7368 if (sym
->attr
.proc
!= PROC_MODULE
7369 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
7370 sym
->name
, NULL
) == FAILURE
)
7373 if (gfc_add_interface (sym
) == FAILURE
)
7376 sym
->attr
.mod_proc
= 1;
7377 sym
->declared_at
= old_locus
;
7386 /* Restore the previous state of the interface. */
7387 interface
= gfc_current_interface_head ();
7388 gfc_set_current_interface_head (old_interface_head
);
7390 /* Free the new interfaces. */
7391 while (interface
!= old_interface_head
)
7393 gfc_interface
*i
= interface
->next
;
7398 /* And issue a syntax error. */
7399 gfc_syntax_error (ST_MODULE_PROC
);
7404 /* Check a derived type that is being extended. */
7407 check_extended_derived_type (char *name
)
7409 gfc_symbol
*extended
;
7411 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7413 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7417 extended
= gfc_find_dt_in_generic (extended
);
7422 gfc_error ("Symbol '%s' at %C has not been previously defined", name
);
7426 if (extended
->attr
.flavor
!= FL_DERIVED
)
7428 gfc_error ("'%s' in EXTENDS expression at %C is not a "
7429 "derived type", name
);
7433 if (extended
->attr
.is_bind_c
)
7435 gfc_error ("'%s' cannot be extended at %C because it "
7436 "is BIND(C)", extended
->name
);
7440 if (extended
->attr
.sequence
)
7442 gfc_error ("'%s' cannot be extended at %C because it "
7443 "is a SEQUENCE type", extended
->name
);
7451 /* Match the optional attribute specifiers for a type declaration.
7452 Return MATCH_ERROR if an error is encountered in one of the handled
7453 attributes (public, private, bind(c)), MATCH_NO if what's found is
7454 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7455 checking on attribute conflicts needs to be done. */
7458 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7460 /* See if the derived type is marked as private. */
7461 if (gfc_match (" , private") == MATCH_YES
)
7463 if (gfc_current_state () != COMP_MODULE
)
7465 gfc_error ("Derived type at %C can only be PRIVATE in the "
7466 "specification part of a module");
7470 if (gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
7473 else if (gfc_match (" , public") == MATCH_YES
)
7475 if (gfc_current_state () != COMP_MODULE
)
7477 gfc_error ("Derived type at %C can only be PUBLIC in the "
7478 "specification part of a module");
7482 if (gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
7485 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7487 /* If the type is defined to be bind(c) it then needs to make
7488 sure that all fields are interoperable. This will
7489 need to be a semantic check on the finished derived type.
7490 See 15.2.3 (lines 9-12) of F2003 draft. */
7491 if (gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0) != SUCCESS
)
7494 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7496 else if (gfc_match (" , abstract") == MATCH_YES
)
7498 if (gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C")
7502 if (gfc_add_abstract (attr
, &gfc_current_locus
) == FAILURE
)
7505 else if (name
&& gfc_match(" , extends ( %n )", name
) == MATCH_YES
)
7507 if (gfc_add_extension (attr
, &gfc_current_locus
) == FAILURE
)
7513 /* If we get here, something matched. */
7518 /* Match the beginning of a derived type declaration. If a type name
7519 was the result of a function, then it is possible to have a symbol
7520 already to be known as a derived type yet have no components. */
7523 gfc_match_derived_decl (void)
7525 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7526 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7527 symbol_attribute attr
;
7528 gfc_symbol
*sym
, *gensym
;
7529 gfc_symbol
*extended
;
7531 match is_type_attr_spec
= MATCH_NO
;
7532 bool seen_attr
= false;
7533 gfc_interface
*intr
= NULL
, *head
;
7535 if (gfc_current_state () == COMP_DERIVED
)
7540 gfc_clear_attr (&attr
);
7545 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7546 if (is_type_attr_spec
== MATCH_ERROR
)
7548 if (is_type_attr_spec
== MATCH_YES
)
7550 } while (is_type_attr_spec
== MATCH_YES
);
7552 /* Deal with derived type extensions. The extension attribute has
7553 been added to 'attr' but now the parent type must be found and
7556 extended
= check_extended_derived_type (parent
);
7558 if (parent
[0] && !extended
)
7561 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7563 gfc_error ("Expected :: in TYPE definition at %C");
7567 m
= gfc_match (" %n%t", name
);
7571 /* Make sure the name is not the name of an intrinsic type. */
7572 if (gfc_is_intrinsic_typename (name
))
7574 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
7579 if (gfc_get_symbol (name
, NULL
, &gensym
))
7582 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7584 gfc_error ("Derived type name '%s' at %C already has a basic type "
7585 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7589 if (!gensym
->attr
.generic
7590 && gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
) == FAILURE
)
7593 if (!gensym
->attr
.function
7594 && gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
) == FAILURE
)
7597 sym
= gfc_find_dt_in_generic (gensym
);
7599 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7601 gfc_error ("Derived type definition of '%s' at %C has already been "
7602 "defined", sym
->name
);
7608 /* Use upper case to save the actual derived-type symbol. */
7609 gfc_get_symbol (gfc_get_string ("%c%s",
7610 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7611 &gensym
->name
[1]), NULL
, &sym
);
7612 sym
->name
= gfc_get_string (gensym
->name
);
7613 head
= gensym
->generic
;
7614 intr
= gfc_get_interface ();
7616 intr
->where
= gfc_current_locus
;
7617 intr
->sym
->declared_at
= gfc_current_locus
;
7619 gensym
->generic
= intr
;
7620 gensym
->attr
.if_source
= IFSRC_DECL
;
7623 /* The symbol may already have the derived attribute without the
7624 components. The ways this can happen is via a function
7625 definition, an INTRINSIC statement or a subtype in another
7626 derived type that is a pointer. The first part of the AND clause
7627 is true if the symbol is not the return value of a function. */
7628 if (sym
->attr
.flavor
!= FL_DERIVED
7629 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
7632 if (attr
.access
!= ACCESS_UNKNOWN
7633 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
7635 else if (sym
->attr
.access
== ACCESS_UNKNOWN
7636 && gensym
->attr
.access
!= ACCESS_UNKNOWN
7637 && gfc_add_access (&sym
->attr
, gensym
->attr
.access
, sym
->name
, NULL
)
7641 if (sym
->attr
.access
!= ACCESS_UNKNOWN
7642 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
7643 gensym
->attr
.access
= sym
->attr
.access
;
7645 /* See if the derived type was labeled as bind(c). */
7646 if (attr
.is_bind_c
!= 0)
7647 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
7649 /* Construct the f2k_derived namespace if it is not yet there. */
7650 if (!sym
->f2k_derived
)
7651 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7653 if (extended
&& !sym
->components
)
7658 /* Add the extended derived type as the first component. */
7659 gfc_add_component (sym
, parent
, &p
);
7661 gfc_set_sym_referenced (extended
);
7663 p
->ts
.type
= BT_DERIVED
;
7664 p
->ts
.u
.derived
= extended
;
7665 p
->initializer
= gfc_default_initializer (&p
->ts
);
7667 /* Set extension level. */
7668 if (extended
->attr
.extension
== 255)
7670 /* Since the extension field is 8 bit wide, we can only have
7671 up to 255 extension levels. */
7672 gfc_error ("Maximum extension level reached with type '%s' at %L",
7673 extended
->name
, &extended
->declared_at
);
7676 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
7678 /* Provide the links between the extended type and its extension. */
7679 if (!extended
->f2k_derived
)
7680 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7681 st
= gfc_new_symtree (&extended
->f2k_derived
->sym_root
, sym
->name
);
7685 if (!sym
->hash_value
)
7686 /* Set the hash for the compound name for this type. */
7687 sym
->hash_value
= gfc_hash_value (sym
);
7689 /* Take over the ABSTRACT attribute. */
7690 sym
->attr
.abstract
= attr
.abstract
;
7692 gfc_new_block
= sym
;
7698 /* Cray Pointees can be declared as:
7699 pointer (ipt, a (n,m,...,*)) */
7702 gfc_mod_pointee_as (gfc_array_spec
*as
)
7704 as
->cray_pointee
= true; /* This will be useful to know later. */
7705 if (as
->type
== AS_ASSUMED_SIZE
)
7706 as
->cp_was_assumed
= true;
7707 else if (as
->type
== AS_ASSUMED_SHAPE
)
7709 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
7716 /* Match the enum definition statement, here we are trying to match
7717 the first line of enum definition statement.
7718 Returns MATCH_YES if match is found. */
7721 gfc_match_enum (void)
7725 m
= gfc_match_eos ();
7729 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
) == FAILURE
)
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
== SUCCESS
) ? 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"
8224 " at %C") == FAILURE
)
8227 /* Try to match the '=> target', if it's there. */
8229 m
= gfc_match (" =>");
8230 if (m
== MATCH_ERROR
)
8236 gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
8242 gfc_error ("'::' needed in PROCEDURE binding with explicit target"
8247 m
= gfc_match_name (target_buf
);
8248 if (m
== MATCH_ERROR
)
8252 gfc_error ("Expected binding target after '=>' at %C");
8255 target
= target_buf
;
8258 /* If no target was found, it has the same name as the binding. */
8262 /* Get the namespace to insert the symbols into. */
8263 ns
= block
->f2k_derived
;
8266 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8267 if (tb
.deferred
&& !block
->attr
.abstract
)
8269 gfc_error ("Type '%s' containing DEFERRED binding at %C "
8270 "is not ABSTRACT", block
->name
);
8274 /* See if we already have a binding with this name in the symtree which
8275 would be an error. If a GENERIC already targetted this binding, it may
8276 be already there but then typebound is still NULL. */
8277 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8278 if (stree
&& stree
->n
.tb
)
8280 gfc_error ("There is already a procedure with binding name '%s' for "
8281 "the derived type '%s' at %C", name
, block
->name
);
8285 /* Insert it and set attributes. */
8289 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8292 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8294 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8297 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8299 if (gfc_match_eos () == MATCH_YES
)
8301 if (gfc_match_char (',') != MATCH_YES
)
8306 gfc_error ("Syntax error in PROCEDURE statement at %C");
8311 /* Match a GENERIC procedure binding inside a derived type. */
8314 gfc_match_generic (void)
8316 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8317 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8319 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8320 gfc_typebound_proc
* tb
;
8322 interface_type op_type
;
8323 gfc_intrinsic_op op
;
8326 /* Check current state. */
8327 if (gfc_current_state () == COMP_DERIVED
)
8329 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8332 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8334 block
= gfc_state_stack
->previous
->sym
;
8335 ns
= block
->f2k_derived
;
8336 gcc_assert (block
&& ns
);
8338 memset (&tbattr
, 0, sizeof (tbattr
));
8339 tbattr
.where
= gfc_current_locus
;
8341 /* See if we get an access-specifier. */
8342 m
= match_binding_attributes (&tbattr
, true, false);
8343 if (m
== MATCH_ERROR
)
8346 /* Now the colons, those are required. */
8347 if (gfc_match (" ::") != MATCH_YES
)
8349 gfc_error ("Expected '::' at %C");
8353 /* Match the binding name; depending on type (operator / generic) format
8354 it for future error messages into bind_name. */
8356 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8357 if (m
== MATCH_ERROR
)
8361 gfc_error ("Expected generic name or operator descriptor at %C");
8367 case INTERFACE_GENERIC
:
8368 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8371 case INTERFACE_USER_OP
:
8372 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8375 case INTERFACE_INTRINSIC_OP
:
8376 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8377 gfc_op2string (op
));
8384 /* Match the required =>. */
8385 if (gfc_match (" =>") != MATCH_YES
)
8387 gfc_error ("Expected '=>' at %C");
8391 /* Try to find existing GENERIC binding with this name / for this operator;
8392 if there is something, check that it is another GENERIC and then extend
8393 it rather than building a new node. Otherwise, create it and put it
8394 at the right position. */
8398 case INTERFACE_USER_OP
:
8399 case INTERFACE_GENERIC
:
8401 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8404 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8416 case INTERFACE_INTRINSIC_OP
:
8426 if (!tb
->is_generic
)
8428 gcc_assert (op_type
== INTERFACE_GENERIC
);
8429 gfc_error ("There's already a non-generic procedure with binding name"
8430 " '%s' for the derived type '%s' at %C",
8431 bind_name
, block
->name
);
8435 if (tb
->access
!= tbattr
.access
)
8437 gfc_error ("Binding at %C must have the same access as already"
8438 " defined binding '%s'", bind_name
);
8444 tb
= gfc_get_typebound_proc (NULL
);
8445 tb
->where
= gfc_current_locus
;
8446 tb
->access
= tbattr
.access
;
8448 tb
->u
.generic
= NULL
;
8452 case INTERFACE_GENERIC
:
8453 case INTERFACE_USER_OP
:
8455 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8458 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8466 case INTERFACE_INTRINSIC_OP
:
8475 /* Now, match all following names as specific targets. */
8478 gfc_symtree
* target_st
;
8479 gfc_tbp_generic
* target
;
8481 m
= gfc_match_name (name
);
8482 if (m
== MATCH_ERROR
)
8486 gfc_error ("Expected specific binding name at %C");
8490 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8492 /* See if this is a duplicate specification. */
8493 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8494 if (target_st
== target
->specific_st
)
8496 gfc_error ("'%s' already defined as specific binding for the"
8497 " generic '%s' at %C", name
, bind_name
);
8501 target
= gfc_get_tbp_generic ();
8502 target
->specific_st
= target_st
;
8503 target
->specific
= NULL
;
8504 target
->next
= tb
->u
.generic
;
8505 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8506 || (op_type
== INTERFACE_INTRINSIC_OP
));
8507 tb
->u
.generic
= target
;
8509 while (gfc_match (" ,") == MATCH_YES
);
8511 /* Here should be the end. */
8512 if (gfc_match_eos () != MATCH_YES
)
8514 gfc_error ("Junk after GENERIC binding at %C");
8525 /* Match a FINAL declaration inside a derived type. */
8528 gfc_match_final_decl (void)
8530 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8533 gfc_namespace
* module_ns
;
8537 if (gfc_current_form
== FORM_FREE
)
8539 char c
= gfc_peek_ascii_char ();
8540 if (!gfc_is_whitespace (c
) && c
!= ':')
8544 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8546 if (gfc_current_form
== FORM_FIXED
)
8549 gfc_error ("FINAL declaration at %C must be inside a derived type "
8550 "CONTAINS section");
8554 block
= gfc_state_stack
->previous
->sym
;
8557 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8558 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8560 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8561 " specification part of a MODULE");
8565 module_ns
= gfc_current_ns
;
8566 gcc_assert (module_ns
);
8567 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8569 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8570 if (gfc_match (" ::") == MATCH_ERROR
)
8573 /* Match the sequence of procedure names. */
8580 if (first
&& gfc_match_eos () == MATCH_YES
)
8582 gfc_error ("Empty FINAL at %C");
8586 m
= gfc_match_name (name
);
8589 gfc_error ("Expected module procedure name at %C");
8592 else if (m
!= MATCH_YES
)
8595 if (gfc_match_eos () == MATCH_YES
)
8597 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8599 gfc_error ("Expected ',' at %C");
8603 if (gfc_get_symbol (name
, module_ns
, &sym
))
8605 gfc_error ("Unknown procedure name \"%s\" at %C", name
);
8609 /* Mark the symbol as module procedure. */
8610 if (sym
->attr
.proc
!= PROC_MODULE
8611 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
8612 sym
->name
, NULL
) == FAILURE
)
8615 /* Check if we already have this symbol in the list, this is an error. */
8616 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8617 if (f
->proc_sym
== sym
)
8619 gfc_error ("'%s' at %C is already defined as FINAL procedure!",
8624 /* Add this symbol to the list of finalizers. */
8625 gcc_assert (block
->f2k_derived
);
8627 f
= XCNEW (gfc_finalizer
);
8629 f
->proc_tree
= NULL
;
8630 f
->where
= gfc_current_locus
;
8631 f
->next
= block
->f2k_derived
->finalizers
;
8632 block
->f2k_derived
->finalizers
= f
;
8642 const ext_attr_t ext_attr_list
[] = {
8643 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
8644 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
8645 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
8646 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
8647 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
8648 { NULL
, EXT_ATTR_LAST
, NULL
}
8651 /* Match a !GCC$ ATTRIBUTES statement of the form:
8652 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
8653 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
8655 TODO: We should support all GCC attributes using the same syntax for
8656 the attribute list, i.e. the list in C
8657 __attributes(( attribute-list ))
8659 !GCC$ ATTRIBUTES attribute-list ::
8660 Cf. c-parser.c's c_parser_attributes; the data can then directly be
8663 As there is absolutely no risk of confusion, we should never return
8666 gfc_match_gcc_attributes (void)
8668 symbol_attribute attr
;
8669 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8674 gfc_clear_attr (&attr
);
8679 if (gfc_match_name (name
) != MATCH_YES
)
8682 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
8683 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
8686 if (id
== EXT_ATTR_LAST
)
8688 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
8692 if (gfc_add_ext_attribute (&attr
, (ext_attr_id_t
) id
, &gfc_current_locus
)
8696 gfc_gobble_whitespace ();
8697 ch
= gfc_next_ascii_char ();
8700 /* This is the successful exit condition for the loop. */
8701 if (gfc_next_ascii_char () == ':')
8711 if (gfc_match_eos () == MATCH_YES
)
8716 m
= gfc_match_name (name
);
8720 if (find_special (name
, &sym
, true))
8723 sym
->attr
.ext_attr
|= attr
.ext_attr
;
8725 if (gfc_match_eos () == MATCH_YES
)
8728 if (gfc_match_char (',') != MATCH_YES
)
8735 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");