1 /* Declaration statement matcher
2 Copyright (C) 2002-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
33 /* Macros to access allocate memory for gfc_data_variable,
34 gfc_data_value and gfc_data. */
35 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
36 #define gfc_get_data_value() XCNEW (gfc_data_value)
37 #define gfc_get_data() XCNEW (gfc_data)
40 static bool set_binding_label (const char **, const char *, int);
43 /* This flag is set if an old-style length selector is matched
44 during a type-declaration statement. */
46 static int old_char_selector
;
48 /* When variables acquire types and attributes from a declaration
49 statement, they get them from the following static variables. The
50 first part of a declaration sets these variables and the second
51 part copies these into symbol structures. */
53 static gfc_typespec current_ts
;
55 static symbol_attribute current_attr
;
56 static gfc_array_spec
*current_as
;
57 static int colon_seen
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
99 /********************* DATA statement subroutines *********************/
101 static bool in_match_data
= false;
104 gfc_in_match_data (void)
106 return in_match_data
;
110 set_in_match_data (bool set_value
)
112 in_match_data
= set_value
;
115 /* Free a gfc_data_variable structure and everything beneath it. */
118 free_variable (gfc_data_variable
*p
)
120 gfc_data_variable
*q
;
125 gfc_free_expr (p
->expr
);
126 gfc_free_iterator (&p
->iter
, 0);
127 free_variable (p
->list
);
133 /* Free a gfc_data_value structure and everything beneath it. */
136 free_value (gfc_data_value
*p
)
143 mpz_clear (p
->repeat
);
144 gfc_free_expr (p
->expr
);
150 /* Free a list of gfc_data structures. */
153 gfc_free_data (gfc_data
*p
)
160 free_variable (p
->var
);
161 free_value (p
->value
);
167 /* Free all data in a namespace. */
170 gfc_free_data_all (gfc_namespace
*ns
)
182 /* Reject data parsed since the last restore point was marked. */
185 gfc_reject_data (gfc_namespace
*ns
)
189 while (ns
->data
&& ns
->data
!= ns
->old_data
)
197 static match
var_element (gfc_data_variable
*);
199 /* Match a list of variables terminated by an iterator and a right
203 var_list (gfc_data_variable
*parent
)
205 gfc_data_variable
*tail
, var
;
208 m
= var_element (&var
);
209 if (m
== MATCH_ERROR
)
214 tail
= gfc_get_data_variable ();
221 if (gfc_match_char (',') != MATCH_YES
)
224 m
= gfc_match_iterator (&parent
->iter
, 1);
227 if (m
== MATCH_ERROR
)
230 m
= var_element (&var
);
231 if (m
== MATCH_ERROR
)
236 tail
->next
= gfc_get_data_variable ();
242 if (gfc_match_char (')') != MATCH_YES
)
247 gfc_syntax_error (ST_DATA
);
252 /* Match a single element in a data variable list, which can be a
253 variable-iterator list. */
256 var_element (gfc_data_variable
*new_var
)
261 memset (new_var
, 0, sizeof (gfc_data_variable
));
263 if (gfc_match_char ('(') == MATCH_YES
)
264 return var_list (new_var
);
266 m
= gfc_match_variable (&new_var
->expr
, 0);
270 sym
= new_var
->expr
->symtree
->n
.sym
;
272 /* Symbol should already have an associated type. */
273 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
276 if (!sym
->attr
.function
&& gfc_current_ns
->parent
277 && gfc_current_ns
->parent
== sym
->ns
)
279 gfc_error ("Host associated variable %qs may not be in the DATA "
280 "statement at %C", sym
->name
);
284 if (gfc_current_state () != COMP_BLOCK_DATA
285 && sym
->attr
.in_common
286 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
287 "common block variable %qs in DATA statement at %C",
291 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
298 /* Match the top-level list of data variables. */
301 top_var_list (gfc_data
*d
)
303 gfc_data_variable var
, *tail
, *new_var
;
310 m
= var_element (&var
);
313 if (m
== MATCH_ERROR
)
316 new_var
= gfc_get_data_variable ();
322 tail
->next
= new_var
;
326 if (gfc_match_char ('/') == MATCH_YES
)
328 if (gfc_match_char (',') != MATCH_YES
)
335 gfc_syntax_error (ST_DATA
);
336 gfc_free_data_all (gfc_current_ns
);
342 match_data_constant (gfc_expr
**result
)
344 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
345 gfc_symbol
*sym
, *dt_sym
= NULL
;
350 m
= gfc_match_literal_constant (&expr
, 1);
357 if (m
== MATCH_ERROR
)
360 m
= gfc_match_null (result
);
364 old_loc
= gfc_current_locus
;
366 /* Should this be a structure component, try to match it
367 before matching a name. */
368 m
= gfc_match_rvalue (result
);
369 if (m
== MATCH_ERROR
)
372 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
374 if (!gfc_simplify_expr (*result
, 0))
378 else if (m
== MATCH_YES
)
379 gfc_free_expr (*result
);
381 gfc_current_locus
= old_loc
;
383 m
= gfc_match_name (name
);
387 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
390 if (sym
&& sym
->attr
.generic
)
391 dt_sym
= gfc_find_dt_in_generic (sym
);
394 || (sym
->attr
.flavor
!= FL_PARAMETER
395 && (!dt_sym
|| dt_sym
->attr
.flavor
!= FL_DERIVED
)))
397 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
401 else if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
)
402 return gfc_match_structure_constructor (dt_sym
, result
);
404 /* Check to see if the value is an initialization array expression. */
405 if (sym
->value
->expr_type
== EXPR_ARRAY
)
407 gfc_current_locus
= old_loc
;
409 m
= gfc_match_init_expr (result
);
410 if (m
== MATCH_ERROR
)
415 if (!gfc_simplify_expr (*result
, 0))
418 if ((*result
)->expr_type
== EXPR_CONSTANT
)
422 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
428 *result
= gfc_copy_expr (sym
->value
);
433 /* Match a list of values in a DATA statement. The leading '/' has
434 already been seen at this point. */
437 top_val_list (gfc_data
*data
)
439 gfc_data_value
*new_val
, *tail
;
447 m
= match_data_constant (&expr
);
450 if (m
== MATCH_ERROR
)
453 new_val
= gfc_get_data_value ();
454 mpz_init (new_val
->repeat
);
457 data
->value
= new_val
;
459 tail
->next
= new_val
;
463 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
466 mpz_set_ui (tail
->repeat
, 1);
470 mpz_set (tail
->repeat
, expr
->value
.integer
);
471 gfc_free_expr (expr
);
473 m
= match_data_constant (&tail
->expr
);
476 if (m
== MATCH_ERROR
)
480 if (gfc_match_char ('/') == MATCH_YES
)
482 if (gfc_match_char (',') == MATCH_NO
)
489 gfc_syntax_error (ST_DATA
);
490 gfc_free_data_all (gfc_current_ns
);
495 /* Matches an old style initialization. */
498 match_old_style_init (const char *name
)
505 /* Set up data structure to hold initializers. */
506 gfc_find_sym_tree (name
, NULL
, 0, &st
);
509 newdata
= gfc_get_data ();
510 newdata
->var
= gfc_get_data_variable ();
511 newdata
->var
->expr
= gfc_get_variable_expr (st
);
512 newdata
->where
= gfc_current_locus
;
514 /* Match initial value list. This also eats the terminal '/'. */
515 m
= top_val_list (newdata
);
524 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
528 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
530 /* Mark the variable as having appeared in a data statement. */
531 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
537 /* Chain in namespace list of DATA initializers. */
538 newdata
->next
= gfc_current_ns
->data
;
539 gfc_current_ns
->data
= newdata
;
545 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
546 we are matching a DATA statement and are therefore issuing an error
547 if we encounter something unexpected, if not, we're trying to match
548 an old-style initialization expression of the form INTEGER I /2/. */
551 gfc_match_data (void)
556 set_in_match_data (true);
560 new_data
= gfc_get_data ();
561 new_data
->where
= gfc_current_locus
;
563 m
= top_var_list (new_data
);
567 m
= top_val_list (new_data
);
571 new_data
->next
= gfc_current_ns
->data
;
572 gfc_current_ns
->data
= new_data
;
574 if (gfc_match_eos () == MATCH_YES
)
577 gfc_match_char (','); /* Optional comma */
580 set_in_match_data (false);
584 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
587 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
592 set_in_match_data (false);
593 gfc_free_data (new_data
);
598 /************************ Declaration statements *********************/
601 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
604 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
608 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
609 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
611 gfc_error ("The assumed-rank array at %C shall not have a codimension");
615 if (to
->rank
== 0 && from
->rank
> 0)
617 to
->rank
= from
->rank
;
618 to
->type
= from
->type
;
619 to
->cray_pointee
= from
->cray_pointee
;
620 to
->cp_was_assumed
= from
->cp_was_assumed
;
622 for (i
= 0; i
< to
->corank
; i
++)
624 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
625 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
627 for (i
= 0; i
< from
->rank
; i
++)
631 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
632 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
636 to
->lower
[i
] = from
->lower
[i
];
637 to
->upper
[i
] = from
->upper
[i
];
641 else if (to
->corank
== 0 && from
->corank
> 0)
643 to
->corank
= from
->corank
;
644 to
->cotype
= from
->cotype
;
646 for (i
= 0; i
< from
->corank
; i
++)
650 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
651 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
655 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
656 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
665 /* Match an intent specification. Since this can only happen after an
666 INTENT word, a legal intent-spec must follow. */
669 match_intent_spec (void)
672 if (gfc_match (" ( in out )") == MATCH_YES
)
674 if (gfc_match (" ( in )") == MATCH_YES
)
676 if (gfc_match (" ( out )") == MATCH_YES
)
679 gfc_error ("Bad INTENT specification at %C");
680 return INTENT_UNKNOWN
;
684 /* Matches a character length specification, which is either a
685 specification expression, '*', or ':'. */
688 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
695 if (gfc_match_char ('*') == MATCH_YES
)
698 if (gfc_match_char (':') == MATCH_YES
)
700 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
708 m
= gfc_match_expr (expr
);
710 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
713 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
716 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
718 if ((*expr
)->ts
.type
== BT_INTEGER
719 || ((*expr
)->ts
.type
== BT_UNKNOWN
720 && strcmp((*expr
)->symtree
->name
, "null") != 0))
725 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
727 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
728 processor dependent and its value is greater than or equal to zero.
729 F2008, 4.4.3.2: If the character length parameter value evaluates
730 to a negative value, the length of character entities declared
733 if ((*expr
)->ts
.type
== BT_INTEGER
)
735 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
736 mpz_set_si ((*expr
)->value
.integer
, 0);
741 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
743 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
747 e
= gfc_copy_expr (*expr
);
749 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
750 which causes an ICE if gfc_reduce_init_expr() is called. */
751 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
752 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
753 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
756 gfc_reduce_init_expr (e
);
758 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
759 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
760 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
772 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
777 /* A character length is a '*' followed by a literal integer or a
778 char_len_param_value in parenthesis. */
781 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
787 m
= gfc_match_char ('*');
791 m
= gfc_match_small_literal_int (&length
, NULL
);
792 if (m
== MATCH_ERROR
)
797 if (obsolescent_check
798 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
800 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
804 if (gfc_match_char ('(') == MATCH_NO
)
807 m
= char_len_param_value (expr
, deferred
);
808 if (m
!= MATCH_YES
&& gfc_matching_function
)
814 if (m
== MATCH_ERROR
)
819 if (gfc_match_char (')') == MATCH_NO
)
821 gfc_free_expr (*expr
);
829 gfc_error ("Syntax error in character length specification at %C");
834 /* Special subroutine for finding a symbol. Check if the name is found
835 in the current name space. If not, and we're compiling a function or
836 subroutine and the parent compilation unit is an interface, then check
837 to see if the name we've been given is the name of the interface
838 (located in another namespace). */
841 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
847 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
850 *result
= st
? st
->n
.sym
: NULL
;
854 if (gfc_current_state () != COMP_SUBROUTINE
855 && gfc_current_state () != COMP_FUNCTION
)
858 s
= gfc_state_stack
->previous
;
862 if (s
->state
!= COMP_INTERFACE
)
865 goto end
; /* Nameless interface. */
867 if (strcmp (name
, s
->sym
->name
) == 0)
878 /* Special subroutine for getting a symbol node associated with a
879 procedure name, used in SUBROUTINE and FUNCTION statements. The
880 symbol is created in the parent using with symtree node in the
881 child unit pointing to the symbol. If the current namespace has no
882 parent, then the symbol is just created in the current unit. */
885 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
891 /* Module functions have to be left in their own namespace because
892 they have potentially (almost certainly!) already been referenced.
893 In this sense, they are rather like external functions. This is
894 fixed up in resolve.c(resolve_entries), where the symbol name-
895 space is set to point to the master function, so that the fake
896 result mechanism can work. */
897 if (module_fcn_entry
)
899 /* Present if entry is declared to be a module procedure. */
900 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
903 rc
= gfc_get_symbol (name
, NULL
, result
);
904 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
905 && (*result
)->ts
.type
== BT_UNKNOWN
906 && sym
->attr
.flavor
== FL_UNKNOWN
)
907 /* Pick up the typespec for the entry, if declared in the function
908 body. Note that this symbol is FL_UNKNOWN because it will
909 only have appeared in a type declaration. The local symtree
910 is set to point to the module symbol and a unique symtree
911 to the local version. This latter ensures a correct clearing
914 /* If the ENTRY proceeds its specification, we need to ensure
915 that this does not raise a "has no IMPLICIT type" error. */
916 if (sym
->ts
.type
== BT_UNKNOWN
)
917 sym
->attr
.untyped
= 1;
919 (*result
)->ts
= sym
->ts
;
921 /* Put the symbol in the procedure namespace so that, should
922 the ENTRY precede its specification, the specification
924 (*result
)->ns
= gfc_current_ns
;
926 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
928 st
= gfc_get_unique_symtree (gfc_current_ns
);
933 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
939 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
942 if (sym
->attr
.module_procedure
943 && sym
->attr
.if_source
== IFSRC_IFBODY
)
945 /* Create a partially populated interface symbol to carry the
946 characteristics of the procedure and the result. */
947 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
948 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
950 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
951 if (sym
->attr
.dimension
)
952 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
954 /* Ideally, at this point, a copy would be made of the formal
955 arguments and their namespace. However, this does not appear
956 to be necessary, albeit at the expense of not being able to
957 use gfc_compare_interfaces directly. */
959 if (sym
->result
&& sym
->result
!= sym
)
961 sym
->ts
.interface
->result
= sym
->result
;
964 else if (sym
->result
)
966 sym
->ts
.interface
->result
= sym
->ts
.interface
;
969 else if (sym
&& !sym
->gfc_new
970 && gfc_current_state () != COMP_INTERFACE
)
972 /* Trap another encompassed procedure with the same name. All
973 these conditions are necessary to avoid picking up an entry
974 whose name clashes with that of the encompassing procedure;
975 this is handled using gsymbols to register unique,globally
977 if (sym
->attr
.flavor
!= 0
978 && sym
->attr
.proc
!= 0
979 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
980 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
981 gfc_error_now ("Procedure %qs at %C is already defined at %L",
982 name
, &sym
->declared_at
);
984 /* Trap a procedure with a name the same as interface in the
985 encompassing scope. */
986 if (sym
->attr
.generic
!= 0
987 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
988 && !sym
->attr
.mod_proc
)
989 gfc_error_now ("Name %qs at %C is already defined"
990 " as a generic interface at %L",
991 name
, &sym
->declared_at
);
993 /* Trap declarations of attributes in encompassing scope. The
994 signature for this is that ts.kind is set. Legitimate
995 references only set ts.type. */
996 if (sym
->ts
.kind
!= 0
997 && !sym
->attr
.implicit_type
998 && sym
->attr
.proc
== 0
999 && gfc_current_ns
->parent
!= NULL
1000 && sym
->attr
.access
== 0
1001 && !module_fcn_entry
)
1002 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1003 "and must not have attributes declared at %L",
1004 name
, &sym
->declared_at
);
1007 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1010 /* Module function entries will already have a symtree in
1011 the current namespace but will need one at module level. */
1012 if (module_fcn_entry
)
1014 /* Present if entry is declared to be a module procedure. */
1015 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1017 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1020 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1025 /* See if the procedure should be a module procedure. */
1027 if (((sym
->ns
->proc_name
!= NULL
1028 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1029 && sym
->attr
.proc
!= PROC_MODULE
)
1030 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1031 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1038 /* Verify that the given symbol representing a parameter is C
1039 interoperable, by checking to see if it was marked as such after
1040 its declaration. If the given symbol is not interoperable, a
1041 warning is reported, thus removing the need to return the status to
1042 the calling function. The standard does not require the user use
1043 one of the iso_c_binding named constants to declare an
1044 interoperable parameter, but we can't be sure if the param is C
1045 interop or not if the user doesn't. For example, integer(4) may be
1046 legal Fortran, but doesn't have meaning in C. It may interop with
1047 a number of the C types, which causes a problem because the
1048 compiler can't know which one. This code is almost certainly not
1049 portable, and the user will get what they deserve if the C type
1050 across platforms isn't always interoperable with integer(4). If
1051 the user had used something like integer(c_int) or integer(c_long),
1052 the compiler could have automatically handled the varying sizes
1053 across platforms. */
1056 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1058 int is_c_interop
= 0;
1061 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1062 Don't repeat the checks here. */
1063 if (sym
->attr
.implicit_type
)
1066 /* For subroutines or functions that are passed to a BIND(C) procedure,
1067 they're interoperable if they're BIND(C) and their params are all
1069 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1071 if (sym
->attr
.is_bind_c
== 0)
1073 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1074 "attribute to be C interoperable", sym
->name
,
1075 &(sym
->declared_at
));
1080 if (sym
->attr
.is_c_interop
== 1)
1081 /* We've already checked this procedure; don't check it again. */
1084 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1089 /* See if we've stored a reference to a procedure that owns sym. */
1090 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1092 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1094 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1096 if (is_c_interop
!= 1)
1098 /* Make personalized messages to give better feedback. */
1099 if (sym
->ts
.type
== BT_DERIVED
)
1100 gfc_error ("Variable %qs at %L is a dummy argument to the "
1101 "BIND(C) procedure %qs but is not C interoperable "
1102 "because derived type %qs is not C interoperable",
1103 sym
->name
, &(sym
->declared_at
),
1104 sym
->ns
->proc_name
->name
,
1105 sym
->ts
.u
.derived
->name
);
1106 else if (sym
->ts
.type
== BT_CLASS
)
1107 gfc_error ("Variable %qs at %L is a dummy argument to the "
1108 "BIND(C) procedure %qs but is not C interoperable "
1109 "because it is polymorphic",
1110 sym
->name
, &(sym
->declared_at
),
1111 sym
->ns
->proc_name
->name
);
1112 else if (warn_c_binding_type
)
1113 gfc_warning (OPT_Wc_binding_type
,
1114 "Variable %qs at %L is a dummy argument of the "
1115 "BIND(C) procedure %qs but may not be C "
1117 sym
->name
, &(sym
->declared_at
),
1118 sym
->ns
->proc_name
->name
);
1121 /* Character strings are only C interoperable if they have a
1123 if (sym
->ts
.type
== BT_CHARACTER
)
1125 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1126 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1127 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1129 gfc_error ("Character argument %qs at %L "
1130 "must be length 1 because "
1131 "procedure %qs is BIND(C)",
1132 sym
->name
, &sym
->declared_at
,
1133 sym
->ns
->proc_name
->name
);
1138 /* We have to make sure that any param to a bind(c) routine does
1139 not have the allocatable, pointer, or optional attributes,
1140 according to J3/04-007, section 5.1. */
1141 if (sym
->attr
.allocatable
== 1
1142 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1143 "ALLOCATABLE attribute in procedure %qs "
1144 "with BIND(C)", sym
->name
,
1145 &(sym
->declared_at
),
1146 sym
->ns
->proc_name
->name
))
1149 if (sym
->attr
.pointer
== 1
1150 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1151 "POINTER attribute in procedure %qs "
1152 "with BIND(C)", sym
->name
,
1153 &(sym
->declared_at
),
1154 sym
->ns
->proc_name
->name
))
1157 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1159 gfc_error ("Scalar variable %qs at %L with POINTER or "
1160 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1161 " supported", sym
->name
, &(sym
->declared_at
),
1162 sym
->ns
->proc_name
->name
);
1166 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1168 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1169 "and the VALUE attribute because procedure %qs "
1170 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1171 sym
->ns
->proc_name
->name
);
1174 else if (sym
->attr
.optional
== 1
1175 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1176 "at %L with OPTIONAL attribute in "
1177 "procedure %qs which is BIND(C)",
1178 sym
->name
, &(sym
->declared_at
),
1179 sym
->ns
->proc_name
->name
))
1182 /* Make sure that if it has the dimension attribute, that it is
1183 either assumed size or explicit shape. Deferred shape is already
1184 covered by the pointer/allocatable attribute. */
1185 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1186 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1187 "at %L as dummy argument to the BIND(C) "
1188 "procedure '%s' at %L", sym
->name
,
1189 &(sym
->declared_at
),
1190 sym
->ns
->proc_name
->name
,
1191 &(sym
->ns
->proc_name
->declared_at
)))
1201 /* Function called by variable_decl() that adds a name to the symbol table. */
1204 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1205 gfc_array_spec
**as
, locus
*var_locus
)
1207 symbol_attribute attr
;
1210 if (gfc_get_symbol (name
, NULL
, &sym
))
1213 /* Start updating the symbol table. Add basic type attribute if present. */
1214 if (current_ts
.type
!= BT_UNKNOWN
1215 && (sym
->attr
.implicit_type
== 0
1216 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1217 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1220 if (sym
->ts
.type
== BT_CHARACTER
)
1223 sym
->ts
.deferred
= cl_deferred
;
1226 /* Add dimension attribute if present. */
1227 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1231 /* Add attribute to symbol. The copy is so that we can reset the
1232 dimension attribute. */
1233 attr
= current_attr
;
1235 attr
.codimension
= 0;
1237 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1240 /* Finish any work that may need to be done for the binding label,
1241 if it's a bind(c). The bind(c) attr is found before the symbol
1242 is made, and before the symbol name (for data decls), so the
1243 current_ts is holding the binding label, or nothing if the
1244 name= attr wasn't given. Therefore, test here if we're dealing
1245 with a bind(c) and make sure the binding label is set correctly. */
1246 if (sym
->attr
.is_bind_c
== 1)
1248 if (!sym
->binding_label
)
1250 /* Set the binding label and verify that if a NAME= was specified
1251 then only one identifier was in the entity-decl-list. */
1252 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1253 num_idents_on_line
))
1258 /* See if we know we're in a common block, and if it's a bind(c)
1259 common then we need to make sure we're an interoperable type. */
1260 if (sym
->attr
.in_common
== 1)
1262 /* Test the common block object. */
1263 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1264 && sym
->ts
.is_c_interop
!= 1)
1266 gfc_error_now ("Variable %qs in common block %qs at %C "
1267 "must be declared with a C interoperable "
1268 "kind since common block %qs is BIND(C)",
1269 sym
->name
, sym
->common_block
->name
,
1270 sym
->common_block
->name
);
1275 sym
->attr
.implied_index
= 0;
1277 if (sym
->ts
.type
== BT_CLASS
)
1278 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1284 /* Set character constant to the given length. The constant will be padded or
1285 truncated. If we're inside an array constructor without a typespec, we
1286 additionally check that all elements have the same length; check_len -1
1287 means no checking. */
1290 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1295 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1296 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1298 slen
= expr
->value
.character
.length
;
1301 s
= gfc_get_wide_string (len
+ 1);
1302 memcpy (s
, expr
->value
.character
.string
,
1303 MIN (len
, slen
) * sizeof (gfc_char_t
));
1305 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1307 if (warn_character_truncation
&& slen
> len
)
1308 gfc_warning_now (OPT_Wcharacter_truncation
,
1309 "CHARACTER expression at %L is being truncated "
1310 "(%d/%d)", &expr
->where
, slen
, len
);
1312 /* Apply the standard by 'hand' otherwise it gets cleared for
1314 if (check_len
!= -1 && slen
!= check_len
1315 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1316 gfc_error_now ("The CHARACTER elements of the array constructor "
1317 "at %L must have the same length (%d/%d)",
1318 &expr
->where
, slen
, check_len
);
1321 free (expr
->value
.character
.string
);
1322 expr
->value
.character
.string
= s
;
1323 expr
->value
.character
.length
= len
;
1328 /* Function to create and update the enumerator history
1329 using the information passed as arguments.
1330 Pointer "max_enum" is also updated, to point to
1331 enum history node containing largest initializer.
1333 SYM points to the symbol node of enumerator.
1334 INIT points to its enumerator value. */
1337 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1339 enumerator_history
*new_enum_history
;
1340 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1342 new_enum_history
= XCNEW (enumerator_history
);
1344 new_enum_history
->sym
= sym
;
1345 new_enum_history
->initializer
= init
;
1346 new_enum_history
->next
= NULL
;
1348 if (enum_history
== NULL
)
1350 enum_history
= new_enum_history
;
1351 max_enum
= enum_history
;
1355 new_enum_history
->next
= enum_history
;
1356 enum_history
= new_enum_history
;
1358 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1359 new_enum_history
->initializer
->value
.integer
) < 0)
1360 max_enum
= new_enum_history
;
1365 /* Function to free enum kind history. */
1368 gfc_free_enum_history (void)
1370 enumerator_history
*current
= enum_history
;
1371 enumerator_history
*next
;
1373 while (current
!= NULL
)
1375 next
= current
->next
;
1380 enum_history
= NULL
;
1384 /* Function called by variable_decl() that adds an initialization
1385 expression to a symbol. */
1388 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1390 symbol_attribute attr
;
1395 if (find_special (name
, &sym
, false))
1400 /* If this symbol is confirming an implicit parameter type,
1401 then an initialization expression is not allowed. */
1402 if (attr
.flavor
== FL_PARAMETER
1403 && sym
->value
!= NULL
1406 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1413 /* An initializer is required for PARAMETER declarations. */
1414 if (attr
.flavor
== FL_PARAMETER
)
1416 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1422 /* If a variable appears in a DATA block, it cannot have an
1426 gfc_error ("Variable %qs at %C with an initializer already "
1427 "appears in a DATA statement", sym
->name
);
1431 /* Check if the assignment can happen. This has to be put off
1432 until later for derived type variables and procedure pointers. */
1433 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1434 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1435 && !sym
->attr
.proc_pointer
1436 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1439 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1440 && init
->ts
.type
== BT_CHARACTER
)
1442 /* Update symbol character length according initializer. */
1443 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1446 if (sym
->ts
.u
.cl
->length
== NULL
)
1449 /* If there are multiple CHARACTER variables declared on the
1450 same line, we don't want them to share the same length. */
1451 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1453 if (sym
->attr
.flavor
== FL_PARAMETER
)
1455 if (init
->expr_type
== EXPR_CONSTANT
)
1457 clen
= init
->value
.character
.length
;
1458 sym
->ts
.u
.cl
->length
1459 = gfc_get_int_expr (gfc_default_integer_kind
,
1462 else if (init
->expr_type
== EXPR_ARRAY
)
1465 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1466 else if (init
->value
.constructor
)
1469 c
= gfc_constructor_first (init
->value
.constructor
);
1470 clen
= c
->expr
->value
.character
.length
;
1474 sym
->ts
.u
.cl
->length
1475 = gfc_get_int_expr (gfc_default_integer_kind
,
1478 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1479 sym
->ts
.u
.cl
->length
=
1480 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1483 /* Update initializer character length according symbol. */
1484 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1488 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1491 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1493 if (init
->expr_type
== EXPR_CONSTANT
)
1494 gfc_set_constant_character_len (len
, init
, -1);
1495 else if (init
->expr_type
== EXPR_ARRAY
)
1499 /* Build a new charlen to prevent simplification from
1500 deleting the length before it is resolved. */
1501 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1502 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1504 for (c
= gfc_constructor_first (init
->value
.constructor
);
1505 c
; c
= gfc_constructor_next (c
))
1506 gfc_set_constant_character_len (len
, c
->expr
, -1);
1511 /* If sym is implied-shape, set its upper bounds from init. */
1512 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1513 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1517 if (init
->rank
== 0)
1519 gfc_error ("Can't initialize implied-shape array at %L"
1520 " with scalar", &sym
->declared_at
);
1524 /* Shape should be present, we get an initialization expression. */
1525 gcc_assert (init
->shape
);
1527 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1533 lower
= sym
->as
->lower
[dim
];
1534 if (lower
->expr_type
!= EXPR_CONSTANT
)
1536 gfc_error ("Non-constant lower bound in implied-shape"
1537 " declaration at %L", &lower
->where
);
1541 /* All dimensions must be without upper bound. */
1542 gcc_assert (!sym
->as
->upper
[dim
]);
1545 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1546 mpz_add (e
->value
.integer
,
1547 lower
->value
.integer
, init
->shape
[dim
]);
1548 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1549 sym
->as
->upper
[dim
] = e
;
1552 sym
->as
->type
= AS_EXPLICIT
;
1555 /* Need to check if the expression we initialized this
1556 to was one of the iso_c_binding named constants. If so,
1557 and we're a parameter (constant), let it be iso_c.
1559 integer(c_int), parameter :: my_int = c_int
1560 integer(my_int) :: my_int_2
1561 If we mark my_int as iso_c (since we can see it's value
1562 is equal to one of the named constants), then my_int_2
1563 will be considered C interoperable. */
1564 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1566 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1567 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1568 /* attr bits needed for module files. */
1569 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1570 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1571 if (init
->ts
.is_iso_c
)
1572 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1575 /* Add initializer. Make sure we keep the ranks sane. */
1576 if (sym
->attr
.dimension
&& init
->rank
== 0)
1581 if (sym
->attr
.flavor
== FL_PARAMETER
1582 && init
->expr_type
== EXPR_CONSTANT
1583 && spec_size (sym
->as
, &size
)
1584 && mpz_cmp_si (size
, 0) > 0)
1586 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1588 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1589 gfc_constructor_append_expr (&array
->value
.constructor
,
1592 : gfc_copy_expr (init
),
1595 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1596 for (n
= 0; n
< sym
->as
->rank
; n
++)
1597 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1602 init
->rank
= sym
->as
->rank
;
1606 if (sym
->attr
.save
== SAVE_NONE
)
1607 sym
->attr
.save
= SAVE_IMPLICIT
;
1615 /* Function called by variable_decl() that adds a name to a structure
1619 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1620 gfc_array_spec
**as
)
1625 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1626 constructing, it must have the pointer attribute. */
1627 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1628 && current_ts
.u
.derived
== gfc_current_block ()
1629 && current_attr
.pointer
== 0)
1631 gfc_error ("Component at %C must have the POINTER attribute");
1635 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1637 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1639 gfc_error ("Array component of structure at %C must have explicit "
1640 "or deferred shape");
1645 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1649 if (c
->ts
.type
== BT_CHARACTER
)
1651 c
->attr
= current_attr
;
1653 c
->initializer
= *init
;
1660 c
->attr
.codimension
= 1;
1662 c
->attr
.dimension
= 1;
1666 /* Should this ever get more complicated, combine with similar section
1667 in add_init_expr_to_sym into a separate function. */
1668 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1670 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1674 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1675 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1676 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1678 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1680 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1681 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1682 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1683 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1685 gfc_constructor
*ctor
;
1686 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1691 bool has_ts
= (c
->initializer
->ts
.u
.cl
1692 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1694 /* Remember the length of the first element for checking
1695 that all elements *in the constructor* have the same
1696 length. This need not be the length of the LHS! */
1697 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1698 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1699 first_len
= ctor
->expr
->value
.character
.length
;
1701 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1702 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1704 gfc_set_constant_character_len (len
, ctor
->expr
,
1705 has_ts
? -1 : first_len
);
1706 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1712 /* Check array components. */
1713 if (!c
->attr
.dimension
)
1716 if (c
->attr
.pointer
)
1718 if (c
->as
->type
!= AS_DEFERRED
)
1720 gfc_error ("Pointer array component of structure at %C must have a "
1725 else if (c
->attr
.allocatable
)
1727 if (c
->as
->type
!= AS_DEFERRED
)
1729 gfc_error ("Allocatable component of structure at %C must have a "
1736 if (c
->as
->type
!= AS_EXPLICIT
)
1738 gfc_error ("Array component of structure at %C must have an "
1745 if (c
->ts
.type
== BT_CLASS
)
1747 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1757 /* Match a 'NULL()', and possibly take care of some side effects. */
1760 gfc_match_null (gfc_expr
**result
)
1763 match m
, m2
= MATCH_NO
;
1765 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1771 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1773 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1776 old_loc
= gfc_current_locus
;
1777 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1780 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1784 gfc_current_locus
= old_loc
;
1789 /* The NULL symbol now has to be/become an intrinsic function. */
1790 if (gfc_get_symbol ("null", NULL
, &sym
))
1792 gfc_error ("NULL() initialization at %C is ambiguous");
1796 gfc_intrinsic_symbol (sym
);
1798 if (sym
->attr
.proc
!= PROC_INTRINSIC
1799 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1800 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1801 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1804 *result
= gfc_get_null_expr (&gfc_current_locus
);
1806 /* Invalid per F2008, C512. */
1807 if (m2
== MATCH_YES
)
1809 gfc_error ("NULL() initialization at %C may not have MOLD");
1817 /* Match the initialization expr for a data pointer or procedure pointer. */
1820 match_pointer_init (gfc_expr
**init
, int procptr
)
1824 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1826 gfc_error ("Initialization of pointer at %C is not allowed in "
1827 "a PURE procedure");
1830 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1832 /* Match NULL() initialization. */
1833 m
= gfc_match_null (init
);
1837 /* Match non-NULL initialization. */
1838 gfc_matching_ptr_assignment
= !procptr
;
1839 gfc_matching_procptr_assignment
= procptr
;
1840 m
= gfc_match_rvalue (init
);
1841 gfc_matching_ptr_assignment
= 0;
1842 gfc_matching_procptr_assignment
= 0;
1843 if (m
== MATCH_ERROR
)
1845 else if (m
== MATCH_NO
)
1847 gfc_error ("Error in pointer initialization at %C");
1851 if (!procptr
&& !gfc_resolve_expr (*init
))
1854 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1855 "initialization at %C"))
1863 check_function_name (char *name
)
1865 /* In functions that have a RESULT variable defined, the function name always
1866 refers to function calls. Therefore, the name is not allowed to appear in
1867 specification statements. When checking this, be careful about
1868 'hidden' procedure pointer results ('ppr@'). */
1870 if (gfc_current_state () == COMP_FUNCTION
)
1872 gfc_symbol
*block
= gfc_current_block ();
1873 if (block
&& block
->result
&& block
->result
!= block
1874 && strcmp (block
->result
->name
, "ppr@") != 0
1875 && strcmp (block
->name
, name
) == 0)
1877 gfc_error ("Function name %qs not allowed at %C", name
);
1886 /* Match a variable name with an optional initializer. When this
1887 subroutine is called, a variable is expected to be parsed next.
1888 Depending on what is happening at the moment, updates either the
1889 symbol table or the current interface. */
1892 variable_decl (int elem
)
1894 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1895 gfc_expr
*initializer
, *char_len
;
1897 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1909 /* When we get here, we've just matched a list of attributes and
1910 maybe a type and a double colon. The next thing we expect to see
1911 is the name of the symbol. */
1912 m
= gfc_match_name (name
);
1916 var_locus
= gfc_current_locus
;
1918 /* Now we could see the optional array spec. or character length. */
1919 m
= gfc_match_array_spec (&as
, true, true);
1920 if (m
== MATCH_ERROR
)
1924 as
= gfc_copy_array_spec (current_as
);
1926 && !merge_array_spec (current_as
, as
, true))
1932 if (flag_cray_pointer
)
1933 cp_as
= gfc_copy_array_spec (as
);
1935 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1936 determine (and check) whether it can be implied-shape. If it
1937 was parsed as assumed-size, change it because PARAMETERs can not
1941 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1944 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1949 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1950 && current_attr
.flavor
== FL_PARAMETER
)
1951 as
->type
= AS_IMPLIED_SHAPE
;
1953 if (as
->type
== AS_IMPLIED_SHAPE
1954 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1964 cl_deferred
= false;
1966 if (current_ts
.type
== BT_CHARACTER
)
1968 switch (match_char_length (&char_len
, &cl_deferred
, false))
1971 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1973 cl
->length
= char_len
;
1976 /* Non-constant lengths need to be copied after the first
1977 element. Also copy assumed lengths. */
1980 && (current_ts
.u
.cl
->length
== NULL
1981 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1983 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1984 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1987 cl
= current_ts
.u
.cl
;
1989 cl_deferred
= current_ts
.deferred
;
1998 /* The dummy arguments and result of the abreviated form of MODULE
1999 PROCEDUREs, used in SUBMODULES should not be redefined. */
2000 if (gfc_current_ns
->proc_name
2001 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2003 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2004 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2007 gfc_error ("'%s' at %C is a redefinition of the declaration "
2008 "in the corresponding interface for MODULE "
2009 "PROCEDURE '%s'", sym
->name
,
2010 gfc_current_ns
->proc_name
->name
);
2015 /* If this symbol has already shown up in a Cray Pointer declaration,
2016 and this is not a component declaration,
2017 then we want to set the type & bail out. */
2018 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
2020 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2021 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2023 sym
->ts
.type
= current_ts
.type
;
2024 sym
->ts
.kind
= current_ts
.kind
;
2026 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2027 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2028 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2031 /* Check to see if we have an array specification. */
2034 if (sym
->as
!= NULL
)
2036 gfc_error ("Duplicate array spec for Cray pointee at %C");
2037 gfc_free_array_spec (cp_as
);
2043 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2044 gfc_internal_error ("Couldn't set pointee array spec.");
2046 /* Fix the array spec. */
2047 m
= gfc_mod_pointee_as (sym
->as
);
2048 if (m
== MATCH_ERROR
)
2056 gfc_free_array_spec (cp_as
);
2060 /* Procedure pointer as function result. */
2061 if (gfc_current_state () == COMP_FUNCTION
2062 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2063 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2064 strcpy (name
, "ppr@");
2066 if (gfc_current_state () == COMP_FUNCTION
2067 && strcmp (name
, gfc_current_block ()->name
) == 0
2068 && gfc_current_block ()->result
2069 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2070 strcpy (name
, "ppr@");
2072 /* OK, we've successfully matched the declaration. Now put the
2073 symbol in the current namespace, because it might be used in the
2074 optional initialization expression for this symbol, e.g. this is
2077 integer, parameter :: i = huge(i)
2079 This is only true for parameters or variables of a basic type.
2080 For components of derived types, it is not true, so we don't
2081 create a symbol for those yet. If we fail to create the symbol,
2083 if (gfc_current_state () != COMP_DERIVED
2084 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2090 if (!check_function_name (name
))
2096 /* We allow old-style initializations of the form
2097 integer i /2/, j(4) /3*3, 1/
2098 (if no colon has been seen). These are different from data
2099 statements in that initializers are only allowed to apply to the
2100 variable immediately preceding, i.e.
2102 is not allowed. Therefore we have to do some work manually, that
2103 could otherwise be left to the matchers for DATA statements. */
2105 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2107 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2108 "initialization at %C"))
2110 else if (gfc_current_state () == COMP_DERIVED
)
2112 gfc_error ("Invalid old style initialization for derived type "
2118 return match_old_style_init (name
);
2121 /* The double colon must be present in order to have initializers.
2122 Otherwise the statement is ambiguous with an assignment statement. */
2125 if (gfc_match (" =>") == MATCH_YES
)
2127 if (!current_attr
.pointer
)
2129 gfc_error ("Initialization at %C isn't for a pointer variable");
2134 m
= match_pointer_init (&initializer
, 0);
2138 else if (gfc_match_char ('=') == MATCH_YES
)
2140 if (current_attr
.pointer
)
2142 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2148 m
= gfc_match_init_expr (&initializer
);
2151 gfc_error ("Expected an initialization expression at %C");
2155 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2156 && gfc_state_stack
->state
!= COMP_DERIVED
)
2158 gfc_error ("Initialization of variable at %C is not allowed in "
2159 "a PURE procedure");
2163 if (current_attr
.flavor
!= FL_PARAMETER
2164 && gfc_state_stack
->state
!= COMP_DERIVED
)
2165 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2172 if (initializer
!= NULL
&& current_attr
.allocatable
2173 && gfc_current_state () == COMP_DERIVED
)
2175 gfc_error ("Initialization of allocatable component at %C is not "
2181 /* Add the initializer. Note that it is fine if initializer is
2182 NULL here, because we sometimes also need to check if a
2183 declaration *must* have an initialization expression. */
2184 if (gfc_current_state () != COMP_DERIVED
)
2185 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2188 if (current_ts
.type
== BT_DERIVED
2189 && !current_attr
.pointer
&& !initializer
)
2190 initializer
= gfc_default_initializer (¤t_ts
);
2191 t
= build_struct (name
, cl
, &initializer
, &as
);
2194 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2197 /* Free stuff up and return. */
2198 gfc_free_expr (initializer
);
2199 gfc_free_array_spec (as
);
2205 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2206 This assumes that the byte size is equal to the kind number for
2207 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2210 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2215 if (gfc_match_char ('*') != MATCH_YES
)
2218 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2222 original_kind
= ts
->kind
;
2224 /* Massage the kind numbers for complex types. */
2225 if (ts
->type
== BT_COMPLEX
)
2229 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2230 gfc_basic_typename (ts
->type
), original_kind
);
2237 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2240 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2244 if (flag_real4_kind
== 8)
2246 if (flag_real4_kind
== 10)
2248 if (flag_real4_kind
== 16)
2254 if (flag_real8_kind
== 4)
2256 if (flag_real8_kind
== 10)
2258 if (flag_real8_kind
== 16)
2263 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2265 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2266 gfc_basic_typename (ts
->type
), original_kind
);
2270 if (!gfc_notify_std (GFC_STD_GNU
,
2271 "Nonstandard type declaration %s*%d at %C",
2272 gfc_basic_typename(ts
->type
), original_kind
))
2279 /* Match a kind specification. Since kinds are generally optional, we
2280 usually return MATCH_NO if something goes wrong. If a "kind="
2281 string is found, then we know we have an error. */
2284 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2296 where
= loc
= gfc_current_locus
;
2301 if (gfc_match_char ('(') == MATCH_NO
)
2304 /* Also gobbles optional text. */
2305 if (gfc_match (" kind = ") == MATCH_YES
)
2308 loc
= gfc_current_locus
;
2311 n
= gfc_match_init_expr (&e
);
2315 if (gfc_matching_function
)
2317 /* The function kind expression might include use associated or
2318 imported parameters and try again after the specification
2320 if (gfc_match_char (')') != MATCH_YES
)
2322 gfc_error ("Missing right parenthesis at %C");
2328 gfc_undo_symbols ();
2333 /* ....or else, the match is real. */
2335 gfc_error ("Expected initialization expression at %C");
2343 gfc_error ("Expected scalar initialization expression at %C");
2348 msg
= gfc_extract_int (e
, &ts
->kind
);
2357 /* Before throwing away the expression, let's see if we had a
2358 C interoperable kind (and store the fact). */
2359 if (e
->ts
.is_c_interop
== 1)
2361 /* Mark this as C interoperable if being declared with one
2362 of the named constants from iso_c_binding. */
2363 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2364 ts
->f90_type
= e
->ts
.f90_type
;
2370 /* Ignore errors to this point, if we've gotten here. This means
2371 we ignore the m=MATCH_ERROR from above. */
2372 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2374 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2375 gfc_basic_typename (ts
->type
));
2376 gfc_current_locus
= where
;
2380 /* Warn if, e.g., c_int is used for a REAL variable, but not
2381 if, e.g., c_double is used for COMPLEX as the standard
2382 explicitly says that the kind type parameter for complex and real
2383 variable is the same, i.e. c_float == c_float_complex. */
2384 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2385 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2386 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2387 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2388 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2389 gfc_basic_typename (ts
->type
));
2391 gfc_gobble_whitespace ();
2392 if ((c
= gfc_next_ascii_char ()) != ')'
2393 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2395 if (ts
->type
== BT_CHARACTER
)
2396 gfc_error ("Missing right parenthesis or comma at %C");
2398 gfc_error ("Missing right parenthesis at %C");
2402 /* All tests passed. */
2405 if(m
== MATCH_ERROR
)
2406 gfc_current_locus
= where
;
2408 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2411 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2415 if (flag_real4_kind
== 8)
2417 if (flag_real4_kind
== 10)
2419 if (flag_real4_kind
== 16)
2425 if (flag_real8_kind
== 4)
2427 if (flag_real8_kind
== 10)
2429 if (flag_real8_kind
== 16)
2434 /* Return what we know from the test(s). */
2439 gfc_current_locus
= where
;
2445 match_char_kind (int * kind
, int * is_iso_c
)
2454 where
= gfc_current_locus
;
2456 n
= gfc_match_init_expr (&e
);
2458 if (n
!= MATCH_YES
&& gfc_matching_function
)
2460 /* The expression might include use-associated or imported
2461 parameters and try again after the specification
2464 gfc_undo_symbols ();
2469 gfc_error ("Expected initialization expression at %C");
2475 gfc_error ("Expected scalar initialization expression at %C");
2480 msg
= gfc_extract_int (e
, kind
);
2481 *is_iso_c
= e
->ts
.is_iso_c
;
2491 /* Ignore errors to this point, if we've gotten here. This means
2492 we ignore the m=MATCH_ERROR from above. */
2493 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2495 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2499 /* All tests passed. */
2502 if (m
== MATCH_ERROR
)
2503 gfc_current_locus
= where
;
2505 /* Return what we know from the test(s). */
2510 gfc_current_locus
= where
;
2515 /* Match the various kind/length specifications in a CHARACTER
2516 declaration. We don't return MATCH_NO. */
2519 gfc_match_char_spec (gfc_typespec
*ts
)
2521 int kind
, seen_length
, is_iso_c
;
2533 /* Try the old-style specification first. */
2534 old_char_selector
= 0;
2536 m
= match_char_length (&len
, &deferred
, true);
2540 old_char_selector
= 1;
2545 m
= gfc_match_char ('(');
2548 m
= MATCH_YES
; /* Character without length is a single char. */
2552 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2553 if (gfc_match (" kind =") == MATCH_YES
)
2555 m
= match_char_kind (&kind
, &is_iso_c
);
2557 if (m
== MATCH_ERROR
)
2562 if (gfc_match (" , len =") == MATCH_NO
)
2565 m
= char_len_param_value (&len
, &deferred
);
2568 if (m
== MATCH_ERROR
)
2575 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2576 if (gfc_match (" len =") == MATCH_YES
)
2578 m
= char_len_param_value (&len
, &deferred
);
2581 if (m
== MATCH_ERROR
)
2585 if (gfc_match_char (')') == MATCH_YES
)
2588 if (gfc_match (" , kind =") != MATCH_YES
)
2591 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2597 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2598 m
= char_len_param_value (&len
, &deferred
);
2601 if (m
== MATCH_ERROR
)
2605 m
= gfc_match_char (')');
2609 if (gfc_match_char (',') != MATCH_YES
)
2612 gfc_match (" kind ="); /* Gobble optional text. */
2614 m
= match_char_kind (&kind
, &is_iso_c
);
2615 if (m
== MATCH_ERROR
)
2621 /* Require a right-paren at this point. */
2622 m
= gfc_match_char (')');
2627 gfc_error ("Syntax error in CHARACTER declaration at %C");
2629 gfc_free_expr (len
);
2633 /* Deal with character functions after USE and IMPORT statements. */
2634 if (gfc_matching_function
)
2636 gfc_free_expr (len
);
2637 gfc_undo_symbols ();
2643 gfc_free_expr (len
);
2647 /* Do some final massaging of the length values. */
2648 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2650 if (seen_length
== 0)
2651 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2656 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2657 ts
->deferred
= deferred
;
2659 /* We have to know if it was a C interoperable kind so we can
2660 do accurate type checking of bind(c) procs, etc. */
2662 /* Mark this as C interoperable if being declared with one
2663 of the named constants from iso_c_binding. */
2664 ts
->is_c_interop
= is_iso_c
;
2665 else if (len
!= NULL
)
2666 /* Here, we might have parsed something such as: character(c_char)
2667 In this case, the parsing code above grabs the c_char when
2668 looking for the length (line 1690, roughly). it's the last
2669 testcase for parsing the kind params of a character variable.
2670 However, it's not actually the length. this seems like it
2672 To see if the user used a C interop kind, test the expr
2673 of the so called length, and see if it's C interoperable. */
2674 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2680 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2681 structure to the matched specification. This is necessary for FUNCTION and
2682 IMPLICIT statements.
2684 If implicit_flag is nonzero, then we don't check for the optional
2685 kind specification. Not doing so is needed for matching an IMPLICIT
2686 statement correctly. */
2689 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2691 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2692 gfc_symbol
*sym
, *dt_sym
;
2695 bool seen_deferred_kind
, matched_type
;
2696 const char *dt_name
;
2698 /* A belt and braces check that the typespec is correctly being treated
2699 as a deferred characteristic association. */
2700 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2701 && (gfc_current_block ()->result
->ts
.kind
== -1)
2702 && (ts
->kind
== -1);
2704 if (seen_deferred_kind
)
2707 /* Clear the current binding label, in case one is given. */
2708 curr_binding_label
= NULL
;
2710 if (gfc_match (" byte") == MATCH_YES
)
2712 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2715 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2717 gfc_error ("BYTE type used at %C "
2718 "is not available on the target machine");
2722 ts
->type
= BT_INTEGER
;
2728 m
= gfc_match (" type (");
2729 matched_type
= (m
== MATCH_YES
);
2732 gfc_gobble_whitespace ();
2733 if (gfc_peek_ascii_char () == '*')
2735 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2737 if (gfc_current_state () == COMP_DERIVED
)
2739 gfc_error ("Assumed type at %C is not allowed for components");
2742 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2745 ts
->type
= BT_ASSUMED
;
2749 m
= gfc_match ("%n", name
);
2750 matched_type
= (m
== MATCH_YES
);
2753 if ((matched_type
&& strcmp ("integer", name
) == 0)
2754 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2756 ts
->type
= BT_INTEGER
;
2757 ts
->kind
= gfc_default_integer_kind
;
2761 if ((matched_type
&& strcmp ("character", name
) == 0)
2762 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2765 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2766 "intrinsic-type-spec at %C"))
2769 ts
->type
= BT_CHARACTER
;
2770 if (implicit_flag
== 0)
2771 m
= gfc_match_char_spec (ts
);
2775 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2781 if ((matched_type
&& strcmp ("real", name
) == 0)
2782 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2785 ts
->kind
= gfc_default_real_kind
;
2790 && (strcmp ("doubleprecision", name
) == 0
2791 || (strcmp ("double", name
) == 0
2792 && gfc_match (" precision") == MATCH_YES
)))
2793 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2796 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2797 "intrinsic-type-spec at %C"))
2799 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2803 ts
->kind
= gfc_default_double_kind
;
2807 if ((matched_type
&& strcmp ("complex", name
) == 0)
2808 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2810 ts
->type
= BT_COMPLEX
;
2811 ts
->kind
= gfc_default_complex_kind
;
2816 && (strcmp ("doublecomplex", name
) == 0
2817 || (strcmp ("double", name
) == 0
2818 && gfc_match (" complex") == MATCH_YES
)))
2819 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2821 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2825 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2826 "intrinsic-type-spec at %C"))
2829 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2832 ts
->type
= BT_COMPLEX
;
2833 ts
->kind
= gfc_default_double_kind
;
2837 if ((matched_type
&& strcmp ("logical", name
) == 0)
2838 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2840 ts
->type
= BT_LOGICAL
;
2841 ts
->kind
= gfc_default_logical_kind
;
2846 m
= gfc_match_char (')');
2849 ts
->type
= BT_DERIVED
;
2852 /* Match CLASS declarations. */
2853 m
= gfc_match (" class ( * )");
2854 if (m
== MATCH_ERROR
)
2856 else if (m
== MATCH_YES
)
2860 ts
->type
= BT_CLASS
;
2861 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2864 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2865 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2867 gfc_set_sym_referenced (upe
);
2869 upe
->ts
.type
= BT_VOID
;
2870 upe
->attr
.unlimited_polymorphic
= 1;
2871 /* This is essential to force the construction of
2872 unlimited polymorphic component class containers. */
2873 upe
->attr
.zero_comp
= 1;
2874 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2875 &gfc_current_locus
))
2880 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2882 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2886 ts
->u
.derived
= upe
;
2890 m
= gfc_match (" class ( %n )", name
);
2893 ts
->type
= BT_CLASS
;
2895 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2899 /* Defer association of the derived type until the end of the
2900 specification block. However, if the derived type can be
2901 found, add it to the typespec. */
2902 if (gfc_matching_function
)
2904 ts
->u
.derived
= NULL
;
2905 if (gfc_current_state () != COMP_INTERFACE
2906 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2908 sym
= gfc_find_dt_in_generic (sym
);
2909 ts
->u
.derived
= sym
;
2914 /* Search for the name but allow the components to be defined later. If
2915 type = -1, this typespec has been seen in a function declaration but
2916 the type could not be accessed at that point. The actual derived type is
2917 stored in a symtree with the first letter of the name capitalized; the
2918 symtree with the all lower-case name contains the associated
2919 generic function. */
2920 dt_name
= gfc_get_string ("%c%s",
2921 (char) TOUPPER ((unsigned char) name
[0]),
2922 (const char*)&name
[1]);
2927 gfc_get_ha_symbol (name
, &sym
);
2928 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2930 gfc_error ("Type name %qs at %C is ambiguous", name
);
2933 if (sym
->generic
&& !dt_sym
)
2934 dt_sym
= gfc_find_dt_in_generic (sym
);
2936 else if (ts
->kind
== -1)
2938 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2939 || gfc_current_ns
->has_import_set
;
2940 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2941 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2943 gfc_error ("Type name %qs at %C is ambiguous", name
);
2946 if (sym
&& sym
->generic
&& !dt_sym
)
2947 dt_sym
= gfc_find_dt_in_generic (sym
);
2954 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2955 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2956 || sym
->attr
.subroutine
)
2958 gfc_error ("Type name %qs at %C conflicts with previously declared "
2959 "entity at %L, which has the same name", name
,
2964 gfc_save_symbol_data (sym
);
2965 gfc_set_sym_referenced (sym
);
2966 if (!sym
->attr
.generic
2967 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2970 if (!sym
->attr
.function
2971 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2976 gfc_interface
*intr
, *head
;
2978 /* Use upper case to save the actual derived-type symbol. */
2979 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2980 dt_sym
->name
= gfc_get_string (sym
->name
);
2981 head
= sym
->generic
;
2982 intr
= gfc_get_interface ();
2984 intr
->where
= gfc_current_locus
;
2986 sym
->generic
= intr
;
2987 sym
->attr
.if_source
= IFSRC_DECL
;
2990 gfc_save_symbol_data (dt_sym
);
2992 gfc_set_sym_referenced (dt_sym
);
2994 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2995 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2998 ts
->u
.derived
= dt_sym
;
3004 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3005 "intrinsic-type-spec at %C"))
3008 /* For all types except double, derived and character, look for an
3009 optional kind specifier. MATCH_NO is actually OK at this point. */
3010 if (implicit_flag
== 1)
3012 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3018 if (gfc_current_form
== FORM_FREE
)
3020 c
= gfc_peek_ascii_char ();
3021 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
3022 && c
!= ':' && c
!= ',')
3024 if (matched_type
&& c
== ')')
3026 gfc_next_ascii_char ();
3033 m
= gfc_match_kind_spec (ts
, false);
3034 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3036 m
= gfc_match_old_kind_spec (ts
);
3037 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
3041 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3044 /* Defer association of the KIND expression of function results
3045 until after USE and IMPORT statements. */
3046 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3047 || gfc_matching_function
)
3051 m
= MATCH_YES
; /* No kind specifier found. */
3057 /* Match an IMPLICIT NONE statement. Actually, this statement is
3058 already matched in parse.c, or we would not end up here in the
3059 first place. So the only thing we need to check, is if there is
3060 trailing garbage. If not, the match is successful. */
3063 gfc_match_implicit_none (void)
3067 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3069 bool external
= false;
3070 locus cur_loc
= gfc_current_locus
;
3072 if (gfc_current_ns
->seen_implicit_none
3073 || gfc_current_ns
->has_implicit_none_export
)
3075 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3079 gfc_gobble_whitespace ();
3080 c
= gfc_peek_ascii_char ();
3083 (void) gfc_next_ascii_char ();
3084 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3087 gfc_gobble_whitespace ();
3088 if (gfc_peek_ascii_char () == ')')
3090 (void) gfc_next_ascii_char ();
3096 m
= gfc_match (" %n", name
);
3100 if (strcmp (name
, "type") == 0)
3102 else if (strcmp (name
, "external") == 0)
3107 gfc_gobble_whitespace ();
3108 c
= gfc_next_ascii_char ();
3119 if (gfc_match_eos () != MATCH_YES
)
3122 gfc_set_implicit_none (type
, external
, &cur_loc
);
3128 /* Match the letter range(s) of an IMPLICIT statement. */
3131 match_implicit_range (void)
3137 cur_loc
= gfc_current_locus
;
3139 gfc_gobble_whitespace ();
3140 c
= gfc_next_ascii_char ();
3143 gfc_error ("Missing character range in IMPLICIT at %C");
3150 gfc_gobble_whitespace ();
3151 c1
= gfc_next_ascii_char ();
3155 gfc_gobble_whitespace ();
3156 c
= gfc_next_ascii_char ();
3161 inner
= 0; /* Fall through. */
3168 gfc_gobble_whitespace ();
3169 c2
= gfc_next_ascii_char ();
3173 gfc_gobble_whitespace ();
3174 c
= gfc_next_ascii_char ();
3176 if ((c
!= ',') && (c
!= ')'))
3189 gfc_error ("Letters must be in alphabetic order in "
3190 "IMPLICIT statement at %C");
3194 /* See if we can add the newly matched range to the pending
3195 implicits from this IMPLICIT statement. We do not check for
3196 conflicts with whatever earlier IMPLICIT statements may have
3197 set. This is done when we've successfully finished matching
3199 if (!gfc_add_new_implicit_range (c1
, c2
))
3206 gfc_syntax_error (ST_IMPLICIT
);
3208 gfc_current_locus
= cur_loc
;
3213 /* Match an IMPLICIT statement, storing the types for
3214 gfc_set_implicit() if the statement is accepted by the parser.
3215 There is a strange looking, but legal syntactic construction
3216 possible. It looks like:
3218 IMPLICIT INTEGER (a-b) (c-d)
3220 This is legal if "a-b" is a constant expression that happens to
3221 equal one of the legal kinds for integers. The real problem
3222 happens with an implicit specification that looks like:
3224 IMPLICIT INTEGER (a-b)
3226 In this case, a typespec matcher that is "greedy" (as most of the
3227 matchers are) gobbles the character range as a kindspec, leaving
3228 nothing left. We therefore have to go a bit more slowly in the
3229 matching process by inhibiting the kindspec checking during
3230 typespec matching and checking for a kind later. */
3233 gfc_match_implicit (void)
3240 if (gfc_current_ns
->seen_implicit_none
)
3242 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3249 /* We don't allow empty implicit statements. */
3250 if (gfc_match_eos () == MATCH_YES
)
3252 gfc_error ("Empty IMPLICIT statement at %C");
3258 /* First cleanup. */
3259 gfc_clear_new_implicit ();
3261 /* A basic type is mandatory here. */
3262 m
= gfc_match_decl_type_spec (&ts
, 1);
3263 if (m
== MATCH_ERROR
)
3268 cur_loc
= gfc_current_locus
;
3269 m
= match_implicit_range ();
3273 /* We may have <TYPE> (<RANGE>). */
3274 gfc_gobble_whitespace ();
3275 c
= gfc_peek_ascii_char ();
3276 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3278 /* Check for CHARACTER with no length parameter. */
3279 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3281 ts
.kind
= gfc_default_character_kind
;
3282 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3283 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3287 /* Record the Successful match. */
3288 if (!gfc_merge_new_implicit (&ts
))
3291 c
= gfc_next_ascii_char ();
3292 else if (gfc_match_eos () == MATCH_ERROR
)
3297 gfc_current_locus
= cur_loc
;
3300 /* Discard the (incorrectly) matched range. */
3301 gfc_clear_new_implicit ();
3303 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3304 if (ts
.type
== BT_CHARACTER
)
3305 m
= gfc_match_char_spec (&ts
);
3308 m
= gfc_match_kind_spec (&ts
, false);
3311 m
= gfc_match_old_kind_spec (&ts
);
3312 if (m
== MATCH_ERROR
)
3318 if (m
== MATCH_ERROR
)
3321 m
= match_implicit_range ();
3322 if (m
== MATCH_ERROR
)
3327 gfc_gobble_whitespace ();
3328 c
= gfc_next_ascii_char ();
3329 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3332 if (!gfc_merge_new_implicit (&ts
))
3340 gfc_syntax_error (ST_IMPLICIT
);
3348 gfc_match_import (void)
3350 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3355 if (gfc_current_ns
->proc_name
== NULL
3356 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3358 gfc_error ("IMPORT statement at %C only permitted in "
3359 "an INTERFACE body");
3363 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3365 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3366 "in a module procedure interface body");
3370 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3373 if (gfc_match_eos () == MATCH_YES
)
3375 /* All host variables should be imported. */
3376 gfc_current_ns
->has_import_set
= 1;
3380 if (gfc_match (" ::") == MATCH_YES
)
3382 if (gfc_match_eos () == MATCH_YES
)
3384 gfc_error ("Expecting list of named entities at %C");
3392 m
= gfc_match (" %n", name
);
3396 if (gfc_current_ns
->parent
!= NULL
3397 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3399 gfc_error ("Type name %qs at %C is ambiguous", name
);
3402 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3403 && gfc_find_symbol (name
,
3404 gfc_current_ns
->proc_name
->ns
->parent
,
3407 gfc_error ("Type name %qs at %C is ambiguous", name
);
3413 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3414 "at %C - does not exist.", name
);
3418 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3420 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3425 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3428 sym
->attr
.imported
= 1;
3430 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3432 /* The actual derived type is stored in a symtree with the first
3433 letter of the name capitalized; the symtree with the all
3434 lower-case name contains the associated generic function. */
3435 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3436 gfc_get_string ("%c%s",
3437 (char) TOUPPER ((unsigned char) name
[0]),
3441 sym
->attr
.imported
= 1;
3454 if (gfc_match_eos () == MATCH_YES
)
3456 if (gfc_match_char (',') != MATCH_YES
)
3463 gfc_error ("Syntax error in IMPORT statement at %C");
3468 /* A minimal implementation of gfc_match without whitespace, escape
3469 characters or variable arguments. Returns true if the next
3470 characters match the TARGET template exactly. */
3473 match_string_p (const char *target
)
3477 for (p
= target
; *p
; p
++)
3478 if ((char) gfc_next_ascii_char () != *p
)
3483 /* Matches an attribute specification including array specs. If
3484 successful, leaves the variables current_attr and current_as
3485 holding the specification. Also sets the colon_seen variable for
3486 later use by matchers associated with initializations.
3488 This subroutine is a little tricky in the sense that we don't know
3489 if we really have an attr-spec until we hit the double colon.
3490 Until that time, we can only return MATCH_NO. This forces us to
3491 check for duplicate specification at this level. */
3494 match_attr_spec (void)
3496 /* Modifiers that can exist in a type statement. */
3498 { GFC_DECL_BEGIN
= 0,
3499 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3500 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3501 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3502 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3503 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3504 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3507 /* GFC_DECL_END is the sentinel, index starts at 0. */
3508 #define NUM_DECL GFC_DECL_END
3510 locus start
, seen_at
[NUM_DECL
];
3517 gfc_clear_attr (¤t_attr
);
3518 start
= gfc_current_locus
;
3523 /* See if we get all of the keywords up to the final double colon. */
3524 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3532 gfc_gobble_whitespace ();
3534 ch
= gfc_next_ascii_char ();
3537 /* This is the successful exit condition for the loop. */
3538 if (gfc_next_ascii_char () == ':')
3543 gfc_gobble_whitespace ();
3544 switch (gfc_peek_ascii_char ())
3547 gfc_next_ascii_char ();
3548 switch (gfc_next_ascii_char ())
3551 if (match_string_p ("locatable"))
3553 /* Matched "allocatable". */
3554 d
= DECL_ALLOCATABLE
;
3559 if (match_string_p ("ynchronous"))
3561 /* Matched "asynchronous". */
3562 d
= DECL_ASYNCHRONOUS
;
3569 /* Try and match the bind(c). */
3570 m
= gfc_match_bind_c (NULL
, true);
3573 else if (m
== MATCH_ERROR
)
3578 gfc_next_ascii_char ();
3579 if ('o' != gfc_next_ascii_char ())
3581 switch (gfc_next_ascii_char ())
3584 if (match_string_p ("imension"))
3586 d
= DECL_CODIMENSION
;
3590 if (match_string_p ("tiguous"))
3592 d
= DECL_CONTIGUOUS
;
3599 if (match_string_p ("dimension"))
3604 if (match_string_p ("external"))
3609 if (match_string_p ("int"))
3611 ch
= gfc_next_ascii_char ();
3614 if (match_string_p ("nt"))
3616 /* Matched "intent". */
3617 /* TODO: Call match_intent_spec from here. */
3618 if (gfc_match (" ( in out )") == MATCH_YES
)
3620 else if (gfc_match (" ( in )") == MATCH_YES
)
3622 else if (gfc_match (" ( out )") == MATCH_YES
)
3628 if (match_string_p ("insic"))
3630 /* Matched "intrinsic". */
3638 if (match_string_p ("optional"))
3643 gfc_next_ascii_char ();
3644 switch (gfc_next_ascii_char ())
3647 if (match_string_p ("rameter"))
3649 /* Matched "parameter". */
3655 if (match_string_p ("inter"))
3657 /* Matched "pointer". */
3663 ch
= gfc_next_ascii_char ();
3666 if (match_string_p ("vate"))
3668 /* Matched "private". */
3674 if (match_string_p ("tected"))
3676 /* Matched "protected". */
3683 if (match_string_p ("blic"))
3685 /* Matched "public". */
3693 if (match_string_p ("save"))
3698 if (match_string_p ("target"))
3703 gfc_next_ascii_char ();
3704 ch
= gfc_next_ascii_char ();
3707 if (match_string_p ("lue"))
3709 /* Matched "value". */
3715 if (match_string_p ("latile"))
3717 /* Matched "volatile". */
3725 /* No double colon and no recognizable decl_type, so assume that
3726 we've been looking at something else the whole time. */
3733 /* Check to make sure any parens are paired up correctly. */
3734 if (gfc_match_parens () == MATCH_ERROR
)
3741 seen_at
[d
] = gfc_current_locus
;
3743 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3745 gfc_array_spec
*as
= NULL
;
3747 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3748 d
== DECL_CODIMENSION
);
3750 if (current_as
== NULL
)
3752 else if (m
== MATCH_YES
)
3754 if (!merge_array_spec (as
, current_as
, false))
3761 if (d
== DECL_CODIMENSION
)
3762 gfc_error ("Missing codimension specification at %C");
3764 gfc_error ("Missing dimension specification at %C");
3768 if (m
== MATCH_ERROR
)
3773 /* Since we've seen a double colon, we have to be looking at an
3774 attr-spec. This means that we can now issue errors. */
3775 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3780 case DECL_ALLOCATABLE
:
3781 attr
= "ALLOCATABLE";
3783 case DECL_ASYNCHRONOUS
:
3784 attr
= "ASYNCHRONOUS";
3786 case DECL_CODIMENSION
:
3787 attr
= "CODIMENSION";
3789 case DECL_CONTIGUOUS
:
3790 attr
= "CONTIGUOUS";
3792 case DECL_DIMENSION
:
3799 attr
= "INTENT (IN)";
3802 attr
= "INTENT (OUT)";
3805 attr
= "INTENT (IN OUT)";
3807 case DECL_INTRINSIC
:
3813 case DECL_PARAMETER
:
3819 case DECL_PROTECTED
:
3834 case DECL_IS_BIND_C
:
3844 attr
= NULL
; /* This shouldn't happen. */
3847 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3852 /* Now that we've dealt with duplicate attributes, add the attributes
3853 to the current attribute. */
3854 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3859 if (gfc_current_state () == COMP_DERIVED
3860 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3861 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3862 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3864 if (d
== DECL_ALLOCATABLE
)
3866 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3867 "attribute at %C in a TYPE definition"))
3875 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3882 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3883 && gfc_current_state () != COMP_MODULE
)
3885 if (d
== DECL_PRIVATE
)
3889 if (gfc_current_state () == COMP_DERIVED
3890 && gfc_state_stack
->previous
3891 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3893 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3894 "at %L in a TYPE definition", attr
,
3903 gfc_error ("%s attribute at %L is not allowed outside of the "
3904 "specification part of a module", attr
, &seen_at
[d
]);
3912 case DECL_ALLOCATABLE
:
3913 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3916 case DECL_ASYNCHRONOUS
:
3917 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3920 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3923 case DECL_CODIMENSION
:
3924 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3927 case DECL_CONTIGUOUS
:
3928 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3931 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3934 case DECL_DIMENSION
:
3935 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3939 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3943 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3947 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3951 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3954 case DECL_INTRINSIC
:
3955 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3959 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3962 case DECL_PARAMETER
:
3963 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3967 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3970 case DECL_PROTECTED
:
3971 if (gfc_current_state () != COMP_MODULE
3972 || (gfc_current_ns
->proc_name
3973 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
3975 gfc_error ("PROTECTED at %C only allowed in specification "
3976 "part of a module");
3981 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3984 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3988 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3993 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3998 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
4002 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
4005 case DECL_IS_BIND_C
:
4006 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
4010 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
4013 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
4017 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
4020 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
4024 gfc_internal_error ("match_attr_spec(): Bad attribute");
4034 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4035 if ((gfc_current_state () == COMP_MODULE
4036 || gfc_current_state () == COMP_SUBMODULE
)
4037 && !current_attr
.save
4038 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4039 current_attr
.save
= SAVE_IMPLICIT
;
4045 gfc_current_locus
= start
;
4046 gfc_free_array_spec (current_as
);
4052 /* Set the binding label, dest_label, either with the binding label
4053 stored in the given gfc_typespec, ts, or if none was provided, it
4054 will be the symbol name in all lower case, as required by the draft
4055 (J3/04-007, section 15.4.1). If a binding label was given and
4056 there is more than one argument (num_idents), it is an error. */
4059 set_binding_label (const char **dest_label
, const char *sym_name
,
4062 if (num_idents
> 1 && has_name_equals
)
4064 gfc_error ("Multiple identifiers provided with "
4065 "single NAME= specifier at %C");
4069 if (curr_binding_label
)
4070 /* Binding label given; store in temp holder till have sym. */
4071 *dest_label
= curr_binding_label
;
4074 /* No binding label given, and the NAME= specifier did not exist,
4075 which means there was no NAME="". */
4076 if (sym_name
!= NULL
&& has_name_equals
== 0)
4077 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4084 /* Set the status of the given common block as being BIND(C) or not,
4085 depending on the given parameter, is_bind_c. */
4088 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4090 com_block
->is_bind_c
= is_bind_c
;
4095 /* Verify that the given gfc_typespec is for a C interoperable type. */
4098 gfc_verify_c_interop (gfc_typespec
*ts
)
4100 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4101 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4103 else if (ts
->type
== BT_CLASS
)
4105 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4112 /* Verify that the variables of a given common block, which has been
4113 defined with the attribute specifier bind(c), to be of a C
4114 interoperable type. Errors will be reported here, if
4118 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4120 gfc_symbol
*curr_sym
= NULL
;
4123 curr_sym
= com_block
->head
;
4125 /* Make sure we have at least one symbol. */
4126 if (curr_sym
== NULL
)
4129 /* Here we know we have a symbol, so we'll execute this loop
4133 /* The second to last param, 1, says this is in a common block. */
4134 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4135 curr_sym
= curr_sym
->common_next
;
4136 } while (curr_sym
!= NULL
);
4142 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4143 an appropriate error message is reported. */
4146 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4147 int is_in_common
, gfc_common_head
*com_block
)
4149 bool bind_c_function
= false;
4152 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4153 bind_c_function
= true;
4155 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4157 tmp_sym
= tmp_sym
->result
;
4158 /* Make sure it wasn't an implicitly typed result. */
4159 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4161 gfc_warning (OPT_Wc_binding_type
,
4162 "Implicitly declared BIND(C) function %qs at "
4163 "%L may not be C interoperable", tmp_sym
->name
,
4164 &tmp_sym
->declared_at
);
4165 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4166 /* Mark it as C interoperable to prevent duplicate warnings. */
4167 tmp_sym
->ts
.is_c_interop
= 1;
4168 tmp_sym
->attr
.is_c_interop
= 1;
4172 /* Here, we know we have the bind(c) attribute, so if we have
4173 enough type info, then verify that it's a C interop kind.
4174 The info could be in the symbol already, or possibly still in
4175 the given ts (current_ts), so look in both. */
4176 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4178 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4180 /* See if we're dealing with a sym in a common block or not. */
4181 if (is_in_common
== 1 && warn_c_binding_type
)
4183 gfc_warning (OPT_Wc_binding_type
,
4184 "Variable %qs in common block %qs at %L "
4185 "may not be a C interoperable "
4186 "kind though common block %qs is BIND(C)",
4187 tmp_sym
->name
, com_block
->name
,
4188 &(tmp_sym
->declared_at
), com_block
->name
);
4192 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4193 gfc_error ("Type declaration %qs at %L is not C "
4194 "interoperable but it is BIND(C)",
4195 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4196 else if (warn_c_binding_type
)
4197 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4198 "may not be a C interoperable "
4199 "kind but it is BIND(C)",
4200 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4204 /* Variables declared w/in a common block can't be bind(c)
4205 since there's no way for C to see these variables, so there's
4206 semantically no reason for the attribute. */
4207 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4209 gfc_error ("Variable %qs in common block %qs at "
4210 "%L cannot be declared with BIND(C) "
4211 "since it is not a global",
4212 tmp_sym
->name
, com_block
->name
,
4213 &(tmp_sym
->declared_at
));
4217 /* Scalar variables that are bind(c) can not have the pointer
4218 or allocatable attributes. */
4219 if (tmp_sym
->attr
.is_bind_c
== 1)
4221 if (tmp_sym
->attr
.pointer
== 1)
4223 gfc_error ("Variable %qs at %L cannot have both the "
4224 "POINTER and BIND(C) attributes",
4225 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4229 if (tmp_sym
->attr
.allocatable
== 1)
4231 gfc_error ("Variable %qs at %L cannot have both the "
4232 "ALLOCATABLE and BIND(C) attributes",
4233 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4239 /* If it is a BIND(C) function, make sure the return value is a
4240 scalar value. The previous tests in this function made sure
4241 the type is interoperable. */
4242 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4243 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4244 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4246 /* BIND(C) functions can not return a character string. */
4247 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4248 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4249 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4250 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4251 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4252 "be a character string", tmp_sym
->name
,
4253 &(tmp_sym
->declared_at
));
4256 /* See if the symbol has been marked as private. If it has, make sure
4257 there is no binding label and warn the user if there is one. */
4258 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4259 && tmp_sym
->binding_label
)
4260 /* Use gfc_warning_now because we won't say that the symbol fails
4261 just because of this. */
4262 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4263 "given the binding label %qs", tmp_sym
->name
,
4264 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4270 /* Set the appropriate fields for a symbol that's been declared as
4271 BIND(C) (the is_bind_c flag and the binding label), and verify that
4272 the type is C interoperable. Errors are reported by the functions
4273 used to set/test these fields. */
4276 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4280 /* TODO: Do we need to make sure the vars aren't marked private? */
4282 /* Set the is_bind_c bit in symbol_attribute. */
4283 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4285 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4292 /* Set the fields marking the given common block as BIND(C), including
4293 a binding label, and report any errors encountered. */
4296 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4300 /* destLabel, common name, typespec (which may have binding label). */
4301 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4305 /* Set the given common block (com_block) to being bind(c) (1). */
4306 set_com_block_bind_c (com_block
, 1);
4312 /* Retrieve the list of one or more identifiers that the given bind(c)
4313 attribute applies to. */
4316 get_bind_c_idents (void)
4318 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4320 gfc_symbol
*tmp_sym
= NULL
;
4322 gfc_common_head
*com_block
= NULL
;
4324 if (gfc_match_name (name
) == MATCH_YES
)
4326 found_id
= MATCH_YES
;
4327 gfc_get_ha_symbol (name
, &tmp_sym
);
4329 else if (match_common_name (name
) == MATCH_YES
)
4331 found_id
= MATCH_YES
;
4332 com_block
= gfc_get_common (name
, 0);
4336 gfc_error ("Need either entity or common block name for "
4337 "attribute specification statement at %C");
4341 /* Save the current identifier and look for more. */
4344 /* Increment the number of identifiers found for this spec stmt. */
4347 /* Make sure we have a sym or com block, and verify that it can
4348 be bind(c). Set the appropriate field(s) and look for more
4350 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4352 if (tmp_sym
!= NULL
)
4354 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4359 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4363 /* Look to see if we have another identifier. */
4365 if (gfc_match_eos () == MATCH_YES
)
4366 found_id
= MATCH_NO
;
4367 else if (gfc_match_char (',') != MATCH_YES
)
4368 found_id
= MATCH_NO
;
4369 else if (gfc_match_name (name
) == MATCH_YES
)
4371 found_id
= MATCH_YES
;
4372 gfc_get_ha_symbol (name
, &tmp_sym
);
4374 else if (match_common_name (name
) == MATCH_YES
)
4376 found_id
= MATCH_YES
;
4377 com_block
= gfc_get_common (name
, 0);
4381 gfc_error ("Missing entity or common block name for "
4382 "attribute specification statement at %C");
4388 gfc_internal_error ("Missing symbol");
4390 } while (found_id
== MATCH_YES
);
4392 /* if we get here we were successful */
4397 /* Try and match a BIND(C) attribute specification statement. */
4400 gfc_match_bind_c_stmt (void)
4402 match found_match
= MATCH_NO
;
4407 /* This may not be necessary. */
4409 /* Clear the temporary binding label holder. */
4410 curr_binding_label
= NULL
;
4412 /* Look for the bind(c). */
4413 found_match
= gfc_match_bind_c (NULL
, true);
4415 if (found_match
== MATCH_YES
)
4417 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4420 /* Look for the :: now, but it is not required. */
4423 /* Get the identifier(s) that needs to be updated. This may need to
4424 change to hand the flag(s) for the attr specified so all identifiers
4425 found can have all appropriate parts updated (assuming that the same
4426 spec stmt can have multiple attrs, such as both bind(c) and
4428 if (!get_bind_c_idents ())
4429 /* Error message should have printed already. */
4437 /* Match a data declaration statement. */
4440 gfc_match_data_decl (void)
4446 num_idents_on_line
= 0;
4448 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4452 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4453 && gfc_current_state () != COMP_DERIVED
)
4455 sym
= gfc_use_derived (current_ts
.u
.derived
);
4463 current_ts
.u
.derived
= sym
;
4466 m
= match_attr_spec ();
4467 if (m
== MATCH_ERROR
)
4473 if (current_ts
.type
== BT_CLASS
4474 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4477 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4478 && current_ts
.u
.derived
->components
== NULL
4479 && !current_ts
.u
.derived
->attr
.zero_comp
)
4482 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4485 gfc_find_symbol (current_ts
.u
.derived
->name
,
4486 current_ts
.u
.derived
->ns
, 1, &sym
);
4488 /* Any symbol that we find had better be a type definition
4489 which has its components defined. */
4490 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4491 && (current_ts
.u
.derived
->components
!= NULL
4492 || current_ts
.u
.derived
->attr
.zero_comp
))
4495 gfc_error ("Derived type at %C has not been previously defined "
4496 "and so cannot appear in a derived type definition");
4502 /* If we have an old-style character declaration, and no new-style
4503 attribute specifications, then there a comma is optional between
4504 the type specification and the variable list. */
4505 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4506 gfc_match_char (',');
4508 /* Give the types/attributes to symbols that follow. Give the element
4509 a number so that repeat character length expressions can be copied. */
4513 num_idents_on_line
++;
4514 m
= variable_decl (elem
++);
4515 if (m
== MATCH_ERROR
)
4520 if (gfc_match_eos () == MATCH_YES
)
4522 if (gfc_match_char (',') != MATCH_YES
)
4526 if (!gfc_error_flag_test ())
4527 gfc_error ("Syntax error in data declaration at %C");
4530 gfc_free_data_all (gfc_current_ns
);
4533 gfc_free_array_spec (current_as
);
4539 /* Match a prefix associated with a function or subroutine
4540 declaration. If the typespec pointer is nonnull, then a typespec
4541 can be matched. Note that if nothing matches, MATCH_YES is
4542 returned (the null string was matched). */
4545 gfc_match_prefix (gfc_typespec
*ts
)
4551 gfc_clear_attr (¤t_attr
);
4553 seen_impure
= false;
4555 gcc_assert (!gfc_matching_prefix
);
4556 gfc_matching_prefix
= true;
4560 found_prefix
= false;
4562 if (!seen_type
&& ts
!= NULL
4563 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4564 && gfc_match_space () == MATCH_YES
)
4568 found_prefix
= true;
4571 if (gfc_match ("elemental% ") == MATCH_YES
)
4573 if (!gfc_add_elemental (¤t_attr
, NULL
))
4576 found_prefix
= true;
4579 if (gfc_match ("pure% ") == MATCH_YES
)
4581 if (!gfc_add_pure (¤t_attr
, NULL
))
4584 found_prefix
= true;
4587 if (gfc_match ("recursive% ") == MATCH_YES
)
4589 if (!gfc_add_recursive (¤t_attr
, NULL
))
4592 found_prefix
= true;
4595 /* IMPURE is a somewhat special case, as it needs not set an actual
4596 attribute but rather only prevents ELEMENTAL routines from being
4597 automatically PURE. */
4598 if (gfc_match ("impure% ") == MATCH_YES
)
4600 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4604 found_prefix
= true;
4607 while (found_prefix
);
4609 /* IMPURE and PURE must not both appear, of course. */
4610 if (seen_impure
&& current_attr
.pure
)
4612 gfc_error ("PURE and IMPURE must not appear both at %C");
4616 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4617 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4619 if (!gfc_add_pure (¤t_attr
, NULL
))
4623 /* At this point, the next item is not a prefix. */
4624 gcc_assert (gfc_matching_prefix
);
4626 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4627 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4628 corresponding attribute seems natural and distinguishes these
4629 procedures from procedure types of PROC_MODULE, which these are
4631 if ((gfc_current_state () == COMP_INTERFACE
4632 || gfc_current_state () == COMP_CONTAINS
)
4633 && gfc_match ("module% ") == MATCH_YES
)
4635 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4638 current_attr
.module_procedure
= 1;
4641 gfc_matching_prefix
= false;
4645 gcc_assert (gfc_matching_prefix
);
4646 gfc_matching_prefix
= false;
4651 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4654 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4656 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4659 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4662 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4669 /* Match a formal argument list. */
4672 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4674 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4675 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4678 gfc_formal_arglist
*formal
= NULL
;
4682 /* Keep the interface formal argument list and null it so that the
4683 matching for the new declaration can be done. The numbers and
4684 names of the arguments are checked here. The interface formal
4685 arguments are retained in formal_arglist and the characteristics
4686 are compared in resolve.c(resolve_fl_procedure). See the remark
4687 in get_proc_name about the eventual need to copy the formal_arglist
4688 and populate the formal namespace of the interface symbol. */
4689 if (progname
->attr
.module_procedure
4690 && progname
->attr
.host_assoc
)
4692 formal
= progname
->formal
;
4693 progname
->formal
= NULL
;
4696 if (gfc_match_char ('(') != MATCH_YES
)
4703 if (gfc_match_char (')') == MATCH_YES
)
4708 if (gfc_match_char ('*') == MATCH_YES
)
4711 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4720 m
= gfc_match_name (name
);
4724 if (gfc_get_symbol (name
, NULL
, &sym
))
4728 p
= gfc_get_formal_arglist ();
4740 /* We don't add the VARIABLE flavor because the name could be a
4741 dummy procedure. We don't apply these attributes to formal
4742 arguments of statement functions. */
4743 if (sym
!= NULL
&& !st_flag
4744 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4745 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4751 /* The name of a program unit can be in a different namespace,
4752 so check for it explicitly. After the statement is accepted,
4753 the name is checked for especially in gfc_get_symbol(). */
4754 if (gfc_new_block
!= NULL
&& sym
!= NULL
4755 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4757 gfc_error ("Name %qs at %C is the name of the procedure",
4763 if (gfc_match_char (')') == MATCH_YES
)
4766 m
= gfc_match_char (',');
4769 gfc_error ("Unexpected junk in formal argument list at %C");
4775 /* Check for duplicate symbols in the formal argument list. */
4778 for (p
= head
; p
->next
; p
= p
->next
)
4783 for (q
= p
->next
; q
; q
= q
->next
)
4784 if (p
->sym
== q
->sym
)
4786 gfc_error ("Duplicate symbol %qs in formal argument list "
4787 "at %C", p
->sym
->name
);
4795 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4803 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4805 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4806 || (p
->next
== NULL
&& q
->next
!= NULL
))
4807 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4808 "formal arguments at %C");
4809 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4810 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4813 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4814 "argument names (%s/%s) at %C",
4815 p
->sym
->name
, q
->sym
->name
);
4822 gfc_free_formal_arglist (head
);
4827 /* Match a RESULT specification following a function declaration or
4828 ENTRY statement. Also matches the end-of-statement. */
4831 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4833 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4837 if (gfc_match (" result (") != MATCH_YES
)
4840 m
= gfc_match_name (name
);
4844 /* Get the right paren, and that's it because there could be the
4845 bind(c) attribute after the result clause. */
4846 if (gfc_match_char (')') != MATCH_YES
)
4848 /* TODO: should report the missing right paren here. */
4852 if (strcmp (function
->name
, name
) == 0)
4854 gfc_error ("RESULT variable at %C must be different than function name");
4858 if (gfc_get_symbol (name
, NULL
, &r
))
4861 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4870 /* Match a function suffix, which could be a combination of a result
4871 clause and BIND(C), either one, or neither. The draft does not
4872 require them to come in a specific order. */
4875 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4877 match is_bind_c
; /* Found bind(c). */
4878 match is_result
; /* Found result clause. */
4879 match found_match
; /* Status of whether we've found a good match. */
4880 char peek_char
; /* Character we're going to peek at. */
4881 bool allow_binding_name
;
4883 /* Initialize to having found nothing. */
4884 found_match
= MATCH_NO
;
4885 is_bind_c
= MATCH_NO
;
4886 is_result
= MATCH_NO
;
4888 /* Get the next char to narrow between result and bind(c). */
4889 gfc_gobble_whitespace ();
4890 peek_char
= gfc_peek_ascii_char ();
4892 /* C binding names are not allowed for internal procedures. */
4893 if (gfc_current_state () == COMP_CONTAINS
4894 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4895 allow_binding_name
= false;
4897 allow_binding_name
= true;
4902 /* Look for result clause. */
4903 is_result
= match_result (sym
, result
);
4904 if (is_result
== MATCH_YES
)
4906 /* Now see if there is a bind(c) after it. */
4907 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4908 /* We've found the result clause and possibly bind(c). */
4909 found_match
= MATCH_YES
;
4912 /* This should only be MATCH_ERROR. */
4913 found_match
= is_result
;
4916 /* Look for bind(c) first. */
4917 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4918 if (is_bind_c
== MATCH_YES
)
4920 /* Now see if a result clause followed it. */
4921 is_result
= match_result (sym
, result
);
4922 found_match
= MATCH_YES
;
4926 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4927 found_match
= MATCH_ERROR
;
4931 gfc_error ("Unexpected junk after function declaration at %C");
4932 found_match
= MATCH_ERROR
;
4936 if (is_bind_c
== MATCH_YES
)
4938 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4939 if (gfc_current_state () == COMP_CONTAINS
4940 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4941 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4942 "at %L may not be specified for an internal "
4943 "procedure", &gfc_current_locus
))
4946 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4954 /* Procedure pointer return value without RESULT statement:
4955 Add "hidden" result variable named "ppr@". */
4958 add_hidden_procptr_result (gfc_symbol
*sym
)
4962 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4965 /* First usage case: PROCEDURE and EXTERNAL statements. */
4966 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4967 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4968 && sym
->attr
.external
;
4969 /* Second usage case: INTERFACE statements. */
4970 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4971 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4972 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4978 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4982 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4983 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4984 st2
->n
.sym
= stree
->n
.sym
;
4986 sym
->result
= stree
->n
.sym
;
4988 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4989 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4990 sym
->result
->attr
.external
= sym
->attr
.external
;
4991 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4992 sym
->result
->ts
= sym
->ts
;
4993 sym
->attr
.proc_pointer
= 0;
4994 sym
->attr
.pointer
= 0;
4995 sym
->attr
.external
= 0;
4996 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4998 sym
->result
->attr
.pointer
= 0;
4999 sym
->result
->attr
.proc_pointer
= 1;
5002 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5004 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5005 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5006 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5007 && sym
== gfc_current_ns
->proc_name
5008 && sym
== sym
->result
->ns
->proc_name
5009 && strcmp ("ppr@", sym
->result
->name
) == 0)
5011 sym
->result
->attr
.proc_pointer
= 1;
5012 sym
->attr
.pointer
= 0;
5020 /* Match the interface for a PROCEDURE declaration,
5021 including brackets (R1212). */
5024 match_procedure_interface (gfc_symbol
**proc_if
)
5028 locus old_loc
, entry_loc
;
5029 gfc_namespace
*old_ns
= gfc_current_ns
;
5030 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5032 old_loc
= entry_loc
= gfc_current_locus
;
5033 gfc_clear_ts (¤t_ts
);
5035 if (gfc_match (" (") != MATCH_YES
)
5037 gfc_current_locus
= entry_loc
;
5041 /* Get the type spec. for the procedure interface. */
5042 old_loc
= gfc_current_locus
;
5043 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5044 gfc_gobble_whitespace ();
5045 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5048 if (m
== MATCH_ERROR
)
5051 /* Procedure interface is itself a procedure. */
5052 gfc_current_locus
= old_loc
;
5053 m
= gfc_match_name (name
);
5055 /* First look to see if it is already accessible in the current
5056 namespace because it is use associated or contained. */
5058 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5061 /* If it is still not found, then try the parent namespace, if it
5062 exists and create the symbol there if it is still not found. */
5063 if (gfc_current_ns
->parent
)
5064 gfc_current_ns
= gfc_current_ns
->parent
;
5065 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5068 gfc_current_ns
= old_ns
;
5069 *proc_if
= st
->n
.sym
;
5074 /* Resolve interface if possible. That way, attr.procedure is only set
5075 if it is declared by a later procedure-declaration-stmt, which is
5076 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5077 while ((*proc_if
)->ts
.interface
)
5078 *proc_if
= (*proc_if
)->ts
.interface
;
5080 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5081 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5082 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5083 (*proc_if
)->name
, NULL
))
5088 if (gfc_match (" )") != MATCH_YES
)
5090 gfc_current_locus
= entry_loc
;
5098 /* Match a PROCEDURE declaration (R1211). */
5101 match_procedure_decl (void)
5104 gfc_symbol
*sym
, *proc_if
= NULL
;
5106 gfc_expr
*initializer
= NULL
;
5108 /* Parse interface (with brackets). */
5109 m
= match_procedure_interface (&proc_if
);
5113 /* Parse attributes (with colons). */
5114 m
= match_attr_spec();
5115 if (m
== MATCH_ERROR
)
5118 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5120 current_attr
.is_bind_c
= 1;
5121 has_name_equals
= 0;
5122 curr_binding_label
= NULL
;
5125 /* Get procedure symbols. */
5128 m
= gfc_match_symbol (&sym
, 0);
5131 else if (m
== MATCH_ERROR
)
5134 /* Add current_attr to the symbol attributes. */
5135 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5138 if (sym
->attr
.is_bind_c
)
5140 /* Check for C1218. */
5141 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5143 gfc_error ("BIND(C) attribute at %C requires "
5144 "an interface with BIND(C)");
5147 /* Check for C1217. */
5148 if (has_name_equals
&& sym
->attr
.pointer
)
5150 gfc_error ("BIND(C) procedure with NAME may not have "
5151 "POINTER attribute at %C");
5154 if (has_name_equals
&& sym
->attr
.dummy
)
5156 gfc_error ("Dummy procedure at %C may not have "
5157 "BIND(C) attribute with NAME");
5160 /* Set binding label for BIND(C). */
5161 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5165 if (!gfc_add_external (&sym
->attr
, NULL
))
5168 if (add_hidden_procptr_result (sym
))
5171 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5174 /* Set interface. */
5175 if (proc_if
!= NULL
)
5177 if (sym
->ts
.type
!= BT_UNKNOWN
)
5179 gfc_error ("Procedure %qs at %L already has basic type of %s",
5180 sym
->name
, &gfc_current_locus
,
5181 gfc_basic_typename (sym
->ts
.type
));
5184 sym
->ts
.interface
= proc_if
;
5185 sym
->attr
.untyped
= 1;
5186 sym
->attr
.if_source
= IFSRC_IFBODY
;
5188 else if (current_ts
.type
!= BT_UNKNOWN
)
5190 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5192 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5193 sym
->ts
.interface
->ts
= current_ts
;
5194 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5195 sym
->ts
.interface
->attr
.function
= 1;
5196 sym
->attr
.function
= 1;
5197 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5200 if (gfc_match (" =>") == MATCH_YES
)
5202 if (!current_attr
.pointer
)
5204 gfc_error ("Initialization at %C isn't for a pointer variable");
5209 m
= match_pointer_init (&initializer
, 1);
5213 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5218 if (gfc_match_eos () == MATCH_YES
)
5220 if (gfc_match_char (',') != MATCH_YES
)
5225 gfc_error ("Syntax error in PROCEDURE statement at %C");
5229 /* Free stuff up and return. */
5230 gfc_free_expr (initializer
);
5236 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5239 /* Match a procedure pointer component declaration (R445). */
5242 match_ppc_decl (void)
5245 gfc_symbol
*proc_if
= NULL
;
5249 gfc_expr
*initializer
= NULL
;
5250 gfc_typebound_proc
* tb
;
5251 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5253 /* Parse interface (with brackets). */
5254 m
= match_procedure_interface (&proc_if
);
5258 /* Parse attributes. */
5259 tb
= XCNEW (gfc_typebound_proc
);
5260 tb
->where
= gfc_current_locus
;
5261 m
= match_binding_attributes (tb
, false, true);
5262 if (m
== MATCH_ERROR
)
5265 gfc_clear_attr (¤t_attr
);
5266 current_attr
.procedure
= 1;
5267 current_attr
.proc_pointer
= 1;
5268 current_attr
.access
= tb
->access
;
5269 current_attr
.flavor
= FL_PROCEDURE
;
5271 /* Match the colons (required). */
5272 if (gfc_match (" ::") != MATCH_YES
)
5274 gfc_error ("Expected %<::%> after binding-attributes at %C");
5278 /* Check for C450. */
5279 if (!tb
->nopass
&& proc_if
== NULL
)
5281 gfc_error("NOPASS or explicit interface required at %C");
5285 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5288 /* Match PPC names. */
5292 m
= gfc_match_name (name
);
5295 else if (m
== MATCH_ERROR
)
5298 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5301 /* Add current_attr to the symbol attributes. */
5302 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5305 if (!gfc_add_external (&c
->attr
, NULL
))
5308 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5315 c
->tb
= XCNEW (gfc_typebound_proc
);
5316 c
->tb
->where
= gfc_current_locus
;
5320 /* Set interface. */
5321 if (proc_if
!= NULL
)
5323 c
->ts
.interface
= proc_if
;
5324 c
->attr
.untyped
= 1;
5325 c
->attr
.if_source
= IFSRC_IFBODY
;
5327 else if (ts
.type
!= BT_UNKNOWN
)
5330 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5331 c
->ts
.interface
->result
= c
->ts
.interface
;
5332 c
->ts
.interface
->ts
= ts
;
5333 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5334 c
->ts
.interface
->attr
.function
= 1;
5335 c
->attr
.function
= 1;
5336 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5339 if (gfc_match (" =>") == MATCH_YES
)
5341 m
= match_pointer_init (&initializer
, 1);
5344 gfc_free_expr (initializer
);
5347 c
->initializer
= initializer
;
5350 if (gfc_match_eos () == MATCH_YES
)
5352 if (gfc_match_char (',') != MATCH_YES
)
5357 gfc_error ("Syntax error in procedure pointer component at %C");
5362 /* Match a PROCEDURE declaration inside an interface (R1206). */
5365 match_procedure_in_interface (void)
5369 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5372 if (current_interface
.type
== INTERFACE_NAMELESS
5373 || current_interface
.type
== INTERFACE_ABSTRACT
)
5375 gfc_error ("PROCEDURE at %C must be in a generic interface");
5379 /* Check if the F2008 optional double colon appears. */
5380 gfc_gobble_whitespace ();
5381 old_locus
= gfc_current_locus
;
5382 if (gfc_match ("::") == MATCH_YES
)
5384 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5385 "MODULE PROCEDURE statement at %L", &old_locus
))
5389 gfc_current_locus
= old_locus
;
5393 m
= gfc_match_name (name
);
5396 else if (m
== MATCH_ERROR
)
5398 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5401 if (!gfc_add_interface (sym
))
5404 if (gfc_match_eos () == MATCH_YES
)
5406 if (gfc_match_char (',') != MATCH_YES
)
5413 gfc_error ("Syntax error in PROCEDURE statement at %C");
5418 /* General matcher for PROCEDURE declarations. */
5420 static match
match_procedure_in_type (void);
5423 gfc_match_procedure (void)
5427 switch (gfc_current_state ())
5432 case COMP_SUBMODULE
:
5433 case COMP_SUBROUTINE
:
5436 m
= match_procedure_decl ();
5438 case COMP_INTERFACE
:
5439 m
= match_procedure_in_interface ();
5442 m
= match_ppc_decl ();
5444 case COMP_DERIVED_CONTAINS
:
5445 m
= match_procedure_in_type ();
5454 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5461 /* Warn if a matched procedure has the same name as an intrinsic; this is
5462 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5463 parser-state-stack to find out whether we're in a module. */
5466 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5470 in_module
= (gfc_state_stack
->previous
5471 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5472 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5474 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5478 /* Match a function declaration. */
5481 gfc_match_function_decl (void)
5483 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5484 gfc_symbol
*sym
, *result
;
5488 match found_match
; /* Status returned by match func. */
5490 if (gfc_current_state () != COMP_NONE
5491 && gfc_current_state () != COMP_INTERFACE
5492 && gfc_current_state () != COMP_CONTAINS
)
5495 gfc_clear_ts (¤t_ts
);
5497 old_loc
= gfc_current_locus
;
5499 m
= gfc_match_prefix (¤t_ts
);
5502 gfc_current_locus
= old_loc
;
5506 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5508 gfc_current_locus
= old_loc
;
5512 if (get_proc_name (name
, &sym
, false))
5515 if (add_hidden_procptr_result (sym
))
5518 if (current_attr
.module_procedure
)
5519 sym
->attr
.module_procedure
= 1;
5521 gfc_new_block
= sym
;
5523 m
= gfc_match_formal_arglist (sym
, 0, 0);
5526 gfc_error ("Expected formal argument list in function "
5527 "definition at %C");
5531 else if (m
== MATCH_ERROR
)
5536 /* According to the draft, the bind(c) and result clause can
5537 come in either order after the formal_arg_list (i.e., either
5538 can be first, both can exist together or by themselves or neither
5539 one). Therefore, the match_result can't match the end of the
5540 string, and check for the bind(c) or result clause in either order. */
5541 found_match
= gfc_match_eos ();
5543 /* Make sure that it isn't already declared as BIND(C). If it is, it
5544 must have been marked BIND(C) with a BIND(C) attribute and that is
5545 not allowed for procedures. */
5546 if (sym
->attr
.is_bind_c
== 1)
5548 sym
->attr
.is_bind_c
= 0;
5549 if (sym
->old_symbol
!= NULL
)
5550 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5551 "variables or common blocks",
5552 &(sym
->old_symbol
->declared_at
));
5554 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5555 "variables or common blocks", &gfc_current_locus
);
5558 if (found_match
!= MATCH_YES
)
5560 /* If we haven't found the end-of-statement, look for a suffix. */
5561 suffix_match
= gfc_match_suffix (sym
, &result
);
5562 if (suffix_match
== MATCH_YES
)
5563 /* Need to get the eos now. */
5564 found_match
= gfc_match_eos ();
5566 found_match
= suffix_match
;
5569 if(found_match
!= MATCH_YES
)
5573 /* Make changes to the symbol. */
5576 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5579 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5580 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5583 /* Delay matching the function characteristics until after the
5584 specification block by signalling kind=-1. */
5585 sym
->declared_at
= old_loc
;
5586 if (current_ts
.type
!= BT_UNKNOWN
)
5587 current_ts
.kind
= -1;
5589 current_ts
.kind
= 0;
5593 if (current_ts
.type
!= BT_UNKNOWN
5594 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5600 if (current_ts
.type
!= BT_UNKNOWN
5601 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5603 sym
->result
= result
;
5606 /* Warn if this procedure has the same name as an intrinsic. */
5607 do_warn_intrinsic_shadow (sym
, true);
5613 gfc_current_locus
= old_loc
;
5618 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5619 pass the name of the entry, rather than the gfc_current_block name, and
5620 to return false upon finding an existing global entry. */
5623 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5627 enum gfc_symbol_type type
;
5629 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5631 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5632 name is a global identifier. */
5633 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5635 s
= gfc_get_gsymbol (name
);
5637 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5639 gfc_global_used (s
, where
);
5648 s
->ns
= gfc_current_ns
;
5652 /* Don't add the symbol multiple times. */
5654 && (!gfc_notification_std (GFC_STD_F2008
)
5655 || strcmp (name
, binding_label
) != 0))
5657 s
= gfc_get_gsymbol (binding_label
);
5659 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5661 gfc_global_used (s
, where
);
5668 s
->binding_label
= binding_label
;
5671 s
->ns
= gfc_current_ns
;
5679 /* Match an ENTRY statement. */
5682 gfc_match_entry (void)
5687 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5688 gfc_compile_state state
;
5692 bool module_procedure
;
5696 m
= gfc_match_name (name
);
5700 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5703 state
= gfc_current_state ();
5704 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5709 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5712 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5714 case COMP_SUBMODULE
:
5715 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5717 case COMP_BLOCK_DATA
:
5718 gfc_error ("ENTRY statement at %C cannot appear within "
5721 case COMP_INTERFACE
:
5722 gfc_error ("ENTRY statement at %C cannot appear within "
5726 gfc_error ("ENTRY statement at %C cannot appear within "
5727 "a DERIVED TYPE block");
5730 gfc_error ("ENTRY statement at %C cannot appear within "
5731 "an IF-THEN block");
5734 case COMP_DO_CONCURRENT
:
5735 gfc_error ("ENTRY statement at %C cannot appear within "
5739 gfc_error ("ENTRY statement at %C cannot appear within "
5743 gfc_error ("ENTRY statement at %C cannot appear within "
5747 gfc_error ("ENTRY statement at %C cannot appear within "
5751 gfc_error ("ENTRY statement at %C cannot appear within "
5752 "a contained subprogram");
5755 gfc_error ("Unexpected ENTRY statement at %C");
5760 module_procedure
= gfc_current_ns
->parent
!= NULL
5761 && gfc_current_ns
->parent
->proc_name
5762 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5765 if (gfc_current_ns
->parent
!= NULL
5766 && gfc_current_ns
->parent
->proc_name
5767 && !module_procedure
)
5769 gfc_error("ENTRY statement at %C cannot appear in a "
5770 "contained procedure");
5774 /* Module function entries need special care in get_proc_name
5775 because previous references within the function will have
5776 created symbols attached to the current namespace. */
5777 if (get_proc_name (name
, &entry
,
5778 gfc_current_ns
->parent
!= NULL
5779 && module_procedure
))
5782 proc
= gfc_current_block ();
5784 /* Make sure that it isn't already declared as BIND(C). If it is, it
5785 must have been marked BIND(C) with a BIND(C) attribute and that is
5786 not allowed for procedures. */
5787 if (entry
->attr
.is_bind_c
== 1)
5789 entry
->attr
.is_bind_c
= 0;
5790 if (entry
->old_symbol
!= NULL
)
5791 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5792 "variables or common blocks",
5793 &(entry
->old_symbol
->declared_at
));
5795 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5796 "variables or common blocks", &gfc_current_locus
);
5799 /* Check what next non-whitespace character is so we can tell if there
5800 is the required parens if we have a BIND(C). */
5801 old_loc
= gfc_current_locus
;
5802 gfc_gobble_whitespace ();
5803 peek_char
= gfc_peek_ascii_char ();
5805 if (state
== COMP_SUBROUTINE
)
5807 m
= gfc_match_formal_arglist (entry
, 0, 1);
5811 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5812 never be an internal procedure. */
5813 is_bind_c
= gfc_match_bind_c (entry
, true);
5814 if (is_bind_c
== MATCH_ERROR
)
5816 if (is_bind_c
== MATCH_YES
)
5818 if (peek_char
!= '(')
5820 gfc_error ("Missing required parentheses before BIND(C) at %C");
5823 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5824 &(entry
->declared_at
), 1))
5828 if (!gfc_current_ns
->parent
5829 && !add_global_entry (name
, entry
->binding_label
, true,
5833 /* An entry in a subroutine. */
5834 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5835 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5840 /* An entry in a function.
5841 We need to take special care because writing
5846 ENTRY f() RESULT (r)
5848 ENTRY f RESULT (r). */
5849 if (gfc_match_eos () == MATCH_YES
)
5851 gfc_current_locus
= old_loc
;
5852 /* Match the empty argument list, and add the interface to
5854 m
= gfc_match_formal_arglist (entry
, 0, 1);
5857 m
= gfc_match_formal_arglist (entry
, 0, 0);
5864 if (gfc_match_eos () == MATCH_YES
)
5866 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5867 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5870 entry
->result
= entry
;
5874 m
= gfc_match_suffix (entry
, &result
);
5876 gfc_syntax_error (ST_ENTRY
);
5882 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5883 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5884 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5886 entry
->result
= result
;
5890 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5891 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5893 entry
->result
= entry
;
5897 if (!gfc_current_ns
->parent
5898 && !add_global_entry (name
, entry
->binding_label
, false,
5903 if (gfc_match_eos () != MATCH_YES
)
5905 gfc_syntax_error (ST_ENTRY
);
5909 entry
->attr
.recursive
= proc
->attr
.recursive
;
5910 entry
->attr
.elemental
= proc
->attr
.elemental
;
5911 entry
->attr
.pure
= proc
->attr
.pure
;
5913 el
= gfc_get_entry_list ();
5915 el
->next
= gfc_current_ns
->entries
;
5916 gfc_current_ns
->entries
= el
;
5918 el
->id
= el
->next
->id
+ 1;
5922 new_st
.op
= EXEC_ENTRY
;
5923 new_st
.ext
.entry
= el
;
5929 /* Match a subroutine statement, including optional prefixes. */
5932 gfc_match_subroutine (void)
5934 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5939 bool allow_binding_name
;
5941 if (gfc_current_state () != COMP_NONE
5942 && gfc_current_state () != COMP_INTERFACE
5943 && gfc_current_state () != COMP_CONTAINS
)
5946 m
= gfc_match_prefix (NULL
);
5950 m
= gfc_match ("subroutine% %n", name
);
5954 if (get_proc_name (name
, &sym
, false))
5957 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5958 the symbol existed before. */
5959 sym
->declared_at
= gfc_current_locus
;
5961 if (current_attr
.module_procedure
)
5962 sym
->attr
.module_procedure
= 1;
5964 if (add_hidden_procptr_result (sym
))
5967 gfc_new_block
= sym
;
5969 /* Check what next non-whitespace character is so we can tell if there
5970 is the required parens if we have a BIND(C). */
5971 gfc_gobble_whitespace ();
5972 peek_char
= gfc_peek_ascii_char ();
5974 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5977 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5980 /* Make sure that it isn't already declared as BIND(C). If it is, it
5981 must have been marked BIND(C) with a BIND(C) attribute and that is
5982 not allowed for procedures. */
5983 if (sym
->attr
.is_bind_c
== 1)
5985 sym
->attr
.is_bind_c
= 0;
5986 if (sym
->old_symbol
!= NULL
)
5987 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5988 "variables or common blocks",
5989 &(sym
->old_symbol
->declared_at
));
5991 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5992 "variables or common blocks", &gfc_current_locus
);
5995 /* C binding names are not allowed for internal procedures. */
5996 if (gfc_current_state () == COMP_CONTAINS
5997 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5998 allow_binding_name
= false;
6000 allow_binding_name
= true;
6002 /* Here, we are just checking if it has the bind(c) attribute, and if
6003 so, then we need to make sure it's all correct. If it doesn't,
6004 we still need to continue matching the rest of the subroutine line. */
6005 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6006 if (is_bind_c
== MATCH_ERROR
)
6008 /* There was an attempt at the bind(c), but it was wrong. An
6009 error message should have been printed w/in the gfc_match_bind_c
6010 so here we'll just return the MATCH_ERROR. */
6014 if (is_bind_c
== MATCH_YES
)
6016 /* The following is allowed in the Fortran 2008 draft. */
6017 if (gfc_current_state () == COMP_CONTAINS
6018 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6019 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6020 "at %L may not be specified for an internal "
6021 "procedure", &gfc_current_locus
))
6024 if (peek_char
!= '(')
6026 gfc_error ("Missing required parentheses before BIND(C) at %C");
6029 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6030 &(sym
->declared_at
), 1))
6034 if (gfc_match_eos () != MATCH_YES
)
6036 gfc_syntax_error (ST_SUBROUTINE
);
6040 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6043 /* Warn if it has the same name as an intrinsic. */
6044 do_warn_intrinsic_shadow (sym
, false);
6050 /* Check that the NAME identifier in a BIND attribute or statement
6051 is conform to C identifier rules. */
6054 check_bind_name_identifier (char **name
)
6056 char *n
= *name
, *p
;
6058 /* Remove leading spaces. */
6062 /* On an empty string, free memory and set name to NULL. */
6070 /* Remove trailing spaces. */
6071 p
= n
+ strlen(n
) - 1;
6075 /* Insert the identifier into the symbol table. */
6080 /* Now check that identifier is valid under C rules. */
6083 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6088 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6090 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6098 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6099 given, and set the binding label in either the given symbol (if not
6100 NULL), or in the current_ts. The symbol may be NULL because we may
6101 encounter the BIND(C) before the declaration itself. Return
6102 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6103 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6104 or MATCH_YES if the specifier was correct and the binding label and
6105 bind(c) fields were set correctly for the given symbol or the
6106 current_ts. If allow_binding_name is false, no binding name may be
6110 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6112 char *binding_label
= NULL
;
6115 /* Initialize the flag that specifies whether we encountered a NAME=
6116 specifier or not. */
6117 has_name_equals
= 0;
6119 /* This much we have to be able to match, in this order, if
6120 there is a bind(c) label. */
6121 if (gfc_match (" bind ( c ") != MATCH_YES
)
6124 /* Now see if there is a binding label, or if we've reached the
6125 end of the bind(c) attribute without one. */
6126 if (gfc_match_char (',') == MATCH_YES
)
6128 if (gfc_match (" name = ") != MATCH_YES
)
6130 gfc_error ("Syntax error in NAME= specifier for binding label "
6132 /* should give an error message here */
6136 has_name_equals
= 1;
6138 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6144 if (!gfc_simplify_expr(e
, 0))
6146 gfc_error ("NAME= specifier at %C should be a constant expression");
6151 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6152 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6154 gfc_error ("NAME= specifier at %C should be a scalar of "
6155 "default character kind");
6160 // Get a C string from the Fortran string constant
6161 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6162 e
->value
.character
.length
);
6165 // Check that it is valid (old gfc_match_name_C)
6166 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6170 /* Get the required right paren. */
6171 if (gfc_match_char (')') != MATCH_YES
)
6173 gfc_error ("Missing closing paren for binding label at %C");
6177 if (has_name_equals
&& !allow_binding_name
)
6179 gfc_error ("No binding name is allowed in BIND(C) at %C");
6183 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6185 gfc_error ("For dummy procedure %s, no binding name is "
6186 "allowed in BIND(C) at %C", sym
->name
);
6191 /* Save the binding label to the symbol. If sym is null, we're
6192 probably matching the typespec attributes of a declaration and
6193 haven't gotten the name yet, and therefore, no symbol yet. */
6197 sym
->binding_label
= binding_label
;
6199 curr_binding_label
= binding_label
;
6201 else if (allow_binding_name
)
6203 /* No binding label, but if symbol isn't null, we
6204 can set the label for it here.
6205 If name="" or allow_binding_name is false, no C binding name is
6207 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6208 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6211 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6212 && current_interface
.type
== INTERFACE_ABSTRACT
)
6214 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6222 /* Return nonzero if we're currently compiling a contained procedure. */
6225 contained_procedure (void)
6227 gfc_state_data
*s
= gfc_state_stack
;
6229 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6230 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6236 /* Set the kind of each enumerator. The kind is selected such that it is
6237 interoperable with the corresponding C enumeration type, making
6238 sure that -fshort-enums is honored. */
6243 enumerator_history
*current_history
= NULL
;
6247 if (max_enum
== NULL
|| enum_history
== NULL
)
6250 if (!flag_short_enums
)
6256 kind
= gfc_integer_kinds
[i
++].kind
;
6258 while (kind
< gfc_c_int_kind
6259 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6262 current_history
= enum_history
;
6263 while (current_history
!= NULL
)
6265 current_history
->sym
->ts
.kind
= kind
;
6266 current_history
= current_history
->next
;
6271 /* Match any of the various end-block statements. Returns the type of
6272 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6273 and END BLOCK statements cannot be replaced by a single END statement. */
6276 gfc_match_end (gfc_statement
*st
)
6278 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6279 gfc_compile_state state
;
6281 const char *block_name
;
6285 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6286 gfc_namespace
**nsp
;
6287 bool abreviated_modproc_decl
;
6289 old_loc
= gfc_current_locus
;
6290 if (gfc_match ("end") != MATCH_YES
)
6293 state
= gfc_current_state ();
6294 block_name
= gfc_current_block () == NULL
6295 ? NULL
: gfc_current_block ()->name
;
6299 case COMP_ASSOCIATE
:
6301 if (!strncmp (block_name
, "block@", strlen("block@")))
6306 case COMP_DERIVED_CONTAINS
:
6307 state
= gfc_state_stack
->previous
->state
;
6308 block_name
= gfc_state_stack
->previous
->sym
== NULL
6309 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6316 abreviated_modproc_decl
6317 = gfc_current_block ()
6318 && gfc_current_block ()->abr_modproc_decl
;
6324 *st
= ST_END_PROGRAM
;
6325 target
= " program";
6329 case COMP_SUBROUTINE
:
6330 *st
= ST_END_SUBROUTINE
;
6331 if (!abreviated_modproc_decl
)
6332 target
= " subroutine";
6334 target
= " procedure";
6335 eos_ok
= !contained_procedure ();
6339 *st
= ST_END_FUNCTION
;
6340 if (!abreviated_modproc_decl
)
6341 target
= " function";
6343 target
= " procedure";
6344 eos_ok
= !contained_procedure ();
6347 case COMP_BLOCK_DATA
:
6348 *st
= ST_END_BLOCK_DATA
;
6349 target
= " block data";
6354 *st
= ST_END_MODULE
;
6359 case COMP_SUBMODULE
:
6360 *st
= ST_END_SUBMODULE
;
6361 target
= " submodule";
6365 case COMP_INTERFACE
:
6366 *st
= ST_END_INTERFACE
;
6367 target
= " interface";
6372 case COMP_DERIVED_CONTAINS
:
6378 case COMP_ASSOCIATE
:
6379 *st
= ST_END_ASSOCIATE
;
6380 target
= " associate";
6397 case COMP_DO_CONCURRENT
:
6404 *st
= ST_END_CRITICAL
;
6405 target
= " critical";
6410 case COMP_SELECT_TYPE
:
6411 *st
= ST_END_SELECT
;
6417 *st
= ST_END_FORALL
;
6432 last_initializer
= NULL
;
6434 gfc_free_enum_history ();
6438 gfc_error ("Unexpected END statement at %C");
6442 old_loc
= gfc_current_locus
;
6443 if (gfc_match_eos () == MATCH_YES
)
6445 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6447 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6448 "instead of %s statement at %L",
6449 abreviated_modproc_decl
? "END PROCEDURE"
6450 : gfc_ascii_statement(*st
), &old_loc
))
6455 /* We would have required END [something]. */
6456 gfc_error ("%s statement expected at %L",
6457 gfc_ascii_statement (*st
), &old_loc
);
6464 /* Verify that we've got the sort of end-block that we're expecting. */
6465 if (gfc_match (target
) != MATCH_YES
)
6467 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6468 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6472 old_loc
= gfc_current_locus
;
6473 /* If we're at the end, make sure a block name wasn't required. */
6474 if (gfc_match_eos () == MATCH_YES
)
6477 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6478 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6479 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6485 gfc_error ("Expected block name of %qs in %s statement at %L",
6486 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6491 /* END INTERFACE has a special handler for its several possible endings. */
6492 if (*st
== ST_END_INTERFACE
)
6493 return gfc_match_end_interface ();
6495 /* We haven't hit the end of statement, so what is left must be an
6497 m
= gfc_match_space ();
6499 m
= gfc_match_name (name
);
6502 gfc_error ("Expected terminating name at %C");
6506 if (block_name
== NULL
)
6509 /* We have to pick out the declared submodule name from the composite
6510 required by F2008:11.2.3 para 2, which ends in the declared name. */
6511 if (state
== COMP_SUBMODULE
)
6512 block_name
= strchr (block_name
, '.') + 1;
6514 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6516 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6517 gfc_ascii_statement (*st
));
6520 /* Procedure pointer as function result. */
6521 else if (strcmp (block_name
, "ppr@") == 0
6522 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6524 gfc_error ("Expected label %qs for %s statement at %C",
6525 gfc_current_block ()->ns
->proc_name
->name
,
6526 gfc_ascii_statement (*st
));
6530 if (gfc_match_eos () == MATCH_YES
)
6534 gfc_syntax_error (*st
);
6537 gfc_current_locus
= old_loc
;
6539 /* If we are missing an END BLOCK, we created a half-ready namespace.
6540 Remove it from the parent namespace's sibling list. */
6542 while (state
== COMP_BLOCK
)
6544 parent_ns
= gfc_current_ns
->parent
;
6546 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6552 if (ns
== gfc_current_ns
)
6554 if (prev_ns
== NULL
)
6557 prev_ns
->sibling
= ns
->sibling
;
6563 gfc_free_namespace (gfc_current_ns
);
6564 gfc_current_ns
= parent_ns
;
6565 gfc_state_stack
= gfc_state_stack
->previous
;
6566 state
= gfc_current_state ();
6574 /***************** Attribute declaration statements ****************/
6576 /* Set the attribute of a single variable. */
6581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6584 /* Workaround -Wmaybe-uninitialized false positive during
6585 profiledbootstrap by initializing them. */
6586 gfc_symbol
*sym
= NULL
;
6592 m
= gfc_match_name (name
);
6596 if (find_special (name
, &sym
, false))
6599 if (!check_function_name (name
))
6605 var_locus
= gfc_current_locus
;
6607 /* Deal with possible array specification for certain attributes. */
6608 if (current_attr
.dimension
6609 || current_attr
.codimension
6610 || current_attr
.allocatable
6611 || current_attr
.pointer
6612 || current_attr
.target
)
6614 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6615 !current_attr
.dimension
6616 && !current_attr
.pointer
6617 && !current_attr
.target
);
6618 if (m
== MATCH_ERROR
)
6621 if (current_attr
.dimension
&& m
== MATCH_NO
)
6623 gfc_error ("Missing array specification at %L in DIMENSION "
6624 "statement", &var_locus
);
6629 if (current_attr
.dimension
&& sym
->value
)
6631 gfc_error ("Dimensions specified for %s at %L after its "
6632 "initialisation", sym
->name
, &var_locus
);
6637 if (current_attr
.codimension
&& m
== MATCH_NO
)
6639 gfc_error ("Missing array specification at %L in CODIMENSION "
6640 "statement", &var_locus
);
6645 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6646 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6648 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6654 /* Update symbol table. DIMENSION attribute is set in
6655 gfc_set_array_spec(). For CLASS variables, this must be applied
6656 to the first component, or '_data' field. */
6657 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6659 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6667 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6668 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6675 if (sym
->ts
.type
== BT_CLASS
6676 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6682 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6688 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6690 /* Fix the array spec. */
6691 m
= gfc_mod_pointee_as (sym
->as
);
6692 if (m
== MATCH_ERROR
)
6696 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6702 if ((current_attr
.external
|| current_attr
.intrinsic
)
6703 && sym
->attr
.flavor
!= FL_PROCEDURE
6704 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6710 add_hidden_procptr_result (sym
);
6715 gfc_free_array_spec (as
);
6720 /* Generic attribute declaration subroutine. Used for attributes that
6721 just have a list of names. */
6728 /* Gobble the optional double colon, by simply ignoring the result
6738 if (gfc_match_eos () == MATCH_YES
)
6744 if (gfc_match_char (',') != MATCH_YES
)
6746 gfc_error ("Unexpected character in variable list at %C");
6756 /* This routine matches Cray Pointer declarations of the form:
6757 pointer ( <pointer>, <pointee> )
6759 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6760 The pointer, if already declared, should be an integer. Otherwise, we
6761 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6762 be either a scalar, or an array declaration. No space is allocated for
6763 the pointee. For the statement
6764 pointer (ipt, ar(10))
6765 any subsequent uses of ar will be translated (in C-notation) as
6766 ar(i) => ((<type> *) ipt)(i)
6767 After gimplification, pointee variable will disappear in the code. */
6770 cray_pointer_decl (void)
6773 gfc_array_spec
*as
= NULL
;
6774 gfc_symbol
*cptr
; /* Pointer symbol. */
6775 gfc_symbol
*cpte
; /* Pointee symbol. */
6781 if (gfc_match_char ('(') != MATCH_YES
)
6783 gfc_error ("Expected %<(%> at %C");
6787 /* Match pointer. */
6788 var_locus
= gfc_current_locus
;
6789 gfc_clear_attr (¤t_attr
);
6790 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6791 current_ts
.type
= BT_INTEGER
;
6792 current_ts
.kind
= gfc_index_integer_kind
;
6794 m
= gfc_match_symbol (&cptr
, 0);
6797 gfc_error ("Expected variable name at %C");
6801 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6804 gfc_set_sym_referenced (cptr
);
6806 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6808 cptr
->ts
.type
= BT_INTEGER
;
6809 cptr
->ts
.kind
= gfc_index_integer_kind
;
6811 else if (cptr
->ts
.type
!= BT_INTEGER
)
6813 gfc_error ("Cray pointer at %C must be an integer");
6816 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6817 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6818 " memory addresses require %d bytes",
6819 cptr
->ts
.kind
, gfc_index_integer_kind
);
6821 if (gfc_match_char (',') != MATCH_YES
)
6823 gfc_error ("Expected \",\" at %C");
6827 /* Match Pointee. */
6828 var_locus
= gfc_current_locus
;
6829 gfc_clear_attr (¤t_attr
);
6830 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6831 current_ts
.type
= BT_UNKNOWN
;
6832 current_ts
.kind
= 0;
6834 m
= gfc_match_symbol (&cpte
, 0);
6837 gfc_error ("Expected variable name at %C");
6841 /* Check for an optional array spec. */
6842 m
= gfc_match_array_spec (&as
, true, false);
6843 if (m
== MATCH_ERROR
)
6845 gfc_free_array_spec (as
);
6848 else if (m
== MATCH_NO
)
6850 gfc_free_array_spec (as
);
6854 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6857 gfc_set_sym_referenced (cpte
);
6859 if (cpte
->as
== NULL
)
6861 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6862 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6864 else if (as
!= NULL
)
6866 gfc_error ("Duplicate array spec for Cray pointee at %C");
6867 gfc_free_array_spec (as
);
6873 if (cpte
->as
!= NULL
)
6875 /* Fix array spec. */
6876 m
= gfc_mod_pointee_as (cpte
->as
);
6877 if (m
== MATCH_ERROR
)
6881 /* Point the Pointee at the Pointer. */
6882 cpte
->cp_pointer
= cptr
;
6884 if (gfc_match_char (')') != MATCH_YES
)
6886 gfc_error ("Expected \")\" at %C");
6889 m
= gfc_match_char (',');
6891 done
= true; /* Stop searching for more declarations. */
6895 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6896 || gfc_match_eos () != MATCH_YES
)
6898 gfc_error ("Expected %<,%> or end of statement at %C");
6906 gfc_match_external (void)
6909 gfc_clear_attr (¤t_attr
);
6910 current_attr
.external
= 1;
6912 return attr_decl ();
6917 gfc_match_intent (void)
6921 /* This is not allowed within a BLOCK construct! */
6922 if (gfc_current_state () == COMP_BLOCK
)
6924 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6928 intent
= match_intent_spec ();
6929 if (intent
== INTENT_UNKNOWN
)
6932 gfc_clear_attr (¤t_attr
);
6933 current_attr
.intent
= intent
;
6935 return attr_decl ();
6940 gfc_match_intrinsic (void)
6943 gfc_clear_attr (¤t_attr
);
6944 current_attr
.intrinsic
= 1;
6946 return attr_decl ();
6951 gfc_match_optional (void)
6953 /* This is not allowed within a BLOCK construct! */
6954 if (gfc_current_state () == COMP_BLOCK
)
6956 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6960 gfc_clear_attr (¤t_attr
);
6961 current_attr
.optional
= 1;
6963 return attr_decl ();
6968 gfc_match_pointer (void)
6970 gfc_gobble_whitespace ();
6971 if (gfc_peek_ascii_char () == '(')
6973 if (!flag_cray_pointer
)
6975 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6979 return cray_pointer_decl ();
6983 gfc_clear_attr (¤t_attr
);
6984 current_attr
.pointer
= 1;
6986 return attr_decl ();
6992 gfc_match_allocatable (void)
6994 gfc_clear_attr (¤t_attr
);
6995 current_attr
.allocatable
= 1;
6997 return attr_decl ();
7002 gfc_match_codimension (void)
7004 gfc_clear_attr (¤t_attr
);
7005 current_attr
.codimension
= 1;
7007 return attr_decl ();
7012 gfc_match_contiguous (void)
7014 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7017 gfc_clear_attr (¤t_attr
);
7018 current_attr
.contiguous
= 1;
7020 return attr_decl ();
7025 gfc_match_dimension (void)
7027 gfc_clear_attr (¤t_attr
);
7028 current_attr
.dimension
= 1;
7030 return attr_decl ();
7035 gfc_match_target (void)
7037 gfc_clear_attr (¤t_attr
);
7038 current_attr
.target
= 1;
7040 return attr_decl ();
7044 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7048 access_attr_decl (gfc_statement st
)
7050 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7051 interface_type type
;
7053 gfc_symbol
*sym
, *dt_sym
;
7054 gfc_intrinsic_op op
;
7057 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7062 m
= gfc_match_generic_spec (&type
, name
, &op
);
7065 if (m
== MATCH_ERROR
)
7070 case INTERFACE_NAMELESS
:
7071 case INTERFACE_ABSTRACT
:
7074 case INTERFACE_GENERIC
:
7075 if (gfc_get_symbol (name
, NULL
, &sym
))
7078 if (!gfc_add_access (&sym
->attr
,
7080 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7084 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7085 && !gfc_add_access (&dt_sym
->attr
,
7087 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7093 case INTERFACE_INTRINSIC_OP
:
7094 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7096 gfc_intrinsic_op other_op
;
7098 gfc_current_ns
->operator_access
[op
] =
7099 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7101 /* Handle the case if there is another op with the same
7102 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7103 other_op
= gfc_equivalent_op (op
);
7105 if (other_op
!= INTRINSIC_NONE
)
7106 gfc_current_ns
->operator_access
[other_op
] =
7107 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7112 gfc_error ("Access specification of the %s operator at %C has "
7113 "already been specified", gfc_op2string (op
));
7119 case INTERFACE_USER_OP
:
7120 uop
= gfc_get_uop (name
);
7122 if (uop
->access
== ACCESS_UNKNOWN
)
7124 uop
->access
= (st
== ST_PUBLIC
)
7125 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7129 gfc_error ("Access specification of the .%s. operator at %C "
7130 "has already been specified", sym
->name
);
7137 if (gfc_match_char (',') == MATCH_NO
)
7141 if (gfc_match_eos () != MATCH_YES
)
7146 gfc_syntax_error (st
);
7154 gfc_match_protected (void)
7159 if (!gfc_current_ns
->proc_name
7160 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7162 gfc_error ("PROTECTED at %C only allowed in specification "
7163 "part of a module");
7168 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7171 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7176 if (gfc_match_eos () == MATCH_YES
)
7181 m
= gfc_match_symbol (&sym
, 0);
7185 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7197 if (gfc_match_eos () == MATCH_YES
)
7199 if (gfc_match_char (',') != MATCH_YES
)
7206 gfc_error ("Syntax error in PROTECTED statement at %C");
7211 /* The PRIVATE statement is a bit weird in that it can be an attribute
7212 declaration, but also works as a standalone statement inside of a
7213 type declaration or a module. */
7216 gfc_match_private (gfc_statement
*st
)
7219 if (gfc_match ("private") != MATCH_YES
)
7222 if (gfc_current_state () != COMP_MODULE
7223 && !(gfc_current_state () == COMP_DERIVED
7224 && gfc_state_stack
->previous
7225 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7226 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7227 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7228 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7230 gfc_error ("PRIVATE statement at %C is only allowed in the "
7231 "specification part of a module");
7235 if (gfc_current_state () == COMP_DERIVED
)
7237 if (gfc_match_eos () == MATCH_YES
)
7243 gfc_syntax_error (ST_PRIVATE
);
7247 if (gfc_match_eos () == MATCH_YES
)
7254 return access_attr_decl (ST_PRIVATE
);
7259 gfc_match_public (gfc_statement
*st
)
7262 if (gfc_match ("public") != MATCH_YES
)
7265 if (gfc_current_state () != COMP_MODULE
)
7267 gfc_error ("PUBLIC statement at %C is only allowed in the "
7268 "specification part of a module");
7272 if (gfc_match_eos () == MATCH_YES
)
7279 return access_attr_decl (ST_PUBLIC
);
7283 /* Workhorse for gfc_match_parameter. */
7293 m
= gfc_match_symbol (&sym
, 0);
7295 gfc_error ("Expected variable name at %C in PARAMETER statement");
7300 if (gfc_match_char ('=') == MATCH_NO
)
7302 gfc_error ("Expected = sign in PARAMETER statement at %C");
7306 m
= gfc_match_init_expr (&init
);
7308 gfc_error ("Expected expression at %C in PARAMETER statement");
7312 if (sym
->ts
.type
== BT_UNKNOWN
7313 && !gfc_set_default_type (sym
, 1, NULL
))
7319 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7320 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7328 gfc_error ("Initializing already initialized variable at %C");
7333 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7334 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7337 gfc_free_expr (init
);
7342 /* Match a parameter statement, with the weird syntax that these have. */
7345 gfc_match_parameter (void)
7349 if (gfc_match_char ('(') == MATCH_NO
)
7358 if (gfc_match (" )%t") == MATCH_YES
)
7361 if (gfc_match_char (',') != MATCH_YES
)
7363 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7373 /* Save statements have a special syntax. */
7376 gfc_match_save (void)
7378 char n
[GFC_MAX_SYMBOL_LEN
+1];
7383 if (gfc_match_eos () == MATCH_YES
)
7385 if (gfc_current_ns
->seen_save
)
7387 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7388 "follows previous SAVE statement"))
7392 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7396 if (gfc_current_ns
->save_all
)
7398 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7399 "blanket SAVE statement"))
7407 m
= gfc_match_symbol (&sym
, 0);
7411 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7412 &gfc_current_locus
))
7423 m
= gfc_match (" / %n /", &n
);
7424 if (m
== MATCH_ERROR
)
7429 c
= gfc_get_common (n
, 0);
7432 gfc_current_ns
->seen_save
= 1;
7435 if (gfc_match_eos () == MATCH_YES
)
7437 if (gfc_match_char (',') != MATCH_YES
)
7444 gfc_error ("Syntax error in SAVE statement at %C");
7450 gfc_match_value (void)
7455 /* This is not allowed within a BLOCK construct! */
7456 if (gfc_current_state () == COMP_BLOCK
)
7458 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7462 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7465 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7470 if (gfc_match_eos () == MATCH_YES
)
7475 m
= gfc_match_symbol (&sym
, 0);
7479 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7491 if (gfc_match_eos () == MATCH_YES
)
7493 if (gfc_match_char (',') != MATCH_YES
)
7500 gfc_error ("Syntax error in VALUE statement at %C");
7506 gfc_match_volatile (void)
7511 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7514 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7519 if (gfc_match_eos () == MATCH_YES
)
7524 /* VOLATILE is special because it can be added to host-associated
7525 symbols locally. Except for coarrays. */
7526 m
= gfc_match_symbol (&sym
, 1);
7530 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7531 for variable in a BLOCK which is defined outside of the BLOCK. */
7532 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7534 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7535 "%C, which is use-/host-associated", sym
->name
);
7538 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7550 if (gfc_match_eos () == MATCH_YES
)
7552 if (gfc_match_char (',') != MATCH_YES
)
7559 gfc_error ("Syntax error in VOLATILE statement at %C");
7565 gfc_match_asynchronous (void)
7570 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7573 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7578 if (gfc_match_eos () == MATCH_YES
)
7583 /* ASYNCHRONOUS is special because it can be added to host-associated
7585 m
= gfc_match_symbol (&sym
, 1);
7589 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7601 if (gfc_match_eos () == MATCH_YES
)
7603 if (gfc_match_char (',') != MATCH_YES
)
7610 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7615 /* Match a module procedure statement in a submodule. */
7618 gfc_match_submod_proc (void)
7620 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7621 gfc_symbol
*sym
, *fsym
;
7623 gfc_formal_arglist
*formal
, *head
, *tail
;
7625 if (gfc_current_state () != COMP_CONTAINS
7626 || !(gfc_state_stack
->previous
7627 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7630 m
= gfc_match (" module% procedure% %n", name
);
7634 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7638 if (get_proc_name (name
, &sym
, false))
7641 /* Make sure that the result field is appropriately filled, even though
7642 the result symbol will be replaced later on. */
7643 if (sym
->ts
.interface
->attr
.function
)
7645 if (sym
->ts
.interface
->result
7646 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7647 sym
->result
= sym
->ts
.interface
->result
;
7652 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7653 the symbol existed before. */
7654 sym
->declared_at
= gfc_current_locus
;
7656 if (!sym
->attr
.module_procedure
)
7659 /* Signal match_end to expect "end procedure". */
7660 sym
->abr_modproc_decl
= 1;
7662 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7663 sym
->attr
.if_source
= IFSRC_DECL
;
7665 gfc_new_block
= sym
;
7667 /* Make a new formal arglist with the symbols in the procedure
7670 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7672 if (formal
== sym
->formal
)
7673 head
= tail
= gfc_get_formal_arglist ();
7676 tail
->next
= gfc_get_formal_arglist ();
7680 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7684 gfc_set_sym_referenced (fsym
);
7687 /* The dummy symbols get cleaned up, when the formal_namespace of the
7688 interface declaration is cleared. This allows us to add the
7689 explicit interface as is done for other type of procedure. */
7690 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7691 &gfc_current_locus
))
7694 if (gfc_match_eos () != MATCH_YES
)
7696 gfc_syntax_error (ST_MODULE_PROC
);
7703 gfc_free_formal_arglist (head
);
7708 /* Match a module procedure statement. Note that we have to modify
7709 symbols in the parent's namespace because the current one was there
7710 to receive symbols that are in an interface's formal argument list. */
7713 gfc_match_modproc (void)
7715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7719 gfc_namespace
*module_ns
;
7720 gfc_interface
*old_interface_head
, *interface
;
7722 if (gfc_state_stack
->state
!= COMP_INTERFACE
7723 || gfc_state_stack
->previous
== NULL
7724 || current_interface
.type
== INTERFACE_NAMELESS
7725 || current_interface
.type
== INTERFACE_ABSTRACT
)
7727 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7732 module_ns
= gfc_current_ns
->parent
;
7733 for (; module_ns
; module_ns
= module_ns
->parent
)
7734 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7735 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7736 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7737 && !module_ns
->proc_name
->attr
.contained
))
7740 if (module_ns
== NULL
)
7743 /* Store the current state of the interface. We will need it if we
7744 end up with a syntax error and need to recover. */
7745 old_interface_head
= gfc_current_interface_head ();
7747 /* Check if the F2008 optional double colon appears. */
7748 gfc_gobble_whitespace ();
7749 old_locus
= gfc_current_locus
;
7750 if (gfc_match ("::") == MATCH_YES
)
7752 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7753 "MODULE PROCEDURE statement at %L", &old_locus
))
7757 gfc_current_locus
= old_locus
;
7762 old_locus
= gfc_current_locus
;
7764 m
= gfc_match_name (name
);
7770 /* Check for syntax error before starting to add symbols to the
7771 current namespace. */
7772 if (gfc_match_eos () == MATCH_YES
)
7775 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7778 /* Now we're sure the syntax is valid, we process this item
7780 if (gfc_get_symbol (name
, module_ns
, &sym
))
7783 if (sym
->attr
.intrinsic
)
7785 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7786 "PROCEDURE", &old_locus
);
7790 if (sym
->attr
.proc
!= PROC_MODULE
7791 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7794 if (!gfc_add_interface (sym
))
7797 sym
->attr
.mod_proc
= 1;
7798 sym
->declared_at
= old_locus
;
7807 /* Restore the previous state of the interface. */
7808 interface
= gfc_current_interface_head ();
7809 gfc_set_current_interface_head (old_interface_head
);
7811 /* Free the new interfaces. */
7812 while (interface
!= old_interface_head
)
7814 gfc_interface
*i
= interface
->next
;
7819 /* And issue a syntax error. */
7820 gfc_syntax_error (ST_MODULE_PROC
);
7825 /* Check a derived type that is being extended. */
7828 check_extended_derived_type (char *name
)
7830 gfc_symbol
*extended
;
7832 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7834 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7838 extended
= gfc_find_dt_in_generic (extended
);
7843 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7847 if (extended
->attr
.flavor
!= FL_DERIVED
)
7849 gfc_error ("%qs in EXTENDS expression at %C is not a "
7850 "derived type", name
);
7854 if (extended
->attr
.is_bind_c
)
7856 gfc_error ("%qs cannot be extended at %C because it "
7857 "is BIND(C)", extended
->name
);
7861 if (extended
->attr
.sequence
)
7863 gfc_error ("%qs cannot be extended at %C because it "
7864 "is a SEQUENCE type", extended
->name
);
7872 /* Match the optional attribute specifiers for a type declaration.
7873 Return MATCH_ERROR if an error is encountered in one of the handled
7874 attributes (public, private, bind(c)), MATCH_NO if what's found is
7875 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7876 checking on attribute conflicts needs to be done. */
7879 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7881 /* See if the derived type is marked as private. */
7882 if (gfc_match (" , private") == MATCH_YES
)
7884 if (gfc_current_state () != COMP_MODULE
)
7886 gfc_error ("Derived type at %C can only be PRIVATE in the "
7887 "specification part of a module");
7891 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7894 else if (gfc_match (" , public") == MATCH_YES
)
7896 if (gfc_current_state () != COMP_MODULE
)
7898 gfc_error ("Derived type at %C can only be PUBLIC in the "
7899 "specification part of a module");
7903 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7906 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7908 /* If the type is defined to be bind(c) it then needs to make
7909 sure that all fields are interoperable. This will
7910 need to be a semantic check on the finished derived type.
7911 See 15.2.3 (lines 9-12) of F2003 draft. */
7912 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7915 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7917 else if (gfc_match (" , abstract") == MATCH_YES
)
7919 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7922 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7925 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7927 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7933 /* If we get here, something matched. */
7938 /* Match the beginning of a derived type declaration. If a type name
7939 was the result of a function, then it is possible to have a symbol
7940 already to be known as a derived type yet have no components. */
7943 gfc_match_derived_decl (void)
7945 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7946 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7947 symbol_attribute attr
;
7948 gfc_symbol
*sym
, *gensym
;
7949 gfc_symbol
*extended
;
7951 match is_type_attr_spec
= MATCH_NO
;
7952 bool seen_attr
= false;
7953 gfc_interface
*intr
= NULL
, *head
;
7955 if (gfc_current_state () == COMP_DERIVED
)
7960 gfc_clear_attr (&attr
);
7965 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7966 if (is_type_attr_spec
== MATCH_ERROR
)
7968 if (is_type_attr_spec
== MATCH_YES
)
7970 } while (is_type_attr_spec
== MATCH_YES
);
7972 /* Deal with derived type extensions. The extension attribute has
7973 been added to 'attr' but now the parent type must be found and
7976 extended
= check_extended_derived_type (parent
);
7978 if (parent
[0] && !extended
)
7981 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7983 gfc_error ("Expected :: in TYPE definition at %C");
7987 m
= gfc_match (" %n%t", name
);
7991 /* Make sure the name is not the name of an intrinsic type. */
7992 if (gfc_is_intrinsic_typename (name
))
7994 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
7999 if (gfc_get_symbol (name
, NULL
, &gensym
))
8002 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8004 gfc_error ("Derived type name %qs at %C already has a basic type "
8005 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8009 if (!gensym
->attr
.generic
8010 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8013 if (!gensym
->attr
.function
8014 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8017 sym
= gfc_find_dt_in_generic (gensym
);
8019 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8021 gfc_error ("Derived type definition of %qs at %C has already been "
8022 "defined", sym
->name
);
8028 /* Use upper case to save the actual derived-type symbol. */
8029 gfc_get_symbol (gfc_get_string ("%c%s",
8030 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
8031 &gensym
->name
[1]), NULL
, &sym
);
8032 sym
->name
= gfc_get_string (gensym
->name
);
8033 head
= gensym
->generic
;
8034 intr
= gfc_get_interface ();
8036 intr
->where
= gfc_current_locus
;
8037 intr
->sym
->declared_at
= gfc_current_locus
;
8039 gensym
->generic
= intr
;
8040 gensym
->attr
.if_source
= IFSRC_DECL
;
8043 /* The symbol may already have the derived attribute without the
8044 components. The ways this can happen is via a function
8045 definition, an INTRINSIC statement or a subtype in another
8046 derived type that is a pointer. The first part of the AND clause
8047 is true if the symbol is not the return value of a function. */
8048 if (sym
->attr
.flavor
!= FL_DERIVED
8049 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8052 if (attr
.access
!= ACCESS_UNKNOWN
8053 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8055 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8056 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8057 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8061 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8062 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8063 gensym
->attr
.access
= sym
->attr
.access
;
8065 /* See if the derived type was labeled as bind(c). */
8066 if (attr
.is_bind_c
!= 0)
8067 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8069 /* Construct the f2k_derived namespace if it is not yet there. */
8070 if (!sym
->f2k_derived
)
8071 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8073 if (extended
&& !sym
->components
)
8077 /* Add the extended derived type as the first component. */
8078 gfc_add_component (sym
, parent
, &p
);
8080 gfc_set_sym_referenced (extended
);
8082 p
->ts
.type
= BT_DERIVED
;
8083 p
->ts
.u
.derived
= extended
;
8084 p
->initializer
= gfc_default_initializer (&p
->ts
);
8086 /* Set extension level. */
8087 if (extended
->attr
.extension
== 255)
8089 /* Since the extension field is 8 bit wide, we can only have
8090 up to 255 extension levels. */
8091 gfc_error ("Maximum extension level reached with type %qs at %L",
8092 extended
->name
, &extended
->declared_at
);
8095 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8097 /* Provide the links between the extended type and its extension. */
8098 if (!extended
->f2k_derived
)
8099 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8102 if (!sym
->hash_value
)
8103 /* Set the hash for the compound name for this type. */
8104 sym
->hash_value
= gfc_hash_value (sym
);
8106 /* Take over the ABSTRACT attribute. */
8107 sym
->attr
.abstract
= attr
.abstract
;
8109 gfc_new_block
= sym
;
8115 /* Cray Pointees can be declared as:
8116 pointer (ipt, a (n,m,...,*)) */
8119 gfc_mod_pointee_as (gfc_array_spec
*as
)
8121 as
->cray_pointee
= true; /* This will be useful to know later. */
8122 if (as
->type
== AS_ASSUMED_SIZE
)
8123 as
->cp_was_assumed
= true;
8124 else if (as
->type
== AS_ASSUMED_SHAPE
)
8126 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8133 /* Match the enum definition statement, here we are trying to match
8134 the first line of enum definition statement.
8135 Returns MATCH_YES if match is found. */
8138 gfc_match_enum (void)
8142 m
= gfc_match_eos ();
8146 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8153 /* Returns an initializer whose value is one higher than the value of the
8154 LAST_INITIALIZER argument. If the argument is NULL, the
8155 initializers value will be set to zero. The initializer's kind
8156 will be set to gfc_c_int_kind.
8158 If -fshort-enums is given, the appropriate kind will be selected
8159 later after all enumerators have been parsed. A warning is issued
8160 here if an initializer exceeds gfc_c_int_kind. */
8163 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8166 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8168 mpz_init (result
->value
.integer
);
8170 if (last_initializer
!= NULL
)
8172 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8173 result
->where
= last_initializer
->where
;
8175 if (gfc_check_integer_range (result
->value
.integer
,
8176 gfc_c_int_kind
) != ARITH_OK
)
8178 gfc_error ("Enumerator exceeds the C integer type at %C");
8184 /* Control comes here, if it's the very first enumerator and no
8185 initializer has been given. It will be initialized to zero. */
8186 mpz_set_si (result
->value
.integer
, 0);
8193 /* Match a variable name with an optional initializer. When this
8194 subroutine is called, a variable is expected to be parsed next.
8195 Depending on what is happening at the moment, updates either the
8196 symbol table or the current interface. */
8199 enumerator_decl (void)
8201 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8202 gfc_expr
*initializer
;
8203 gfc_array_spec
*as
= NULL
;
8211 old_locus
= gfc_current_locus
;
8213 /* When we get here, we've just matched a list of attributes and
8214 maybe a type and a double colon. The next thing we expect to see
8215 is the name of the symbol. */
8216 m
= gfc_match_name (name
);
8220 var_locus
= gfc_current_locus
;
8222 /* OK, we've successfully matched the declaration. Now put the
8223 symbol in the current namespace. If we fail to create the symbol,
8225 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8231 /* The double colon must be present in order to have initializers.
8232 Otherwise the statement is ambiguous with an assignment statement. */
8235 if (gfc_match_char ('=') == MATCH_YES
)
8237 m
= gfc_match_init_expr (&initializer
);
8240 gfc_error ("Expected an initialization expression at %C");
8249 /* If we do not have an initializer, the initialization value of the
8250 previous enumerator (stored in last_initializer) is incremented
8251 by 1 and is used to initialize the current enumerator. */
8252 if (initializer
== NULL
)
8253 initializer
= enum_initializer (last_initializer
, old_locus
);
8255 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8257 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8263 /* Store this current initializer, for the next enumerator variable
8264 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8265 use last_initializer below. */
8266 last_initializer
= initializer
;
8267 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8269 /* Maintain enumerator history. */
8270 gfc_find_symbol (name
, NULL
, 0, &sym
);
8271 create_enum_history (sym
, last_initializer
);
8273 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8276 /* Free stuff up and return. */
8277 gfc_free_expr (initializer
);
8283 /* Match the enumerator definition statement. */
8286 gfc_match_enumerator_def (void)
8291 gfc_clear_ts (¤t_ts
);
8293 m
= gfc_match (" enumerator");
8297 m
= gfc_match (" :: ");
8298 if (m
== MATCH_ERROR
)
8301 colon_seen
= (m
== MATCH_YES
);
8303 if (gfc_current_state () != COMP_ENUM
)
8305 gfc_error ("ENUM definition statement expected before %C");
8306 gfc_free_enum_history ();
8310 (¤t_ts
)->type
= BT_INTEGER
;
8311 (¤t_ts
)->kind
= gfc_c_int_kind
;
8313 gfc_clear_attr (¤t_attr
);
8314 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8323 m
= enumerator_decl ();
8324 if (m
== MATCH_ERROR
)
8326 gfc_free_enum_history ();
8332 if (gfc_match_eos () == MATCH_YES
)
8334 if (gfc_match_char (',') != MATCH_YES
)
8338 if (gfc_current_state () == COMP_ENUM
)
8340 gfc_free_enum_history ();
8341 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8346 gfc_free_array_spec (current_as
);
8353 /* Match binding attributes. */
8356 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8358 bool found_passing
= false;
8359 bool seen_ptr
= false;
8360 match m
= MATCH_YES
;
8362 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8363 this case the defaults are in there. */
8364 ba
->access
= ACCESS_UNKNOWN
;
8365 ba
->pass_arg
= NULL
;
8366 ba
->pass_arg_num
= 0;
8368 ba
->non_overridable
= 0;
8372 /* If we find a comma, we believe there are binding attributes. */
8373 m
= gfc_match_char (',');
8379 /* Access specifier. */
8381 m
= gfc_match (" public");
8382 if (m
== MATCH_ERROR
)
8386 if (ba
->access
!= ACCESS_UNKNOWN
)
8388 gfc_error ("Duplicate access-specifier at %C");
8392 ba
->access
= ACCESS_PUBLIC
;
8396 m
= gfc_match (" private");
8397 if (m
== MATCH_ERROR
)
8401 if (ba
->access
!= ACCESS_UNKNOWN
)
8403 gfc_error ("Duplicate access-specifier at %C");
8407 ba
->access
= ACCESS_PRIVATE
;
8411 /* If inside GENERIC, the following is not allowed. */
8416 m
= gfc_match (" nopass");
8417 if (m
== MATCH_ERROR
)
8423 gfc_error ("Binding attributes already specify passing,"
8424 " illegal NOPASS at %C");
8428 found_passing
= true;
8433 /* PASS possibly including argument. */
8434 m
= gfc_match (" pass");
8435 if (m
== MATCH_ERROR
)
8439 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8443 gfc_error ("Binding attributes already specify passing,"
8444 " illegal PASS at %C");
8448 m
= gfc_match (" ( %n )", arg
);
8449 if (m
== MATCH_ERROR
)
8452 ba
->pass_arg
= gfc_get_string (arg
);
8453 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8455 found_passing
= true;
8463 m
= gfc_match (" pointer");
8464 if (m
== MATCH_ERROR
)
8470 gfc_error ("Duplicate POINTER attribute at %C");
8480 /* NON_OVERRIDABLE flag. */
8481 m
= gfc_match (" non_overridable");
8482 if (m
== MATCH_ERROR
)
8486 if (ba
->non_overridable
)
8488 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8492 ba
->non_overridable
= 1;
8496 /* DEFERRED flag. */
8497 m
= gfc_match (" deferred");
8498 if (m
== MATCH_ERROR
)
8504 gfc_error ("Duplicate DEFERRED at %C");
8515 /* Nothing matching found. */
8517 gfc_error ("Expected access-specifier at %C");
8519 gfc_error ("Expected binding attribute at %C");
8522 while (gfc_match_char (',') == MATCH_YES
);
8524 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8525 if (ba
->non_overridable
&& ba
->deferred
)
8527 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8534 if (ba
->access
== ACCESS_UNKNOWN
)
8535 ba
->access
= gfc_typebound_default_access
;
8537 if (ppc
&& !seen_ptr
)
8539 gfc_error ("POINTER attribute is required for procedure pointer component"
8551 /* Match a PROCEDURE specific binding inside a derived type. */
8554 match_procedure_in_type (void)
8556 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8557 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8558 char* target
= NULL
, *ifc
= NULL
;
8559 gfc_typebound_proc tb
;
8568 /* Check current state. */
8569 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8570 block
= gfc_state_stack
->previous
->sym
;
8573 /* Try to match PROCEDURE(interface). */
8574 if (gfc_match (" (") == MATCH_YES
)
8576 m
= gfc_match_name (target_buf
);
8577 if (m
== MATCH_ERROR
)
8581 gfc_error ("Interface-name expected after %<(%> at %C");
8585 if (gfc_match (" )") != MATCH_YES
)
8587 gfc_error ("%<)%> expected at %C");
8594 /* Construct the data structure. */
8595 memset (&tb
, 0, sizeof (tb
));
8596 tb
.where
= gfc_current_locus
;
8598 /* Match binding attributes. */
8599 m
= match_binding_attributes (&tb
, false, false);
8600 if (m
== MATCH_ERROR
)
8602 seen_attrs
= (m
== MATCH_YES
);
8604 /* Check that attribute DEFERRED is given if an interface is specified. */
8605 if (tb
.deferred
&& !ifc
)
8607 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8610 if (ifc
&& !tb
.deferred
)
8612 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8616 /* Match the colons. */
8617 m
= gfc_match (" ::");
8618 if (m
== MATCH_ERROR
)
8620 seen_colons
= (m
== MATCH_YES
);
8621 if (seen_attrs
&& !seen_colons
)
8623 gfc_error ("Expected %<::%> after binding-attributes at %C");
8627 /* Match the binding names. */
8630 m
= gfc_match_name (name
);
8631 if (m
== MATCH_ERROR
)
8635 gfc_error ("Expected binding name at %C");
8639 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8642 /* Try to match the '=> target', if it's there. */
8644 m
= gfc_match (" =>");
8645 if (m
== MATCH_ERROR
)
8651 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8657 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8662 m
= gfc_match_name (target_buf
);
8663 if (m
== MATCH_ERROR
)
8667 gfc_error ("Expected binding target after %<=>%> at %C");
8670 target
= target_buf
;
8673 /* If no target was found, it has the same name as the binding. */
8677 /* Get the namespace to insert the symbols into. */
8678 ns
= block
->f2k_derived
;
8681 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8682 if (tb
.deferred
&& !block
->attr
.abstract
)
8684 gfc_error ("Type %qs containing DEFERRED binding at %C "
8685 "is not ABSTRACT", block
->name
);
8689 /* See if we already have a binding with this name in the symtree which
8690 would be an error. If a GENERIC already targeted this binding, it may
8691 be already there but then typebound is still NULL. */
8692 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8693 if (stree
&& stree
->n
.tb
)
8695 gfc_error ("There is already a procedure with binding name %qs for "
8696 "the derived type %qs at %C", name
, block
->name
);
8700 /* Insert it and set attributes. */
8704 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8707 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8709 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8712 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8714 if (gfc_match_eos () == MATCH_YES
)
8716 if (gfc_match_char (',') != MATCH_YES
)
8721 gfc_error ("Syntax error in PROCEDURE statement at %C");
8726 /* Match a GENERIC procedure binding inside a derived type. */
8729 gfc_match_generic (void)
8731 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8732 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8734 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8735 gfc_typebound_proc
* tb
;
8737 interface_type op_type
;
8738 gfc_intrinsic_op op
;
8741 /* Check current state. */
8742 if (gfc_current_state () == COMP_DERIVED
)
8744 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8747 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8749 block
= gfc_state_stack
->previous
->sym
;
8750 ns
= block
->f2k_derived
;
8751 gcc_assert (block
&& ns
);
8753 memset (&tbattr
, 0, sizeof (tbattr
));
8754 tbattr
.where
= gfc_current_locus
;
8756 /* See if we get an access-specifier. */
8757 m
= match_binding_attributes (&tbattr
, true, false);
8758 if (m
== MATCH_ERROR
)
8761 /* Now the colons, those are required. */
8762 if (gfc_match (" ::") != MATCH_YES
)
8764 gfc_error ("Expected %<::%> at %C");
8768 /* Match the binding name; depending on type (operator / generic) format
8769 it for future error messages into bind_name. */
8771 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8772 if (m
== MATCH_ERROR
)
8776 gfc_error ("Expected generic name or operator descriptor at %C");
8782 case INTERFACE_GENERIC
:
8783 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8786 case INTERFACE_USER_OP
:
8787 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8790 case INTERFACE_INTRINSIC_OP
:
8791 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8792 gfc_op2string (op
));
8795 case INTERFACE_NAMELESS
:
8796 gfc_error ("Malformed GENERIC statement at %C");
8804 /* Match the required =>. */
8805 if (gfc_match (" =>") != MATCH_YES
)
8807 gfc_error ("Expected %<=>%> at %C");
8811 /* Try to find existing GENERIC binding with this name / for this operator;
8812 if there is something, check that it is another GENERIC and then extend
8813 it rather than building a new node. Otherwise, create it and put it
8814 at the right position. */
8818 case INTERFACE_USER_OP
:
8819 case INTERFACE_GENERIC
:
8821 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8824 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8836 case INTERFACE_INTRINSIC_OP
:
8846 if (!tb
->is_generic
)
8848 gcc_assert (op_type
== INTERFACE_GENERIC
);
8849 gfc_error ("There's already a non-generic procedure with binding name"
8850 " %qs for the derived type %qs at %C",
8851 bind_name
, block
->name
);
8855 if (tb
->access
!= tbattr
.access
)
8857 gfc_error ("Binding at %C must have the same access as already"
8858 " defined binding %qs", bind_name
);
8864 tb
= gfc_get_typebound_proc (NULL
);
8865 tb
->where
= gfc_current_locus
;
8866 tb
->access
= tbattr
.access
;
8868 tb
->u
.generic
= NULL
;
8872 case INTERFACE_GENERIC
:
8873 case INTERFACE_USER_OP
:
8875 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8878 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8886 case INTERFACE_INTRINSIC_OP
:
8895 /* Now, match all following names as specific targets. */
8898 gfc_symtree
* target_st
;
8899 gfc_tbp_generic
* target
;
8901 m
= gfc_match_name (name
);
8902 if (m
== MATCH_ERROR
)
8906 gfc_error ("Expected specific binding name at %C");
8910 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8912 /* See if this is a duplicate specification. */
8913 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8914 if (target_st
== target
->specific_st
)
8916 gfc_error ("%qs already defined as specific binding for the"
8917 " generic %qs at %C", name
, bind_name
);
8921 target
= gfc_get_tbp_generic ();
8922 target
->specific_st
= target_st
;
8923 target
->specific
= NULL
;
8924 target
->next
= tb
->u
.generic
;
8925 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8926 || (op_type
== INTERFACE_INTRINSIC_OP
));
8927 tb
->u
.generic
= target
;
8929 while (gfc_match (" ,") == MATCH_YES
);
8931 /* Here should be the end. */
8932 if (gfc_match_eos () != MATCH_YES
)
8934 gfc_error ("Junk after GENERIC binding at %C");
8945 /* Match a FINAL declaration inside a derived type. */
8948 gfc_match_final_decl (void)
8950 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8953 gfc_namespace
* module_ns
;
8957 if (gfc_current_form
== FORM_FREE
)
8959 char c
= gfc_peek_ascii_char ();
8960 if (!gfc_is_whitespace (c
) && c
!= ':')
8964 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8966 if (gfc_current_form
== FORM_FIXED
)
8969 gfc_error ("FINAL declaration at %C must be inside a derived type "
8970 "CONTAINS section");
8974 block
= gfc_state_stack
->previous
->sym
;
8977 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8978 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8980 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8981 " specification part of a MODULE");
8985 module_ns
= gfc_current_ns
;
8986 gcc_assert (module_ns
);
8987 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8989 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8990 if (gfc_match (" ::") == MATCH_ERROR
)
8993 /* Match the sequence of procedure names. */
9000 if (first
&& gfc_match_eos () == MATCH_YES
)
9002 gfc_error ("Empty FINAL at %C");
9006 m
= gfc_match_name (name
);
9009 gfc_error ("Expected module procedure name at %C");
9012 else if (m
!= MATCH_YES
)
9015 if (gfc_match_eos () == MATCH_YES
)
9017 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9019 gfc_error ("Expected %<,%> at %C");
9023 if (gfc_get_symbol (name
, module_ns
, &sym
))
9025 gfc_error ("Unknown procedure name %qs at %C", name
);
9029 /* Mark the symbol as module procedure. */
9030 if (sym
->attr
.proc
!= PROC_MODULE
9031 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9034 /* Check if we already have this symbol in the list, this is an error. */
9035 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9036 if (f
->proc_sym
== sym
)
9038 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9043 /* Add this symbol to the list of finalizers. */
9044 gcc_assert (block
->f2k_derived
);
9046 f
= XCNEW (gfc_finalizer
);
9048 f
->proc_tree
= NULL
;
9049 f
->where
= gfc_current_locus
;
9050 f
->next
= block
->f2k_derived
->finalizers
;
9051 block
->f2k_derived
->finalizers
= f
;
9061 const ext_attr_t ext_attr_list
[] = {
9062 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9063 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9064 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9065 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9066 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9067 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9068 { NULL
, EXT_ATTR_LAST
, NULL
}
9071 /* Match a !GCC$ ATTRIBUTES statement of the form:
9072 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9073 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9075 TODO: We should support all GCC attributes using the same syntax for
9076 the attribute list, i.e. the list in C
9077 __attributes(( attribute-list ))
9079 !GCC$ ATTRIBUTES attribute-list ::
9080 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9083 As there is absolutely no risk of confusion, we should never return
9086 gfc_match_gcc_attributes (void)
9088 symbol_attribute attr
;
9089 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9094 gfc_clear_attr (&attr
);
9099 if (gfc_match_name (name
) != MATCH_YES
)
9102 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9103 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9106 if (id
== EXT_ATTR_LAST
)
9108 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9112 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9115 gfc_gobble_whitespace ();
9116 ch
= gfc_next_ascii_char ();
9119 /* This is the successful exit condition for the loop. */
9120 if (gfc_next_ascii_char () == ':')
9130 if (gfc_match_eos () == MATCH_YES
)
9135 m
= gfc_match_name (name
);
9139 if (find_special (name
, &sym
, true))
9142 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9144 if (gfc_match_eos () == MATCH_YES
)
9147 if (gfc_match_char (',') != MATCH_YES
)
9154 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");