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
);
1297 if (expr
->ts
.type
!= BT_CHARACTER
)
1300 slen
= expr
->value
.character
.length
;
1303 s
= gfc_get_wide_string (len
+ 1);
1304 memcpy (s
, expr
->value
.character
.string
,
1305 MIN (len
, slen
) * sizeof (gfc_char_t
));
1307 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1309 if (warn_character_truncation
&& slen
> len
)
1310 gfc_warning_now (OPT_Wcharacter_truncation
,
1311 "CHARACTER expression at %L is being truncated "
1312 "(%d/%d)", &expr
->where
, slen
, len
);
1314 /* Apply the standard by 'hand' otherwise it gets cleared for
1316 if (check_len
!= -1 && slen
!= check_len
1317 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1318 gfc_error_now ("The CHARACTER elements of the array constructor "
1319 "at %L must have the same length (%d/%d)",
1320 &expr
->where
, slen
, check_len
);
1323 free (expr
->value
.character
.string
);
1324 expr
->value
.character
.string
= s
;
1325 expr
->value
.character
.length
= len
;
1330 /* Function to create and update the enumerator history
1331 using the information passed as arguments.
1332 Pointer "max_enum" is also updated, to point to
1333 enum history node containing largest initializer.
1335 SYM points to the symbol node of enumerator.
1336 INIT points to its enumerator value. */
1339 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1341 enumerator_history
*new_enum_history
;
1342 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1344 new_enum_history
= XCNEW (enumerator_history
);
1346 new_enum_history
->sym
= sym
;
1347 new_enum_history
->initializer
= init
;
1348 new_enum_history
->next
= NULL
;
1350 if (enum_history
== NULL
)
1352 enum_history
= new_enum_history
;
1353 max_enum
= enum_history
;
1357 new_enum_history
->next
= enum_history
;
1358 enum_history
= new_enum_history
;
1360 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1361 new_enum_history
->initializer
->value
.integer
) < 0)
1362 max_enum
= new_enum_history
;
1367 /* Function to free enum kind history. */
1370 gfc_free_enum_history (void)
1372 enumerator_history
*current
= enum_history
;
1373 enumerator_history
*next
;
1375 while (current
!= NULL
)
1377 next
= current
->next
;
1382 enum_history
= NULL
;
1386 /* Function called by variable_decl() that adds an initialization
1387 expression to a symbol. */
1390 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1392 symbol_attribute attr
;
1397 if (find_special (name
, &sym
, false))
1402 /* If this symbol is confirming an implicit parameter type,
1403 then an initialization expression is not allowed. */
1404 if (attr
.flavor
== FL_PARAMETER
1405 && sym
->value
!= NULL
1408 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1415 /* An initializer is required for PARAMETER declarations. */
1416 if (attr
.flavor
== FL_PARAMETER
)
1418 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1424 /* If a variable appears in a DATA block, it cannot have an
1428 gfc_error ("Variable %qs at %C with an initializer already "
1429 "appears in a DATA statement", sym
->name
);
1433 /* Check if the assignment can happen. This has to be put off
1434 until later for derived type variables and procedure pointers. */
1435 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1436 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1437 && !sym
->attr
.proc_pointer
1438 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1441 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1442 && init
->ts
.type
== BT_CHARACTER
)
1444 /* Update symbol character length according initializer. */
1445 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1448 if (sym
->ts
.u
.cl
->length
== NULL
)
1451 /* If there are multiple CHARACTER variables declared on the
1452 same line, we don't want them to share the same length. */
1453 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1455 if (sym
->attr
.flavor
== FL_PARAMETER
)
1457 if (init
->expr_type
== EXPR_CONSTANT
)
1459 clen
= init
->value
.character
.length
;
1460 sym
->ts
.u
.cl
->length
1461 = gfc_get_int_expr (gfc_default_integer_kind
,
1464 else if (init
->expr_type
== EXPR_ARRAY
)
1467 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1468 else if (init
->value
.constructor
)
1471 c
= gfc_constructor_first (init
->value
.constructor
);
1472 clen
= c
->expr
->value
.character
.length
;
1476 sym
->ts
.u
.cl
->length
1477 = gfc_get_int_expr (gfc_default_integer_kind
,
1480 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1481 sym
->ts
.u
.cl
->length
=
1482 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1485 /* Update initializer character length according symbol. */
1486 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1490 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1493 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1495 if (init
->expr_type
== EXPR_CONSTANT
)
1496 gfc_set_constant_character_len (len
, init
, -1);
1497 else if (init
->expr_type
== EXPR_ARRAY
)
1501 /* Build a new charlen to prevent simplification from
1502 deleting the length before it is resolved. */
1503 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1504 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1506 for (c
= gfc_constructor_first (init
->value
.constructor
);
1507 c
; c
= gfc_constructor_next (c
))
1508 gfc_set_constant_character_len (len
, c
->expr
, -1);
1513 /* If sym is implied-shape, set its upper bounds from init. */
1514 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1515 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1519 if (init
->rank
== 0)
1521 gfc_error ("Can't initialize implied-shape array at %L"
1522 " with scalar", &sym
->declared_at
);
1526 /* Shape should be present, we get an initialization expression. */
1527 gcc_assert (init
->shape
);
1529 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1532 gfc_expr
*e
, *lower
;
1534 lower
= sym
->as
->lower
[dim
];
1536 /* If the lower bound is an array element from another
1537 parameterized array, then it is marked with EXPR_VARIABLE and
1538 is an initialization expression. Try to reduce it. */
1539 if (lower
->expr_type
== EXPR_VARIABLE
)
1540 gfc_reduce_init_expr (lower
);
1542 if (lower
->expr_type
== EXPR_CONSTANT
)
1544 /* All dimensions must be without upper bound. */
1545 gcc_assert (!sym
->as
->upper
[dim
]);
1548 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1549 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1551 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1552 sym
->as
->upper
[dim
] = e
;
1556 gfc_error ("Non-constant lower bound in implied-shape"
1557 " declaration at %L", &lower
->where
);
1562 sym
->as
->type
= AS_EXPLICIT
;
1565 /* Need to check if the expression we initialized this
1566 to was one of the iso_c_binding named constants. If so,
1567 and we're a parameter (constant), let it be iso_c.
1569 integer(c_int), parameter :: my_int = c_int
1570 integer(my_int) :: my_int_2
1571 If we mark my_int as iso_c (since we can see it's value
1572 is equal to one of the named constants), then my_int_2
1573 will be considered C interoperable. */
1574 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1576 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1577 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1578 /* attr bits needed for module files. */
1579 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1580 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1581 if (init
->ts
.is_iso_c
)
1582 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1585 /* Add initializer. Make sure we keep the ranks sane. */
1586 if (sym
->attr
.dimension
&& init
->rank
== 0)
1591 if (sym
->attr
.flavor
== FL_PARAMETER
1592 && init
->expr_type
== EXPR_CONSTANT
1593 && spec_size (sym
->as
, &size
)
1594 && mpz_cmp_si (size
, 0) > 0)
1596 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1598 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1599 gfc_constructor_append_expr (&array
->value
.constructor
,
1602 : gfc_copy_expr (init
),
1605 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1606 for (n
= 0; n
< sym
->as
->rank
; n
++)
1607 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1612 init
->rank
= sym
->as
->rank
;
1616 if (sym
->attr
.save
== SAVE_NONE
)
1617 sym
->attr
.save
= SAVE_IMPLICIT
;
1625 /* Function called by variable_decl() that adds a name to a structure
1629 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1630 gfc_array_spec
**as
)
1635 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1636 constructing, it must have the pointer attribute. */
1637 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1638 && current_ts
.u
.derived
== gfc_current_block ()
1639 && current_attr
.pointer
== 0)
1641 gfc_error ("Component at %C must have the POINTER attribute");
1645 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1647 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1649 gfc_error ("Array component of structure at %C must have explicit "
1650 "or deferred shape");
1655 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1659 if (c
->ts
.type
== BT_CHARACTER
)
1661 c
->attr
= current_attr
;
1663 c
->initializer
= *init
;
1670 c
->attr
.codimension
= 1;
1672 c
->attr
.dimension
= 1;
1676 /* Should this ever get more complicated, combine with similar section
1677 in add_init_expr_to_sym into a separate function. */
1678 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1680 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1684 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1685 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1686 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1688 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1690 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1691 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1692 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1693 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1695 gfc_constructor
*ctor
;
1696 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1701 bool has_ts
= (c
->initializer
->ts
.u
.cl
1702 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1704 /* Remember the length of the first element for checking
1705 that all elements *in the constructor* have the same
1706 length. This need not be the length of the LHS! */
1707 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1708 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1709 first_len
= ctor
->expr
->value
.character
.length
;
1711 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1712 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1714 gfc_set_constant_character_len (len
, ctor
->expr
,
1715 has_ts
? -1 : first_len
);
1716 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1722 /* Check array components. */
1723 if (!c
->attr
.dimension
)
1726 if (c
->attr
.pointer
)
1728 if (c
->as
->type
!= AS_DEFERRED
)
1730 gfc_error ("Pointer array component of structure at %C must have a "
1735 else if (c
->attr
.allocatable
)
1737 if (c
->as
->type
!= AS_DEFERRED
)
1739 gfc_error ("Allocatable component of structure at %C must have a "
1746 if (c
->as
->type
!= AS_EXPLICIT
)
1748 gfc_error ("Array component of structure at %C must have an "
1755 if (c
->ts
.type
== BT_CLASS
)
1757 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1767 /* Match a 'NULL()', and possibly take care of some side effects. */
1770 gfc_match_null (gfc_expr
**result
)
1773 match m
, m2
= MATCH_NO
;
1775 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1781 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1783 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1786 old_loc
= gfc_current_locus
;
1787 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1790 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1794 gfc_current_locus
= old_loc
;
1799 /* The NULL symbol now has to be/become an intrinsic function. */
1800 if (gfc_get_symbol ("null", NULL
, &sym
))
1802 gfc_error ("NULL() initialization at %C is ambiguous");
1806 gfc_intrinsic_symbol (sym
);
1808 if (sym
->attr
.proc
!= PROC_INTRINSIC
1809 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1810 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1811 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1814 *result
= gfc_get_null_expr (&gfc_current_locus
);
1816 /* Invalid per F2008, C512. */
1817 if (m2
== MATCH_YES
)
1819 gfc_error ("NULL() initialization at %C may not have MOLD");
1827 /* Match the initialization expr for a data pointer or procedure pointer. */
1830 match_pointer_init (gfc_expr
**init
, int procptr
)
1834 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1836 gfc_error ("Initialization of pointer at %C is not allowed in "
1837 "a PURE procedure");
1840 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1842 /* Match NULL() initialization. */
1843 m
= gfc_match_null (init
);
1847 /* Match non-NULL initialization. */
1848 gfc_matching_ptr_assignment
= !procptr
;
1849 gfc_matching_procptr_assignment
= procptr
;
1850 m
= gfc_match_rvalue (init
);
1851 gfc_matching_ptr_assignment
= 0;
1852 gfc_matching_procptr_assignment
= 0;
1853 if (m
== MATCH_ERROR
)
1855 else if (m
== MATCH_NO
)
1857 gfc_error ("Error in pointer initialization at %C");
1861 if (!procptr
&& !gfc_resolve_expr (*init
))
1864 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1865 "initialization at %C"))
1873 check_function_name (char *name
)
1875 /* In functions that have a RESULT variable defined, the function name always
1876 refers to function calls. Therefore, the name is not allowed to appear in
1877 specification statements. When checking this, be careful about
1878 'hidden' procedure pointer results ('ppr@'). */
1880 if (gfc_current_state () == COMP_FUNCTION
)
1882 gfc_symbol
*block
= gfc_current_block ();
1883 if (block
&& block
->result
&& block
->result
!= block
1884 && strcmp (block
->result
->name
, "ppr@") != 0
1885 && strcmp (block
->name
, name
) == 0)
1887 gfc_error ("Function name %qs not allowed at %C", name
);
1896 /* Match a variable name with an optional initializer. When this
1897 subroutine is called, a variable is expected to be parsed next.
1898 Depending on what is happening at the moment, updates either the
1899 symbol table or the current interface. */
1902 variable_decl (int elem
)
1904 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1905 gfc_expr
*initializer
, *char_len
;
1907 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1919 /* When we get here, we've just matched a list of attributes and
1920 maybe a type and a double colon. The next thing we expect to see
1921 is the name of the symbol. */
1922 m
= gfc_match_name (name
);
1926 var_locus
= gfc_current_locus
;
1928 /* Now we could see the optional array spec. or character length. */
1929 m
= gfc_match_array_spec (&as
, true, true);
1930 if (m
== MATCH_ERROR
)
1934 as
= gfc_copy_array_spec (current_as
);
1936 && !merge_array_spec (current_as
, as
, true))
1942 if (flag_cray_pointer
)
1943 cp_as
= gfc_copy_array_spec (as
);
1945 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1946 determine (and check) whether it can be implied-shape. If it
1947 was parsed as assumed-size, change it because PARAMETERs can not
1951 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1954 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1959 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1960 && current_attr
.flavor
== FL_PARAMETER
)
1961 as
->type
= AS_IMPLIED_SHAPE
;
1963 if (as
->type
== AS_IMPLIED_SHAPE
1964 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1974 cl_deferred
= false;
1976 if (current_ts
.type
== BT_CHARACTER
)
1978 switch (match_char_length (&char_len
, &cl_deferred
, false))
1981 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1983 cl
->length
= char_len
;
1986 /* Non-constant lengths need to be copied after the first
1987 element. Also copy assumed lengths. */
1990 && (current_ts
.u
.cl
->length
== NULL
1991 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1993 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1994 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1997 cl
= current_ts
.u
.cl
;
1999 cl_deferred
= current_ts
.deferred
;
2008 /* The dummy arguments and result of the abreviated form of MODULE
2009 PROCEDUREs, used in SUBMODULES should not be redefined. */
2010 if (gfc_current_ns
->proc_name
2011 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2013 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2014 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2017 gfc_error ("'%s' at %C is a redefinition of the declaration "
2018 "in the corresponding interface for MODULE "
2019 "PROCEDURE '%s'", sym
->name
,
2020 gfc_current_ns
->proc_name
->name
);
2025 /* If this symbol has already shown up in a Cray Pointer declaration,
2026 and this is not a component declaration,
2027 then we want to set the type & bail out. */
2028 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
2030 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2031 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2033 sym
->ts
.type
= current_ts
.type
;
2034 sym
->ts
.kind
= current_ts
.kind
;
2036 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2037 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2038 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2041 /* Check to see if we have an array specification. */
2044 if (sym
->as
!= NULL
)
2046 gfc_error ("Duplicate array spec for Cray pointee at %C");
2047 gfc_free_array_spec (cp_as
);
2053 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2054 gfc_internal_error ("Couldn't set pointee array spec.");
2056 /* Fix the array spec. */
2057 m
= gfc_mod_pointee_as (sym
->as
);
2058 if (m
== MATCH_ERROR
)
2066 gfc_free_array_spec (cp_as
);
2070 /* Procedure pointer as function result. */
2071 if (gfc_current_state () == COMP_FUNCTION
2072 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2073 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2074 strcpy (name
, "ppr@");
2076 if (gfc_current_state () == COMP_FUNCTION
2077 && strcmp (name
, gfc_current_block ()->name
) == 0
2078 && gfc_current_block ()->result
2079 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2080 strcpy (name
, "ppr@");
2082 /* OK, we've successfully matched the declaration. Now put the
2083 symbol in the current namespace, because it might be used in the
2084 optional initialization expression for this symbol, e.g. this is
2087 integer, parameter :: i = huge(i)
2089 This is only true for parameters or variables of a basic type.
2090 For components of derived types, it is not true, so we don't
2091 create a symbol for those yet. If we fail to create the symbol,
2093 if (gfc_current_state () != COMP_DERIVED
2094 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2100 if (!check_function_name (name
))
2106 /* We allow old-style initializations of the form
2107 integer i /2/, j(4) /3*3, 1/
2108 (if no colon has been seen). These are different from data
2109 statements in that initializers are only allowed to apply to the
2110 variable immediately preceding, i.e.
2112 is not allowed. Therefore we have to do some work manually, that
2113 could otherwise be left to the matchers for DATA statements. */
2115 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2117 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2118 "initialization at %C"))
2120 else if (gfc_current_state () == COMP_DERIVED
)
2122 gfc_error ("Invalid old style initialization for derived type "
2128 return match_old_style_init (name
);
2131 /* The double colon must be present in order to have initializers.
2132 Otherwise the statement is ambiguous with an assignment statement. */
2135 if (gfc_match (" =>") == MATCH_YES
)
2137 if (!current_attr
.pointer
)
2139 gfc_error ("Initialization at %C isn't for a pointer variable");
2144 m
= match_pointer_init (&initializer
, 0);
2148 else if (gfc_match_char ('=') == MATCH_YES
)
2150 if (current_attr
.pointer
)
2152 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2158 m
= gfc_match_init_expr (&initializer
);
2161 gfc_error ("Expected an initialization expression at %C");
2165 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2166 && gfc_state_stack
->state
!= COMP_DERIVED
)
2168 gfc_error ("Initialization of variable at %C is not allowed in "
2169 "a PURE procedure");
2173 if (current_attr
.flavor
!= FL_PARAMETER
2174 && gfc_state_stack
->state
!= COMP_DERIVED
)
2175 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2182 if (initializer
!= NULL
&& current_attr
.allocatable
2183 && gfc_current_state () == COMP_DERIVED
)
2185 gfc_error ("Initialization of allocatable component at %C is not "
2191 /* Add the initializer. Note that it is fine if initializer is
2192 NULL here, because we sometimes also need to check if a
2193 declaration *must* have an initialization expression. */
2194 if (gfc_current_state () != COMP_DERIVED
)
2195 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2198 if (current_ts
.type
== BT_DERIVED
2199 && !current_attr
.pointer
&& !initializer
)
2200 initializer
= gfc_default_initializer (¤t_ts
);
2201 t
= build_struct (name
, cl
, &initializer
, &as
);
2204 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2207 /* Free stuff up and return. */
2208 gfc_free_expr (initializer
);
2209 gfc_free_array_spec (as
);
2215 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2216 This assumes that the byte size is equal to the kind number for
2217 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2220 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2225 if (gfc_match_char ('*') != MATCH_YES
)
2228 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2232 original_kind
= ts
->kind
;
2234 /* Massage the kind numbers for complex types. */
2235 if (ts
->type
== BT_COMPLEX
)
2239 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2240 gfc_basic_typename (ts
->type
), original_kind
);
2247 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2250 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2254 if (flag_real4_kind
== 8)
2256 if (flag_real4_kind
== 10)
2258 if (flag_real4_kind
== 16)
2264 if (flag_real8_kind
== 4)
2266 if (flag_real8_kind
== 10)
2268 if (flag_real8_kind
== 16)
2273 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2275 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2276 gfc_basic_typename (ts
->type
), original_kind
);
2280 if (!gfc_notify_std (GFC_STD_GNU
,
2281 "Nonstandard type declaration %s*%d at %C",
2282 gfc_basic_typename(ts
->type
), original_kind
))
2289 /* Match a kind specification. Since kinds are generally optional, we
2290 usually return MATCH_NO if something goes wrong. If a "kind="
2291 string is found, then we know we have an error. */
2294 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2306 where
= loc
= gfc_current_locus
;
2311 if (gfc_match_char ('(') == MATCH_NO
)
2314 /* Also gobbles optional text. */
2315 if (gfc_match (" kind = ") == MATCH_YES
)
2318 loc
= gfc_current_locus
;
2321 n
= gfc_match_init_expr (&e
);
2325 if (gfc_matching_function
)
2327 /* The function kind expression might include use associated or
2328 imported parameters and try again after the specification
2330 if (gfc_match_char (')') != MATCH_YES
)
2332 gfc_error ("Missing right parenthesis at %C");
2338 gfc_undo_symbols ();
2343 /* ....or else, the match is real. */
2345 gfc_error ("Expected initialization expression at %C");
2353 gfc_error ("Expected scalar initialization expression at %C");
2358 msg
= gfc_extract_int (e
, &ts
->kind
);
2367 /* Before throwing away the expression, let's see if we had a
2368 C interoperable kind (and store the fact). */
2369 if (e
->ts
.is_c_interop
== 1)
2371 /* Mark this as C interoperable if being declared with one
2372 of the named constants from iso_c_binding. */
2373 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2374 ts
->f90_type
= e
->ts
.f90_type
;
2380 /* Ignore errors to this point, if we've gotten here. This means
2381 we ignore the m=MATCH_ERROR from above. */
2382 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2384 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2385 gfc_basic_typename (ts
->type
));
2386 gfc_current_locus
= where
;
2390 /* Warn if, e.g., c_int is used for a REAL variable, but not
2391 if, e.g., c_double is used for COMPLEX as the standard
2392 explicitly says that the kind type parameter for complex and real
2393 variable is the same, i.e. c_float == c_float_complex. */
2394 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2395 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2396 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2397 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2398 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2399 gfc_basic_typename (ts
->type
));
2401 gfc_gobble_whitespace ();
2402 if ((c
= gfc_next_ascii_char ()) != ')'
2403 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2405 if (ts
->type
== BT_CHARACTER
)
2406 gfc_error ("Missing right parenthesis or comma at %C");
2408 gfc_error ("Missing right parenthesis at %C");
2412 /* All tests passed. */
2415 if(m
== MATCH_ERROR
)
2416 gfc_current_locus
= where
;
2418 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2421 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2425 if (flag_real4_kind
== 8)
2427 if (flag_real4_kind
== 10)
2429 if (flag_real4_kind
== 16)
2435 if (flag_real8_kind
== 4)
2437 if (flag_real8_kind
== 10)
2439 if (flag_real8_kind
== 16)
2444 /* Return what we know from the test(s). */
2449 gfc_current_locus
= where
;
2455 match_char_kind (int * kind
, int * is_iso_c
)
2464 where
= gfc_current_locus
;
2466 n
= gfc_match_init_expr (&e
);
2468 if (n
!= MATCH_YES
&& gfc_matching_function
)
2470 /* The expression might include use-associated or imported
2471 parameters and try again after the specification
2474 gfc_undo_symbols ();
2479 gfc_error ("Expected initialization expression at %C");
2485 gfc_error ("Expected scalar initialization expression at %C");
2490 msg
= gfc_extract_int (e
, kind
);
2491 *is_iso_c
= e
->ts
.is_iso_c
;
2501 /* Ignore errors to this point, if we've gotten here. This means
2502 we ignore the m=MATCH_ERROR from above. */
2503 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2505 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2509 /* All tests passed. */
2512 if (m
== MATCH_ERROR
)
2513 gfc_current_locus
= where
;
2515 /* Return what we know from the test(s). */
2520 gfc_current_locus
= where
;
2525 /* Match the various kind/length specifications in a CHARACTER
2526 declaration. We don't return MATCH_NO. */
2529 gfc_match_char_spec (gfc_typespec
*ts
)
2531 int kind
, seen_length
, is_iso_c
;
2543 /* Try the old-style specification first. */
2544 old_char_selector
= 0;
2546 m
= match_char_length (&len
, &deferred
, true);
2550 old_char_selector
= 1;
2555 m
= gfc_match_char ('(');
2558 m
= MATCH_YES
; /* Character without length is a single char. */
2562 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2563 if (gfc_match (" kind =") == MATCH_YES
)
2565 m
= match_char_kind (&kind
, &is_iso_c
);
2567 if (m
== MATCH_ERROR
)
2572 if (gfc_match (" , len =") == MATCH_NO
)
2575 m
= char_len_param_value (&len
, &deferred
);
2578 if (m
== MATCH_ERROR
)
2585 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2586 if (gfc_match (" len =") == MATCH_YES
)
2588 m
= char_len_param_value (&len
, &deferred
);
2591 if (m
== MATCH_ERROR
)
2595 if (gfc_match_char (')') == MATCH_YES
)
2598 if (gfc_match (" , kind =") != MATCH_YES
)
2601 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2607 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2608 m
= char_len_param_value (&len
, &deferred
);
2611 if (m
== MATCH_ERROR
)
2615 m
= gfc_match_char (')');
2619 if (gfc_match_char (',') != MATCH_YES
)
2622 gfc_match (" kind ="); /* Gobble optional text. */
2624 m
= match_char_kind (&kind
, &is_iso_c
);
2625 if (m
== MATCH_ERROR
)
2631 /* Require a right-paren at this point. */
2632 m
= gfc_match_char (')');
2637 gfc_error ("Syntax error in CHARACTER declaration at %C");
2639 gfc_free_expr (len
);
2643 /* Deal with character functions after USE and IMPORT statements. */
2644 if (gfc_matching_function
)
2646 gfc_free_expr (len
);
2647 gfc_undo_symbols ();
2653 gfc_free_expr (len
);
2657 /* Do some final massaging of the length values. */
2658 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2660 if (seen_length
== 0)
2661 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2666 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2667 ts
->deferred
= deferred
;
2669 /* We have to know if it was a C interoperable kind so we can
2670 do accurate type checking of bind(c) procs, etc. */
2672 /* Mark this as C interoperable if being declared with one
2673 of the named constants from iso_c_binding. */
2674 ts
->is_c_interop
= is_iso_c
;
2675 else if (len
!= NULL
)
2676 /* Here, we might have parsed something such as: character(c_char)
2677 In this case, the parsing code above grabs the c_char when
2678 looking for the length (line 1690, roughly). it's the last
2679 testcase for parsing the kind params of a character variable.
2680 However, it's not actually the length. this seems like it
2682 To see if the user used a C interop kind, test the expr
2683 of the so called length, and see if it's C interoperable. */
2684 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2690 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2691 structure to the matched specification. This is necessary for FUNCTION and
2692 IMPLICIT statements.
2694 If implicit_flag is nonzero, then we don't check for the optional
2695 kind specification. Not doing so is needed for matching an IMPLICIT
2696 statement correctly. */
2699 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2701 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2702 gfc_symbol
*sym
, *dt_sym
;
2705 bool seen_deferred_kind
, matched_type
;
2706 const char *dt_name
;
2708 /* A belt and braces check that the typespec is correctly being treated
2709 as a deferred characteristic association. */
2710 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2711 && (gfc_current_block ()->result
->ts
.kind
== -1)
2712 && (ts
->kind
== -1);
2714 if (seen_deferred_kind
)
2717 /* Clear the current binding label, in case one is given. */
2718 curr_binding_label
= NULL
;
2720 if (gfc_match (" byte") == MATCH_YES
)
2722 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2725 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2727 gfc_error ("BYTE type used at %C "
2728 "is not available on the target machine");
2732 ts
->type
= BT_INTEGER
;
2738 m
= gfc_match (" type (");
2739 matched_type
= (m
== MATCH_YES
);
2742 gfc_gobble_whitespace ();
2743 if (gfc_peek_ascii_char () == '*')
2745 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2747 if (gfc_current_state () == COMP_DERIVED
)
2749 gfc_error ("Assumed type at %C is not allowed for components");
2752 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2755 ts
->type
= BT_ASSUMED
;
2759 m
= gfc_match ("%n", name
);
2760 matched_type
= (m
== MATCH_YES
);
2763 if ((matched_type
&& strcmp ("integer", name
) == 0)
2764 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2766 ts
->type
= BT_INTEGER
;
2767 ts
->kind
= gfc_default_integer_kind
;
2771 if ((matched_type
&& strcmp ("character", name
) == 0)
2772 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2775 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2776 "intrinsic-type-spec at %C"))
2779 ts
->type
= BT_CHARACTER
;
2780 if (implicit_flag
== 0)
2781 m
= gfc_match_char_spec (ts
);
2785 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2791 if ((matched_type
&& strcmp ("real", name
) == 0)
2792 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2795 ts
->kind
= gfc_default_real_kind
;
2800 && (strcmp ("doubleprecision", name
) == 0
2801 || (strcmp ("double", name
) == 0
2802 && gfc_match (" precision") == MATCH_YES
)))
2803 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2806 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2807 "intrinsic-type-spec at %C"))
2809 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2813 ts
->kind
= gfc_default_double_kind
;
2817 if ((matched_type
&& strcmp ("complex", name
) == 0)
2818 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2820 ts
->type
= BT_COMPLEX
;
2821 ts
->kind
= gfc_default_complex_kind
;
2826 && (strcmp ("doublecomplex", name
) == 0
2827 || (strcmp ("double", name
) == 0
2828 && gfc_match (" complex") == MATCH_YES
)))
2829 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2831 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2835 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2836 "intrinsic-type-spec at %C"))
2839 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2842 ts
->type
= BT_COMPLEX
;
2843 ts
->kind
= gfc_default_double_kind
;
2847 if ((matched_type
&& strcmp ("logical", name
) == 0)
2848 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2850 ts
->type
= BT_LOGICAL
;
2851 ts
->kind
= gfc_default_logical_kind
;
2856 m
= gfc_match_char (')');
2859 ts
->type
= BT_DERIVED
;
2862 /* Match CLASS declarations. */
2863 m
= gfc_match (" class ( * )");
2864 if (m
== MATCH_ERROR
)
2866 else if (m
== MATCH_YES
)
2870 ts
->type
= BT_CLASS
;
2871 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2874 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2875 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2877 gfc_set_sym_referenced (upe
);
2879 upe
->ts
.type
= BT_VOID
;
2880 upe
->attr
.unlimited_polymorphic
= 1;
2881 /* This is essential to force the construction of
2882 unlimited polymorphic component class containers. */
2883 upe
->attr
.zero_comp
= 1;
2884 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2885 &gfc_current_locus
))
2890 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2892 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2896 ts
->u
.derived
= upe
;
2900 m
= gfc_match (" class ( %n )", name
);
2903 ts
->type
= BT_CLASS
;
2905 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2909 /* Defer association of the derived type until the end of the
2910 specification block. However, if the derived type can be
2911 found, add it to the typespec. */
2912 if (gfc_matching_function
)
2914 ts
->u
.derived
= NULL
;
2915 if (gfc_current_state () != COMP_INTERFACE
2916 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2918 sym
= gfc_find_dt_in_generic (sym
);
2919 ts
->u
.derived
= sym
;
2924 /* Search for the name but allow the components to be defined later. If
2925 type = -1, this typespec has been seen in a function declaration but
2926 the type could not be accessed at that point. The actual derived type is
2927 stored in a symtree with the first letter of the name capitalized; the
2928 symtree with the all lower-case name contains the associated
2929 generic function. */
2930 dt_name
= gfc_get_string ("%c%s",
2931 (char) TOUPPER ((unsigned char) name
[0]),
2932 (const char*)&name
[1]);
2937 gfc_get_ha_symbol (name
, &sym
);
2938 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2940 gfc_error ("Type name %qs at %C is ambiguous", name
);
2943 if (sym
->generic
&& !dt_sym
)
2944 dt_sym
= gfc_find_dt_in_generic (sym
);
2946 else if (ts
->kind
== -1)
2948 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2949 || gfc_current_ns
->has_import_set
;
2950 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2951 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2953 gfc_error ("Type name %qs at %C is ambiguous", name
);
2956 if (sym
&& sym
->generic
&& !dt_sym
)
2957 dt_sym
= gfc_find_dt_in_generic (sym
);
2964 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2965 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2966 || sym
->attr
.subroutine
)
2968 gfc_error ("Type name %qs at %C conflicts with previously declared "
2969 "entity at %L, which has the same name", name
,
2974 gfc_save_symbol_data (sym
);
2975 gfc_set_sym_referenced (sym
);
2976 if (!sym
->attr
.generic
2977 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2980 if (!sym
->attr
.function
2981 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2986 gfc_interface
*intr
, *head
;
2988 /* Use upper case to save the actual derived-type symbol. */
2989 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2990 dt_sym
->name
= gfc_get_string (sym
->name
);
2991 head
= sym
->generic
;
2992 intr
= gfc_get_interface ();
2994 intr
->where
= gfc_current_locus
;
2996 sym
->generic
= intr
;
2997 sym
->attr
.if_source
= IFSRC_DECL
;
3000 gfc_save_symbol_data (dt_sym
);
3002 gfc_set_sym_referenced (dt_sym
);
3004 if (dt_sym
->attr
.flavor
!= FL_DERIVED
3005 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
3008 ts
->u
.derived
= dt_sym
;
3014 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3015 "intrinsic-type-spec at %C"))
3018 /* For all types except double, derived and character, look for an
3019 optional kind specifier. MATCH_NO is actually OK at this point. */
3020 if (implicit_flag
== 1)
3022 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3028 if (gfc_current_form
== FORM_FREE
)
3030 c
= gfc_peek_ascii_char ();
3031 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
3032 && c
!= ':' && c
!= ',')
3034 if (matched_type
&& c
== ')')
3036 gfc_next_ascii_char ();
3043 m
= gfc_match_kind_spec (ts
, false);
3044 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3046 m
= gfc_match_old_kind_spec (ts
);
3047 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
3051 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3054 /* Defer association of the KIND expression of function results
3055 until after USE and IMPORT statements. */
3056 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3057 || gfc_matching_function
)
3061 m
= MATCH_YES
; /* No kind specifier found. */
3067 /* Match an IMPLICIT NONE statement. Actually, this statement is
3068 already matched in parse.c, or we would not end up here in the
3069 first place. So the only thing we need to check, is if there is
3070 trailing garbage. If not, the match is successful. */
3073 gfc_match_implicit_none (void)
3077 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3079 bool external
= false;
3080 locus cur_loc
= gfc_current_locus
;
3082 if (gfc_current_ns
->seen_implicit_none
3083 || gfc_current_ns
->has_implicit_none_export
)
3085 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3089 gfc_gobble_whitespace ();
3090 c
= gfc_peek_ascii_char ();
3093 (void) gfc_next_ascii_char ();
3094 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3097 gfc_gobble_whitespace ();
3098 if (gfc_peek_ascii_char () == ')')
3100 (void) gfc_next_ascii_char ();
3106 m
= gfc_match (" %n", name
);
3110 if (strcmp (name
, "type") == 0)
3112 else if (strcmp (name
, "external") == 0)
3117 gfc_gobble_whitespace ();
3118 c
= gfc_next_ascii_char ();
3129 if (gfc_match_eos () != MATCH_YES
)
3132 gfc_set_implicit_none (type
, external
, &cur_loc
);
3138 /* Match the letter range(s) of an IMPLICIT statement. */
3141 match_implicit_range (void)
3147 cur_loc
= gfc_current_locus
;
3149 gfc_gobble_whitespace ();
3150 c
= gfc_next_ascii_char ();
3153 gfc_error ("Missing character range in IMPLICIT at %C");
3160 gfc_gobble_whitespace ();
3161 c1
= gfc_next_ascii_char ();
3165 gfc_gobble_whitespace ();
3166 c
= gfc_next_ascii_char ();
3171 inner
= 0; /* Fall through. */
3178 gfc_gobble_whitespace ();
3179 c2
= gfc_next_ascii_char ();
3183 gfc_gobble_whitespace ();
3184 c
= gfc_next_ascii_char ();
3186 if ((c
!= ',') && (c
!= ')'))
3199 gfc_error ("Letters must be in alphabetic order in "
3200 "IMPLICIT statement at %C");
3204 /* See if we can add the newly matched range to the pending
3205 implicits from this IMPLICIT statement. We do not check for
3206 conflicts with whatever earlier IMPLICIT statements may have
3207 set. This is done when we've successfully finished matching
3209 if (!gfc_add_new_implicit_range (c1
, c2
))
3216 gfc_syntax_error (ST_IMPLICIT
);
3218 gfc_current_locus
= cur_loc
;
3223 /* Match an IMPLICIT statement, storing the types for
3224 gfc_set_implicit() if the statement is accepted by the parser.
3225 There is a strange looking, but legal syntactic construction
3226 possible. It looks like:
3228 IMPLICIT INTEGER (a-b) (c-d)
3230 This is legal if "a-b" is a constant expression that happens to
3231 equal one of the legal kinds for integers. The real problem
3232 happens with an implicit specification that looks like:
3234 IMPLICIT INTEGER (a-b)
3236 In this case, a typespec matcher that is "greedy" (as most of the
3237 matchers are) gobbles the character range as a kindspec, leaving
3238 nothing left. We therefore have to go a bit more slowly in the
3239 matching process by inhibiting the kindspec checking during
3240 typespec matching and checking for a kind later. */
3243 gfc_match_implicit (void)
3250 if (gfc_current_ns
->seen_implicit_none
)
3252 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3259 /* We don't allow empty implicit statements. */
3260 if (gfc_match_eos () == MATCH_YES
)
3262 gfc_error ("Empty IMPLICIT statement at %C");
3268 /* First cleanup. */
3269 gfc_clear_new_implicit ();
3271 /* A basic type is mandatory here. */
3272 m
= gfc_match_decl_type_spec (&ts
, 1);
3273 if (m
== MATCH_ERROR
)
3278 cur_loc
= gfc_current_locus
;
3279 m
= match_implicit_range ();
3283 /* We may have <TYPE> (<RANGE>). */
3284 gfc_gobble_whitespace ();
3285 c
= gfc_peek_ascii_char ();
3286 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3288 /* Check for CHARACTER with no length parameter. */
3289 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3291 ts
.kind
= gfc_default_character_kind
;
3292 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3293 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3297 /* Record the Successful match. */
3298 if (!gfc_merge_new_implicit (&ts
))
3301 c
= gfc_next_ascii_char ();
3302 else if (gfc_match_eos () == MATCH_ERROR
)
3307 gfc_current_locus
= cur_loc
;
3310 /* Discard the (incorrectly) matched range. */
3311 gfc_clear_new_implicit ();
3313 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3314 if (ts
.type
== BT_CHARACTER
)
3315 m
= gfc_match_char_spec (&ts
);
3318 m
= gfc_match_kind_spec (&ts
, false);
3321 m
= gfc_match_old_kind_spec (&ts
);
3322 if (m
== MATCH_ERROR
)
3328 if (m
== MATCH_ERROR
)
3331 m
= match_implicit_range ();
3332 if (m
== MATCH_ERROR
)
3337 gfc_gobble_whitespace ();
3338 c
= gfc_next_ascii_char ();
3339 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3342 if (!gfc_merge_new_implicit (&ts
))
3350 gfc_syntax_error (ST_IMPLICIT
);
3358 gfc_match_import (void)
3360 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3365 if (gfc_current_ns
->proc_name
== NULL
3366 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3368 gfc_error ("IMPORT statement at %C only permitted in "
3369 "an INTERFACE body");
3373 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3375 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3376 "in a module procedure interface body");
3380 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3383 if (gfc_match_eos () == MATCH_YES
)
3385 /* All host variables should be imported. */
3386 gfc_current_ns
->has_import_set
= 1;
3390 if (gfc_match (" ::") == MATCH_YES
)
3392 if (gfc_match_eos () == MATCH_YES
)
3394 gfc_error ("Expecting list of named entities at %C");
3402 m
= gfc_match (" %n", name
);
3406 if (gfc_current_ns
->parent
!= NULL
3407 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3409 gfc_error ("Type name %qs at %C is ambiguous", name
);
3412 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3413 && gfc_find_symbol (name
,
3414 gfc_current_ns
->proc_name
->ns
->parent
,
3417 gfc_error ("Type name %qs at %C is ambiguous", name
);
3423 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3424 "at %C - does not exist.", name
);
3428 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3430 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3435 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3438 sym
->attr
.imported
= 1;
3440 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3442 /* The actual derived type is stored in a symtree with the first
3443 letter of the name capitalized; the symtree with the all
3444 lower-case name contains the associated generic function. */
3445 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3446 gfc_get_string ("%c%s",
3447 (char) TOUPPER ((unsigned char) name
[0]),
3451 sym
->attr
.imported
= 1;
3464 if (gfc_match_eos () == MATCH_YES
)
3466 if (gfc_match_char (',') != MATCH_YES
)
3473 gfc_error ("Syntax error in IMPORT statement at %C");
3478 /* A minimal implementation of gfc_match without whitespace, escape
3479 characters or variable arguments. Returns true if the next
3480 characters match the TARGET template exactly. */
3483 match_string_p (const char *target
)
3487 for (p
= target
; *p
; p
++)
3488 if ((char) gfc_next_ascii_char () != *p
)
3493 /* Matches an attribute specification including array specs. If
3494 successful, leaves the variables current_attr and current_as
3495 holding the specification. Also sets the colon_seen variable for
3496 later use by matchers associated with initializations.
3498 This subroutine is a little tricky in the sense that we don't know
3499 if we really have an attr-spec until we hit the double colon.
3500 Until that time, we can only return MATCH_NO. This forces us to
3501 check for duplicate specification at this level. */
3504 match_attr_spec (void)
3506 /* Modifiers that can exist in a type statement. */
3508 { GFC_DECL_BEGIN
= 0,
3509 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3510 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3511 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3512 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3513 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3514 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3517 /* GFC_DECL_END is the sentinel, index starts at 0. */
3518 #define NUM_DECL GFC_DECL_END
3520 locus start
, seen_at
[NUM_DECL
];
3527 gfc_clear_attr (¤t_attr
);
3528 start
= gfc_current_locus
;
3533 /* See if we get all of the keywords up to the final double colon. */
3534 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3542 gfc_gobble_whitespace ();
3544 ch
= gfc_next_ascii_char ();
3547 /* This is the successful exit condition for the loop. */
3548 if (gfc_next_ascii_char () == ':')
3553 gfc_gobble_whitespace ();
3554 switch (gfc_peek_ascii_char ())
3557 gfc_next_ascii_char ();
3558 switch (gfc_next_ascii_char ())
3561 if (match_string_p ("locatable"))
3563 /* Matched "allocatable". */
3564 d
= DECL_ALLOCATABLE
;
3569 if (match_string_p ("ynchronous"))
3571 /* Matched "asynchronous". */
3572 d
= DECL_ASYNCHRONOUS
;
3579 /* Try and match the bind(c). */
3580 m
= gfc_match_bind_c (NULL
, true);
3583 else if (m
== MATCH_ERROR
)
3588 gfc_next_ascii_char ();
3589 if ('o' != gfc_next_ascii_char ())
3591 switch (gfc_next_ascii_char ())
3594 if (match_string_p ("imension"))
3596 d
= DECL_CODIMENSION
;
3600 if (match_string_p ("tiguous"))
3602 d
= DECL_CONTIGUOUS
;
3609 if (match_string_p ("dimension"))
3614 if (match_string_p ("external"))
3619 if (match_string_p ("int"))
3621 ch
= gfc_next_ascii_char ();
3624 if (match_string_p ("nt"))
3626 /* Matched "intent". */
3627 /* TODO: Call match_intent_spec from here. */
3628 if (gfc_match (" ( in out )") == MATCH_YES
)
3630 else if (gfc_match (" ( in )") == MATCH_YES
)
3632 else if (gfc_match (" ( out )") == MATCH_YES
)
3638 if (match_string_p ("insic"))
3640 /* Matched "intrinsic". */
3648 if (match_string_p ("optional"))
3653 gfc_next_ascii_char ();
3654 switch (gfc_next_ascii_char ())
3657 if (match_string_p ("rameter"))
3659 /* Matched "parameter". */
3665 if (match_string_p ("inter"))
3667 /* Matched "pointer". */
3673 ch
= gfc_next_ascii_char ();
3676 if (match_string_p ("vate"))
3678 /* Matched "private". */
3684 if (match_string_p ("tected"))
3686 /* Matched "protected". */
3693 if (match_string_p ("blic"))
3695 /* Matched "public". */
3703 if (match_string_p ("save"))
3708 if (match_string_p ("target"))
3713 gfc_next_ascii_char ();
3714 ch
= gfc_next_ascii_char ();
3717 if (match_string_p ("lue"))
3719 /* Matched "value". */
3725 if (match_string_p ("latile"))
3727 /* Matched "volatile". */
3735 /* No double colon and no recognizable decl_type, so assume that
3736 we've been looking at something else the whole time. */
3743 /* Check to make sure any parens are paired up correctly. */
3744 if (gfc_match_parens () == MATCH_ERROR
)
3751 seen_at
[d
] = gfc_current_locus
;
3753 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3755 gfc_array_spec
*as
= NULL
;
3757 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3758 d
== DECL_CODIMENSION
);
3760 if (current_as
== NULL
)
3762 else if (m
== MATCH_YES
)
3764 if (!merge_array_spec (as
, current_as
, false))
3771 if (d
== DECL_CODIMENSION
)
3772 gfc_error ("Missing codimension specification at %C");
3774 gfc_error ("Missing dimension specification at %C");
3778 if (m
== MATCH_ERROR
)
3783 /* Since we've seen a double colon, we have to be looking at an
3784 attr-spec. This means that we can now issue errors. */
3785 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3790 case DECL_ALLOCATABLE
:
3791 attr
= "ALLOCATABLE";
3793 case DECL_ASYNCHRONOUS
:
3794 attr
= "ASYNCHRONOUS";
3796 case DECL_CODIMENSION
:
3797 attr
= "CODIMENSION";
3799 case DECL_CONTIGUOUS
:
3800 attr
= "CONTIGUOUS";
3802 case DECL_DIMENSION
:
3809 attr
= "INTENT (IN)";
3812 attr
= "INTENT (OUT)";
3815 attr
= "INTENT (IN OUT)";
3817 case DECL_INTRINSIC
:
3823 case DECL_PARAMETER
:
3829 case DECL_PROTECTED
:
3844 case DECL_IS_BIND_C
:
3854 attr
= NULL
; /* This shouldn't happen. */
3857 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3862 /* Now that we've dealt with duplicate attributes, add the attributes
3863 to the current attribute. */
3864 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3869 if (gfc_current_state () == COMP_DERIVED
3870 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3871 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3872 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3874 if (d
== DECL_ALLOCATABLE
)
3876 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3877 "attribute at %C in a TYPE definition"))
3885 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3892 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3893 && gfc_current_state () != COMP_MODULE
)
3895 if (d
== DECL_PRIVATE
)
3899 if (gfc_current_state () == COMP_DERIVED
3900 && gfc_state_stack
->previous
3901 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3903 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3904 "at %L in a TYPE definition", attr
,
3913 gfc_error ("%s attribute at %L is not allowed outside of the "
3914 "specification part of a module", attr
, &seen_at
[d
]);
3922 case DECL_ALLOCATABLE
:
3923 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3926 case DECL_ASYNCHRONOUS
:
3927 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3930 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3933 case DECL_CODIMENSION
:
3934 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3937 case DECL_CONTIGUOUS
:
3938 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3941 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3944 case DECL_DIMENSION
:
3945 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3949 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3953 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3957 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3961 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3964 case DECL_INTRINSIC
:
3965 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3969 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3972 case DECL_PARAMETER
:
3973 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3977 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3980 case DECL_PROTECTED
:
3981 if (gfc_current_state () != COMP_MODULE
3982 || (gfc_current_ns
->proc_name
3983 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
3985 gfc_error ("PROTECTED at %C only allowed in specification "
3986 "part of a module");
3991 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3994 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3998 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
4003 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
4008 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
4012 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
4015 case DECL_IS_BIND_C
:
4016 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
4020 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
4023 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
4027 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
4030 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
4034 gfc_internal_error ("match_attr_spec(): Bad attribute");
4044 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4045 if ((gfc_current_state () == COMP_MODULE
4046 || gfc_current_state () == COMP_SUBMODULE
)
4047 && !current_attr
.save
4048 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4049 current_attr
.save
= SAVE_IMPLICIT
;
4055 gfc_current_locus
= start
;
4056 gfc_free_array_spec (current_as
);
4062 /* Set the binding label, dest_label, either with the binding label
4063 stored in the given gfc_typespec, ts, or if none was provided, it
4064 will be the symbol name in all lower case, as required by the draft
4065 (J3/04-007, section 15.4.1). If a binding label was given and
4066 there is more than one argument (num_idents), it is an error. */
4069 set_binding_label (const char **dest_label
, const char *sym_name
,
4072 if (num_idents
> 1 && has_name_equals
)
4074 gfc_error ("Multiple identifiers provided with "
4075 "single NAME= specifier at %C");
4079 if (curr_binding_label
)
4080 /* Binding label given; store in temp holder till have sym. */
4081 *dest_label
= curr_binding_label
;
4084 /* No binding label given, and the NAME= specifier did not exist,
4085 which means there was no NAME="". */
4086 if (sym_name
!= NULL
&& has_name_equals
== 0)
4087 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4094 /* Set the status of the given common block as being BIND(C) or not,
4095 depending on the given parameter, is_bind_c. */
4098 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4100 com_block
->is_bind_c
= is_bind_c
;
4105 /* Verify that the given gfc_typespec is for a C interoperable type. */
4108 gfc_verify_c_interop (gfc_typespec
*ts
)
4110 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4111 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4113 else if (ts
->type
== BT_CLASS
)
4115 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4122 /* Verify that the variables of a given common block, which has been
4123 defined with the attribute specifier bind(c), to be of a C
4124 interoperable type. Errors will be reported here, if
4128 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4130 gfc_symbol
*curr_sym
= NULL
;
4133 curr_sym
= com_block
->head
;
4135 /* Make sure we have at least one symbol. */
4136 if (curr_sym
== NULL
)
4139 /* Here we know we have a symbol, so we'll execute this loop
4143 /* The second to last param, 1, says this is in a common block. */
4144 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4145 curr_sym
= curr_sym
->common_next
;
4146 } while (curr_sym
!= NULL
);
4152 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4153 an appropriate error message is reported. */
4156 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4157 int is_in_common
, gfc_common_head
*com_block
)
4159 bool bind_c_function
= false;
4162 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4163 bind_c_function
= true;
4165 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4167 tmp_sym
= tmp_sym
->result
;
4168 /* Make sure it wasn't an implicitly typed result. */
4169 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4171 gfc_warning (OPT_Wc_binding_type
,
4172 "Implicitly declared BIND(C) function %qs at "
4173 "%L may not be C interoperable", tmp_sym
->name
,
4174 &tmp_sym
->declared_at
);
4175 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4176 /* Mark it as C interoperable to prevent duplicate warnings. */
4177 tmp_sym
->ts
.is_c_interop
= 1;
4178 tmp_sym
->attr
.is_c_interop
= 1;
4182 /* Here, we know we have the bind(c) attribute, so if we have
4183 enough type info, then verify that it's a C interop kind.
4184 The info could be in the symbol already, or possibly still in
4185 the given ts (current_ts), so look in both. */
4186 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4188 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4190 /* See if we're dealing with a sym in a common block or not. */
4191 if (is_in_common
== 1 && warn_c_binding_type
)
4193 gfc_warning (OPT_Wc_binding_type
,
4194 "Variable %qs in common block %qs at %L "
4195 "may not be a C interoperable "
4196 "kind though common block %qs is BIND(C)",
4197 tmp_sym
->name
, com_block
->name
,
4198 &(tmp_sym
->declared_at
), com_block
->name
);
4202 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4203 gfc_error ("Type declaration %qs at %L is not C "
4204 "interoperable but it is BIND(C)",
4205 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4206 else if (warn_c_binding_type
)
4207 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4208 "may not be a C interoperable "
4209 "kind but it is BIND(C)",
4210 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4214 /* Variables declared w/in a common block can't be bind(c)
4215 since there's no way for C to see these variables, so there's
4216 semantically no reason for the attribute. */
4217 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4219 gfc_error ("Variable %qs in common block %qs at "
4220 "%L cannot be declared with BIND(C) "
4221 "since it is not a global",
4222 tmp_sym
->name
, com_block
->name
,
4223 &(tmp_sym
->declared_at
));
4227 /* Scalar variables that are bind(c) can not have the pointer
4228 or allocatable attributes. */
4229 if (tmp_sym
->attr
.is_bind_c
== 1)
4231 if (tmp_sym
->attr
.pointer
== 1)
4233 gfc_error ("Variable %qs at %L cannot have both the "
4234 "POINTER and BIND(C) attributes",
4235 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4239 if (tmp_sym
->attr
.allocatable
== 1)
4241 gfc_error ("Variable %qs at %L cannot have both the "
4242 "ALLOCATABLE and BIND(C) attributes",
4243 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4249 /* If it is a BIND(C) function, make sure the return value is a
4250 scalar value. The previous tests in this function made sure
4251 the type is interoperable. */
4252 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4253 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4254 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4256 /* BIND(C) functions can not return a character string. */
4257 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4258 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4259 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4260 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4261 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4262 "be a character string", tmp_sym
->name
,
4263 &(tmp_sym
->declared_at
));
4266 /* See if the symbol has been marked as private. If it has, make sure
4267 there is no binding label and warn the user if there is one. */
4268 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4269 && tmp_sym
->binding_label
)
4270 /* Use gfc_warning_now because we won't say that the symbol fails
4271 just because of this. */
4272 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4273 "given the binding label %qs", tmp_sym
->name
,
4274 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4280 /* Set the appropriate fields for a symbol that's been declared as
4281 BIND(C) (the is_bind_c flag and the binding label), and verify that
4282 the type is C interoperable. Errors are reported by the functions
4283 used to set/test these fields. */
4286 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4290 /* TODO: Do we need to make sure the vars aren't marked private? */
4292 /* Set the is_bind_c bit in symbol_attribute. */
4293 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4295 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4302 /* Set the fields marking the given common block as BIND(C), including
4303 a binding label, and report any errors encountered. */
4306 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4310 /* destLabel, common name, typespec (which may have binding label). */
4311 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4315 /* Set the given common block (com_block) to being bind(c) (1). */
4316 set_com_block_bind_c (com_block
, 1);
4322 /* Retrieve the list of one or more identifiers that the given bind(c)
4323 attribute applies to. */
4326 get_bind_c_idents (void)
4328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4330 gfc_symbol
*tmp_sym
= NULL
;
4332 gfc_common_head
*com_block
= NULL
;
4334 if (gfc_match_name (name
) == MATCH_YES
)
4336 found_id
= MATCH_YES
;
4337 gfc_get_ha_symbol (name
, &tmp_sym
);
4339 else if (match_common_name (name
) == MATCH_YES
)
4341 found_id
= MATCH_YES
;
4342 com_block
= gfc_get_common (name
, 0);
4346 gfc_error ("Need either entity or common block name for "
4347 "attribute specification statement at %C");
4351 /* Save the current identifier and look for more. */
4354 /* Increment the number of identifiers found for this spec stmt. */
4357 /* Make sure we have a sym or com block, and verify that it can
4358 be bind(c). Set the appropriate field(s) and look for more
4360 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4362 if (tmp_sym
!= NULL
)
4364 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4369 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4373 /* Look to see if we have another identifier. */
4375 if (gfc_match_eos () == MATCH_YES
)
4376 found_id
= MATCH_NO
;
4377 else if (gfc_match_char (',') != MATCH_YES
)
4378 found_id
= MATCH_NO
;
4379 else if (gfc_match_name (name
) == MATCH_YES
)
4381 found_id
= MATCH_YES
;
4382 gfc_get_ha_symbol (name
, &tmp_sym
);
4384 else if (match_common_name (name
) == MATCH_YES
)
4386 found_id
= MATCH_YES
;
4387 com_block
= gfc_get_common (name
, 0);
4391 gfc_error ("Missing entity or common block name for "
4392 "attribute specification statement at %C");
4398 gfc_internal_error ("Missing symbol");
4400 } while (found_id
== MATCH_YES
);
4402 /* if we get here we were successful */
4407 /* Try and match a BIND(C) attribute specification statement. */
4410 gfc_match_bind_c_stmt (void)
4412 match found_match
= MATCH_NO
;
4417 /* This may not be necessary. */
4419 /* Clear the temporary binding label holder. */
4420 curr_binding_label
= NULL
;
4422 /* Look for the bind(c). */
4423 found_match
= gfc_match_bind_c (NULL
, true);
4425 if (found_match
== MATCH_YES
)
4427 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4430 /* Look for the :: now, but it is not required. */
4433 /* Get the identifier(s) that needs to be updated. This may need to
4434 change to hand the flag(s) for the attr specified so all identifiers
4435 found can have all appropriate parts updated (assuming that the same
4436 spec stmt can have multiple attrs, such as both bind(c) and
4438 if (!get_bind_c_idents ())
4439 /* Error message should have printed already. */
4447 /* Match a data declaration statement. */
4450 gfc_match_data_decl (void)
4456 num_idents_on_line
= 0;
4458 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4462 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4463 && gfc_current_state () != COMP_DERIVED
)
4465 sym
= gfc_use_derived (current_ts
.u
.derived
);
4473 current_ts
.u
.derived
= sym
;
4476 m
= match_attr_spec ();
4477 if (m
== MATCH_ERROR
)
4483 if (current_ts
.type
== BT_CLASS
4484 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4487 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4488 && current_ts
.u
.derived
->components
== NULL
4489 && !current_ts
.u
.derived
->attr
.zero_comp
)
4492 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4495 gfc_find_symbol (current_ts
.u
.derived
->name
,
4496 current_ts
.u
.derived
->ns
, 1, &sym
);
4498 /* Any symbol that we find had better be a type definition
4499 which has its components defined. */
4500 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4501 && (current_ts
.u
.derived
->components
!= NULL
4502 || current_ts
.u
.derived
->attr
.zero_comp
))
4505 gfc_error ("Derived type at %C has not been previously defined "
4506 "and so cannot appear in a derived type definition");
4512 /* If we have an old-style character declaration, and no new-style
4513 attribute specifications, then there a comma is optional between
4514 the type specification and the variable list. */
4515 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4516 gfc_match_char (',');
4518 /* Give the types/attributes to symbols that follow. Give the element
4519 a number so that repeat character length expressions can be copied. */
4523 num_idents_on_line
++;
4524 m
= variable_decl (elem
++);
4525 if (m
== MATCH_ERROR
)
4530 if (gfc_match_eos () == MATCH_YES
)
4532 if (gfc_match_char (',') != MATCH_YES
)
4536 if (!gfc_error_flag_test ())
4537 gfc_error ("Syntax error in data declaration at %C");
4540 gfc_free_data_all (gfc_current_ns
);
4543 gfc_free_array_spec (current_as
);
4549 /* Match a prefix associated with a function or subroutine
4550 declaration. If the typespec pointer is nonnull, then a typespec
4551 can be matched. Note that if nothing matches, MATCH_YES is
4552 returned (the null string was matched). */
4555 gfc_match_prefix (gfc_typespec
*ts
)
4561 gfc_clear_attr (¤t_attr
);
4563 seen_impure
= false;
4565 gcc_assert (!gfc_matching_prefix
);
4566 gfc_matching_prefix
= true;
4570 found_prefix
= false;
4572 if (!seen_type
&& ts
!= NULL
4573 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4574 && gfc_match_space () == MATCH_YES
)
4578 found_prefix
= true;
4581 if (gfc_match ("elemental% ") == MATCH_YES
)
4583 if (!gfc_add_elemental (¤t_attr
, NULL
))
4586 found_prefix
= true;
4589 if (gfc_match ("pure% ") == MATCH_YES
)
4591 if (!gfc_add_pure (¤t_attr
, NULL
))
4594 found_prefix
= true;
4597 if (gfc_match ("recursive% ") == MATCH_YES
)
4599 if (!gfc_add_recursive (¤t_attr
, NULL
))
4602 found_prefix
= true;
4605 /* IMPURE is a somewhat special case, as it needs not set an actual
4606 attribute but rather only prevents ELEMENTAL routines from being
4607 automatically PURE. */
4608 if (gfc_match ("impure% ") == MATCH_YES
)
4610 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4614 found_prefix
= true;
4617 while (found_prefix
);
4619 /* IMPURE and PURE must not both appear, of course. */
4620 if (seen_impure
&& current_attr
.pure
)
4622 gfc_error ("PURE and IMPURE must not appear both at %C");
4626 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4627 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4629 if (!gfc_add_pure (¤t_attr
, NULL
))
4633 /* At this point, the next item is not a prefix. */
4634 gcc_assert (gfc_matching_prefix
);
4636 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4637 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4638 corresponding attribute seems natural and distinguishes these
4639 procedures from procedure types of PROC_MODULE, which these are
4641 if ((gfc_current_state () == COMP_INTERFACE
4642 || gfc_current_state () == COMP_CONTAINS
)
4643 && gfc_match ("module% ") == MATCH_YES
)
4645 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4648 current_attr
.module_procedure
= 1;
4651 gfc_matching_prefix
= false;
4655 gcc_assert (gfc_matching_prefix
);
4656 gfc_matching_prefix
= false;
4661 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4664 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4666 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4669 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4672 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4679 /* Match a formal argument list. */
4682 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4684 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4685 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4688 gfc_formal_arglist
*formal
= NULL
;
4692 /* Keep the interface formal argument list and null it so that the
4693 matching for the new declaration can be done. The numbers and
4694 names of the arguments are checked here. The interface formal
4695 arguments are retained in formal_arglist and the characteristics
4696 are compared in resolve.c(resolve_fl_procedure). See the remark
4697 in get_proc_name about the eventual need to copy the formal_arglist
4698 and populate the formal namespace of the interface symbol. */
4699 if (progname
->attr
.module_procedure
4700 && progname
->attr
.host_assoc
)
4702 formal
= progname
->formal
;
4703 progname
->formal
= NULL
;
4706 if (gfc_match_char ('(') != MATCH_YES
)
4713 if (gfc_match_char (')') == MATCH_YES
)
4718 if (gfc_match_char ('*') == MATCH_YES
)
4721 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4730 m
= gfc_match_name (name
);
4734 if (gfc_get_symbol (name
, NULL
, &sym
))
4738 p
= gfc_get_formal_arglist ();
4750 /* We don't add the VARIABLE flavor because the name could be a
4751 dummy procedure. We don't apply these attributes to formal
4752 arguments of statement functions. */
4753 if (sym
!= NULL
&& !st_flag
4754 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4755 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4761 /* The name of a program unit can be in a different namespace,
4762 so check for it explicitly. After the statement is accepted,
4763 the name is checked for especially in gfc_get_symbol(). */
4764 if (gfc_new_block
!= NULL
&& sym
!= NULL
4765 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4767 gfc_error ("Name %qs at %C is the name of the procedure",
4773 if (gfc_match_char (')') == MATCH_YES
)
4776 m
= gfc_match_char (',');
4779 gfc_error ("Unexpected junk in formal argument list at %C");
4785 /* Check for duplicate symbols in the formal argument list. */
4788 for (p
= head
; p
->next
; p
= p
->next
)
4793 for (q
= p
->next
; q
; q
= q
->next
)
4794 if (p
->sym
== q
->sym
)
4796 gfc_error ("Duplicate symbol %qs in formal argument list "
4797 "at %C", p
->sym
->name
);
4805 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4813 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4815 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4816 || (p
->next
== NULL
&& q
->next
!= NULL
))
4817 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4818 "formal arguments at %C");
4819 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4820 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4823 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4824 "argument names (%s/%s) at %C",
4825 p
->sym
->name
, q
->sym
->name
);
4832 gfc_free_formal_arglist (head
);
4837 /* Match a RESULT specification following a function declaration or
4838 ENTRY statement. Also matches the end-of-statement. */
4841 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4843 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4847 if (gfc_match (" result (") != MATCH_YES
)
4850 m
= gfc_match_name (name
);
4854 /* Get the right paren, and that's it because there could be the
4855 bind(c) attribute after the result clause. */
4856 if (gfc_match_char (')') != MATCH_YES
)
4858 /* TODO: should report the missing right paren here. */
4862 if (strcmp (function
->name
, name
) == 0)
4864 gfc_error ("RESULT variable at %C must be different than function name");
4868 if (gfc_get_symbol (name
, NULL
, &r
))
4871 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4880 /* Match a function suffix, which could be a combination of a result
4881 clause and BIND(C), either one, or neither. The draft does not
4882 require them to come in a specific order. */
4885 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4887 match is_bind_c
; /* Found bind(c). */
4888 match is_result
; /* Found result clause. */
4889 match found_match
; /* Status of whether we've found a good match. */
4890 char peek_char
; /* Character we're going to peek at. */
4891 bool allow_binding_name
;
4893 /* Initialize to having found nothing. */
4894 found_match
= MATCH_NO
;
4895 is_bind_c
= MATCH_NO
;
4896 is_result
= MATCH_NO
;
4898 /* Get the next char to narrow between result and bind(c). */
4899 gfc_gobble_whitespace ();
4900 peek_char
= gfc_peek_ascii_char ();
4902 /* C binding names are not allowed for internal procedures. */
4903 if (gfc_current_state () == COMP_CONTAINS
4904 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4905 allow_binding_name
= false;
4907 allow_binding_name
= true;
4912 /* Look for result clause. */
4913 is_result
= match_result (sym
, result
);
4914 if (is_result
== MATCH_YES
)
4916 /* Now see if there is a bind(c) after it. */
4917 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4918 /* We've found the result clause and possibly bind(c). */
4919 found_match
= MATCH_YES
;
4922 /* This should only be MATCH_ERROR. */
4923 found_match
= is_result
;
4926 /* Look for bind(c) first. */
4927 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4928 if (is_bind_c
== MATCH_YES
)
4930 /* Now see if a result clause followed it. */
4931 is_result
= match_result (sym
, result
);
4932 found_match
= MATCH_YES
;
4936 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4937 found_match
= MATCH_ERROR
;
4941 gfc_error ("Unexpected junk after function declaration at %C");
4942 found_match
= MATCH_ERROR
;
4946 if (is_bind_c
== MATCH_YES
)
4948 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4949 if (gfc_current_state () == COMP_CONTAINS
4950 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4951 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4952 "at %L may not be specified for an internal "
4953 "procedure", &gfc_current_locus
))
4956 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4964 /* Procedure pointer return value without RESULT statement:
4965 Add "hidden" result variable named "ppr@". */
4968 add_hidden_procptr_result (gfc_symbol
*sym
)
4972 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4975 /* First usage case: PROCEDURE and EXTERNAL statements. */
4976 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4977 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4978 && sym
->attr
.external
;
4979 /* Second usage case: INTERFACE statements. */
4980 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4981 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4982 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4988 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4992 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4993 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4994 st2
->n
.sym
= stree
->n
.sym
;
4996 sym
->result
= stree
->n
.sym
;
4998 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4999 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
5000 sym
->result
->attr
.external
= sym
->attr
.external
;
5001 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
5002 sym
->result
->ts
= sym
->ts
;
5003 sym
->attr
.proc_pointer
= 0;
5004 sym
->attr
.pointer
= 0;
5005 sym
->attr
.external
= 0;
5006 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
5008 sym
->result
->attr
.pointer
= 0;
5009 sym
->result
->attr
.proc_pointer
= 1;
5012 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5014 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5015 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5016 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5017 && sym
== gfc_current_ns
->proc_name
5018 && sym
== sym
->result
->ns
->proc_name
5019 && strcmp ("ppr@", sym
->result
->name
) == 0)
5021 sym
->result
->attr
.proc_pointer
= 1;
5022 sym
->attr
.pointer
= 0;
5030 /* Match the interface for a PROCEDURE declaration,
5031 including brackets (R1212). */
5034 match_procedure_interface (gfc_symbol
**proc_if
)
5038 locus old_loc
, entry_loc
;
5039 gfc_namespace
*old_ns
= gfc_current_ns
;
5040 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5042 old_loc
= entry_loc
= gfc_current_locus
;
5043 gfc_clear_ts (¤t_ts
);
5045 if (gfc_match (" (") != MATCH_YES
)
5047 gfc_current_locus
= entry_loc
;
5051 /* Get the type spec. for the procedure interface. */
5052 old_loc
= gfc_current_locus
;
5053 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5054 gfc_gobble_whitespace ();
5055 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5058 if (m
== MATCH_ERROR
)
5061 /* Procedure interface is itself a procedure. */
5062 gfc_current_locus
= old_loc
;
5063 m
= gfc_match_name (name
);
5065 /* First look to see if it is already accessible in the current
5066 namespace because it is use associated or contained. */
5068 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5071 /* If it is still not found, then try the parent namespace, if it
5072 exists and create the symbol there if it is still not found. */
5073 if (gfc_current_ns
->parent
)
5074 gfc_current_ns
= gfc_current_ns
->parent
;
5075 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5078 gfc_current_ns
= old_ns
;
5079 *proc_if
= st
->n
.sym
;
5084 /* Resolve interface if possible. That way, attr.procedure is only set
5085 if it is declared by a later procedure-declaration-stmt, which is
5086 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5087 while ((*proc_if
)->ts
.interface
)
5088 *proc_if
= (*proc_if
)->ts
.interface
;
5090 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5091 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5092 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5093 (*proc_if
)->name
, NULL
))
5098 if (gfc_match (" )") != MATCH_YES
)
5100 gfc_current_locus
= entry_loc
;
5108 /* Match a PROCEDURE declaration (R1211). */
5111 match_procedure_decl (void)
5114 gfc_symbol
*sym
, *proc_if
= NULL
;
5116 gfc_expr
*initializer
= NULL
;
5118 /* Parse interface (with brackets). */
5119 m
= match_procedure_interface (&proc_if
);
5123 /* Parse attributes (with colons). */
5124 m
= match_attr_spec();
5125 if (m
== MATCH_ERROR
)
5128 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5130 current_attr
.is_bind_c
= 1;
5131 has_name_equals
= 0;
5132 curr_binding_label
= NULL
;
5135 /* Get procedure symbols. */
5138 m
= gfc_match_symbol (&sym
, 0);
5141 else if (m
== MATCH_ERROR
)
5144 /* Add current_attr to the symbol attributes. */
5145 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5148 if (sym
->attr
.is_bind_c
)
5150 /* Check for C1218. */
5151 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5153 gfc_error ("BIND(C) attribute at %C requires "
5154 "an interface with BIND(C)");
5157 /* Check for C1217. */
5158 if (has_name_equals
&& sym
->attr
.pointer
)
5160 gfc_error ("BIND(C) procedure with NAME may not have "
5161 "POINTER attribute at %C");
5164 if (has_name_equals
&& sym
->attr
.dummy
)
5166 gfc_error ("Dummy procedure at %C may not have "
5167 "BIND(C) attribute with NAME");
5170 /* Set binding label for BIND(C). */
5171 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5175 if (!gfc_add_external (&sym
->attr
, NULL
))
5178 if (add_hidden_procptr_result (sym
))
5181 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5184 /* Set interface. */
5185 if (proc_if
!= NULL
)
5187 if (sym
->ts
.type
!= BT_UNKNOWN
)
5189 gfc_error ("Procedure %qs at %L already has basic type of %s",
5190 sym
->name
, &gfc_current_locus
,
5191 gfc_basic_typename (sym
->ts
.type
));
5194 sym
->ts
.interface
= proc_if
;
5195 sym
->attr
.untyped
= 1;
5196 sym
->attr
.if_source
= IFSRC_IFBODY
;
5198 else if (current_ts
.type
!= BT_UNKNOWN
)
5200 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5202 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5203 sym
->ts
.interface
->ts
= current_ts
;
5204 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5205 sym
->ts
.interface
->attr
.function
= 1;
5206 sym
->attr
.function
= 1;
5207 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5210 if (gfc_match (" =>") == MATCH_YES
)
5212 if (!current_attr
.pointer
)
5214 gfc_error ("Initialization at %C isn't for a pointer variable");
5219 m
= match_pointer_init (&initializer
, 1);
5223 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5228 if (gfc_match_eos () == MATCH_YES
)
5230 if (gfc_match_char (',') != MATCH_YES
)
5235 gfc_error ("Syntax error in PROCEDURE statement at %C");
5239 /* Free stuff up and return. */
5240 gfc_free_expr (initializer
);
5246 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5249 /* Match a procedure pointer component declaration (R445). */
5252 match_ppc_decl (void)
5255 gfc_symbol
*proc_if
= NULL
;
5259 gfc_expr
*initializer
= NULL
;
5260 gfc_typebound_proc
* tb
;
5261 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5263 /* Parse interface (with brackets). */
5264 m
= match_procedure_interface (&proc_if
);
5268 /* Parse attributes. */
5269 tb
= XCNEW (gfc_typebound_proc
);
5270 tb
->where
= gfc_current_locus
;
5271 m
= match_binding_attributes (tb
, false, true);
5272 if (m
== MATCH_ERROR
)
5275 gfc_clear_attr (¤t_attr
);
5276 current_attr
.procedure
= 1;
5277 current_attr
.proc_pointer
= 1;
5278 current_attr
.access
= tb
->access
;
5279 current_attr
.flavor
= FL_PROCEDURE
;
5281 /* Match the colons (required). */
5282 if (gfc_match (" ::") != MATCH_YES
)
5284 gfc_error ("Expected %<::%> after binding-attributes at %C");
5288 /* Check for C450. */
5289 if (!tb
->nopass
&& proc_if
== NULL
)
5291 gfc_error("NOPASS or explicit interface required at %C");
5295 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5298 /* Match PPC names. */
5302 m
= gfc_match_name (name
);
5305 else if (m
== MATCH_ERROR
)
5308 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5311 /* Add current_attr to the symbol attributes. */
5312 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5315 if (!gfc_add_external (&c
->attr
, NULL
))
5318 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5325 c
->tb
= XCNEW (gfc_typebound_proc
);
5326 c
->tb
->where
= gfc_current_locus
;
5330 /* Set interface. */
5331 if (proc_if
!= NULL
)
5333 c
->ts
.interface
= proc_if
;
5334 c
->attr
.untyped
= 1;
5335 c
->attr
.if_source
= IFSRC_IFBODY
;
5337 else if (ts
.type
!= BT_UNKNOWN
)
5340 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5341 c
->ts
.interface
->result
= c
->ts
.interface
;
5342 c
->ts
.interface
->ts
= ts
;
5343 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5344 c
->ts
.interface
->attr
.function
= 1;
5345 c
->attr
.function
= 1;
5346 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5349 if (gfc_match (" =>") == MATCH_YES
)
5351 m
= match_pointer_init (&initializer
, 1);
5354 gfc_free_expr (initializer
);
5357 c
->initializer
= initializer
;
5360 if (gfc_match_eos () == MATCH_YES
)
5362 if (gfc_match_char (',') != MATCH_YES
)
5367 gfc_error ("Syntax error in procedure pointer component at %C");
5372 /* Match a PROCEDURE declaration inside an interface (R1206). */
5375 match_procedure_in_interface (void)
5379 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5382 if (current_interface
.type
== INTERFACE_NAMELESS
5383 || current_interface
.type
== INTERFACE_ABSTRACT
)
5385 gfc_error ("PROCEDURE at %C must be in a generic interface");
5389 /* Check if the F2008 optional double colon appears. */
5390 gfc_gobble_whitespace ();
5391 old_locus
= gfc_current_locus
;
5392 if (gfc_match ("::") == MATCH_YES
)
5394 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5395 "MODULE PROCEDURE statement at %L", &old_locus
))
5399 gfc_current_locus
= old_locus
;
5403 m
= gfc_match_name (name
);
5406 else if (m
== MATCH_ERROR
)
5408 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5411 if (!gfc_add_interface (sym
))
5414 if (gfc_match_eos () == MATCH_YES
)
5416 if (gfc_match_char (',') != MATCH_YES
)
5423 gfc_error ("Syntax error in PROCEDURE statement at %C");
5428 /* General matcher for PROCEDURE declarations. */
5430 static match
match_procedure_in_type (void);
5433 gfc_match_procedure (void)
5437 switch (gfc_current_state ())
5442 case COMP_SUBMODULE
:
5443 case COMP_SUBROUTINE
:
5446 m
= match_procedure_decl ();
5448 case COMP_INTERFACE
:
5449 m
= match_procedure_in_interface ();
5452 m
= match_ppc_decl ();
5454 case COMP_DERIVED_CONTAINS
:
5455 m
= match_procedure_in_type ();
5464 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5471 /* Warn if a matched procedure has the same name as an intrinsic; this is
5472 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5473 parser-state-stack to find out whether we're in a module. */
5476 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5480 in_module
= (gfc_state_stack
->previous
5481 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5482 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5484 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5488 /* Match a function declaration. */
5491 gfc_match_function_decl (void)
5493 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5494 gfc_symbol
*sym
, *result
;
5498 match found_match
; /* Status returned by match func. */
5500 if (gfc_current_state () != COMP_NONE
5501 && gfc_current_state () != COMP_INTERFACE
5502 && gfc_current_state () != COMP_CONTAINS
)
5505 gfc_clear_ts (¤t_ts
);
5507 old_loc
= gfc_current_locus
;
5509 m
= gfc_match_prefix (¤t_ts
);
5512 gfc_current_locus
= old_loc
;
5516 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5518 gfc_current_locus
= old_loc
;
5522 if (get_proc_name (name
, &sym
, false))
5525 if (add_hidden_procptr_result (sym
))
5528 if (current_attr
.module_procedure
)
5529 sym
->attr
.module_procedure
= 1;
5531 gfc_new_block
= sym
;
5533 m
= gfc_match_formal_arglist (sym
, 0, 0);
5536 gfc_error ("Expected formal argument list in function "
5537 "definition at %C");
5541 else if (m
== MATCH_ERROR
)
5546 /* According to the draft, the bind(c) and result clause can
5547 come in either order after the formal_arg_list (i.e., either
5548 can be first, both can exist together or by themselves or neither
5549 one). Therefore, the match_result can't match the end of the
5550 string, and check for the bind(c) or result clause in either order. */
5551 found_match
= gfc_match_eos ();
5553 /* Make sure that it isn't already declared as BIND(C). If it is, it
5554 must have been marked BIND(C) with a BIND(C) attribute and that is
5555 not allowed for procedures. */
5556 if (sym
->attr
.is_bind_c
== 1)
5558 sym
->attr
.is_bind_c
= 0;
5559 if (sym
->old_symbol
!= NULL
)
5560 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5561 "variables or common blocks",
5562 &(sym
->old_symbol
->declared_at
));
5564 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5565 "variables or common blocks", &gfc_current_locus
);
5568 if (found_match
!= MATCH_YES
)
5570 /* If we haven't found the end-of-statement, look for a suffix. */
5571 suffix_match
= gfc_match_suffix (sym
, &result
);
5572 if (suffix_match
== MATCH_YES
)
5573 /* Need to get the eos now. */
5574 found_match
= gfc_match_eos ();
5576 found_match
= suffix_match
;
5579 if(found_match
!= MATCH_YES
)
5583 /* Make changes to the symbol. */
5586 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5589 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5590 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5593 /* Delay matching the function characteristics until after the
5594 specification block by signalling kind=-1. */
5595 sym
->declared_at
= old_loc
;
5596 if (current_ts
.type
!= BT_UNKNOWN
)
5597 current_ts
.kind
= -1;
5599 current_ts
.kind
= 0;
5603 if (current_ts
.type
!= BT_UNKNOWN
5604 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5610 if (current_ts
.type
!= BT_UNKNOWN
5611 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5613 sym
->result
= result
;
5616 /* Warn if this procedure has the same name as an intrinsic. */
5617 do_warn_intrinsic_shadow (sym
, true);
5623 gfc_current_locus
= old_loc
;
5628 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5629 pass the name of the entry, rather than the gfc_current_block name, and
5630 to return false upon finding an existing global entry. */
5633 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5637 enum gfc_symbol_type type
;
5639 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5641 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5642 name is a global identifier. */
5643 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5645 s
= gfc_get_gsymbol (name
);
5647 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5649 gfc_global_used (s
, where
);
5658 s
->ns
= gfc_current_ns
;
5662 /* Don't add the symbol multiple times. */
5664 && (!gfc_notification_std (GFC_STD_F2008
)
5665 || strcmp (name
, binding_label
) != 0))
5667 s
= gfc_get_gsymbol (binding_label
);
5669 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5671 gfc_global_used (s
, where
);
5678 s
->binding_label
= binding_label
;
5681 s
->ns
= gfc_current_ns
;
5689 /* Match an ENTRY statement. */
5692 gfc_match_entry (void)
5697 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5698 gfc_compile_state state
;
5702 bool module_procedure
;
5706 m
= gfc_match_name (name
);
5710 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5713 state
= gfc_current_state ();
5714 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5719 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5722 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5724 case COMP_SUBMODULE
:
5725 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5727 case COMP_BLOCK_DATA
:
5728 gfc_error ("ENTRY statement at %C cannot appear within "
5731 case COMP_INTERFACE
:
5732 gfc_error ("ENTRY statement at %C cannot appear within "
5736 gfc_error ("ENTRY statement at %C cannot appear within "
5737 "a DERIVED TYPE block");
5740 gfc_error ("ENTRY statement at %C cannot appear within "
5741 "an IF-THEN block");
5744 case COMP_DO_CONCURRENT
:
5745 gfc_error ("ENTRY statement at %C cannot appear within "
5749 gfc_error ("ENTRY statement at %C cannot appear within "
5753 gfc_error ("ENTRY statement at %C cannot appear within "
5757 gfc_error ("ENTRY statement at %C cannot appear within "
5761 gfc_error ("ENTRY statement at %C cannot appear within "
5762 "a contained subprogram");
5765 gfc_error ("Unexpected ENTRY statement at %C");
5770 module_procedure
= gfc_current_ns
->parent
!= NULL
5771 && gfc_current_ns
->parent
->proc_name
5772 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5775 if (gfc_current_ns
->parent
!= NULL
5776 && gfc_current_ns
->parent
->proc_name
5777 && !module_procedure
)
5779 gfc_error("ENTRY statement at %C cannot appear in a "
5780 "contained procedure");
5784 /* Module function entries need special care in get_proc_name
5785 because previous references within the function will have
5786 created symbols attached to the current namespace. */
5787 if (get_proc_name (name
, &entry
,
5788 gfc_current_ns
->parent
!= NULL
5789 && module_procedure
))
5792 proc
= gfc_current_block ();
5794 /* Make sure that it isn't already declared as BIND(C). If it is, it
5795 must have been marked BIND(C) with a BIND(C) attribute and that is
5796 not allowed for procedures. */
5797 if (entry
->attr
.is_bind_c
== 1)
5799 entry
->attr
.is_bind_c
= 0;
5800 if (entry
->old_symbol
!= NULL
)
5801 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5802 "variables or common blocks",
5803 &(entry
->old_symbol
->declared_at
));
5805 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5806 "variables or common blocks", &gfc_current_locus
);
5809 /* Check what next non-whitespace character is so we can tell if there
5810 is the required parens if we have a BIND(C). */
5811 old_loc
= gfc_current_locus
;
5812 gfc_gobble_whitespace ();
5813 peek_char
= gfc_peek_ascii_char ();
5815 if (state
== COMP_SUBROUTINE
)
5817 m
= gfc_match_formal_arglist (entry
, 0, 1);
5821 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5822 never be an internal procedure. */
5823 is_bind_c
= gfc_match_bind_c (entry
, true);
5824 if (is_bind_c
== MATCH_ERROR
)
5826 if (is_bind_c
== MATCH_YES
)
5828 if (peek_char
!= '(')
5830 gfc_error ("Missing required parentheses before BIND(C) at %C");
5833 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5834 &(entry
->declared_at
), 1))
5838 if (!gfc_current_ns
->parent
5839 && !add_global_entry (name
, entry
->binding_label
, true,
5843 /* An entry in a subroutine. */
5844 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5845 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5850 /* An entry in a function.
5851 We need to take special care because writing
5856 ENTRY f() RESULT (r)
5858 ENTRY f RESULT (r). */
5859 if (gfc_match_eos () == MATCH_YES
)
5861 gfc_current_locus
= old_loc
;
5862 /* Match the empty argument list, and add the interface to
5864 m
= gfc_match_formal_arglist (entry
, 0, 1);
5867 m
= gfc_match_formal_arglist (entry
, 0, 0);
5874 if (gfc_match_eos () == MATCH_YES
)
5876 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5877 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5880 entry
->result
= entry
;
5884 m
= gfc_match_suffix (entry
, &result
);
5886 gfc_syntax_error (ST_ENTRY
);
5892 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5893 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5894 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5896 entry
->result
= result
;
5900 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5901 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5903 entry
->result
= entry
;
5907 if (!gfc_current_ns
->parent
5908 && !add_global_entry (name
, entry
->binding_label
, false,
5913 if (gfc_match_eos () != MATCH_YES
)
5915 gfc_syntax_error (ST_ENTRY
);
5919 entry
->attr
.recursive
= proc
->attr
.recursive
;
5920 entry
->attr
.elemental
= proc
->attr
.elemental
;
5921 entry
->attr
.pure
= proc
->attr
.pure
;
5923 el
= gfc_get_entry_list ();
5925 el
->next
= gfc_current_ns
->entries
;
5926 gfc_current_ns
->entries
= el
;
5928 el
->id
= el
->next
->id
+ 1;
5932 new_st
.op
= EXEC_ENTRY
;
5933 new_st
.ext
.entry
= el
;
5939 /* Match a subroutine statement, including optional prefixes. */
5942 gfc_match_subroutine (void)
5944 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5949 bool allow_binding_name
;
5951 if (gfc_current_state () != COMP_NONE
5952 && gfc_current_state () != COMP_INTERFACE
5953 && gfc_current_state () != COMP_CONTAINS
)
5956 m
= gfc_match_prefix (NULL
);
5960 m
= gfc_match ("subroutine% %n", name
);
5964 if (get_proc_name (name
, &sym
, false))
5967 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5968 the symbol existed before. */
5969 sym
->declared_at
= gfc_current_locus
;
5971 if (current_attr
.module_procedure
)
5972 sym
->attr
.module_procedure
= 1;
5974 if (add_hidden_procptr_result (sym
))
5977 gfc_new_block
= sym
;
5979 /* Check what next non-whitespace character is so we can tell if there
5980 is the required parens if we have a BIND(C). */
5981 gfc_gobble_whitespace ();
5982 peek_char
= gfc_peek_ascii_char ();
5984 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5987 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5990 /* Make sure that it isn't already declared as BIND(C). If it is, it
5991 must have been marked BIND(C) with a BIND(C) attribute and that is
5992 not allowed for procedures. */
5993 if (sym
->attr
.is_bind_c
== 1)
5995 sym
->attr
.is_bind_c
= 0;
5996 if (sym
->old_symbol
!= NULL
)
5997 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5998 "variables or common blocks",
5999 &(sym
->old_symbol
->declared_at
));
6001 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6002 "variables or common blocks", &gfc_current_locus
);
6005 /* C binding names are not allowed for internal procedures. */
6006 if (gfc_current_state () == COMP_CONTAINS
6007 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6008 allow_binding_name
= false;
6010 allow_binding_name
= true;
6012 /* Here, we are just checking if it has the bind(c) attribute, and if
6013 so, then we need to make sure it's all correct. If it doesn't,
6014 we still need to continue matching the rest of the subroutine line. */
6015 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6016 if (is_bind_c
== MATCH_ERROR
)
6018 /* There was an attempt at the bind(c), but it was wrong. An
6019 error message should have been printed w/in the gfc_match_bind_c
6020 so here we'll just return the MATCH_ERROR. */
6024 if (is_bind_c
== MATCH_YES
)
6026 /* The following is allowed in the Fortran 2008 draft. */
6027 if (gfc_current_state () == COMP_CONTAINS
6028 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6029 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6030 "at %L may not be specified for an internal "
6031 "procedure", &gfc_current_locus
))
6034 if (peek_char
!= '(')
6036 gfc_error ("Missing required parentheses before BIND(C) at %C");
6039 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6040 &(sym
->declared_at
), 1))
6044 if (gfc_match_eos () != MATCH_YES
)
6046 gfc_syntax_error (ST_SUBROUTINE
);
6050 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6053 /* Warn if it has the same name as an intrinsic. */
6054 do_warn_intrinsic_shadow (sym
, false);
6060 /* Check that the NAME identifier in a BIND attribute or statement
6061 is conform to C identifier rules. */
6064 check_bind_name_identifier (char **name
)
6066 char *n
= *name
, *p
;
6068 /* Remove leading spaces. */
6072 /* On an empty string, free memory and set name to NULL. */
6080 /* Remove trailing spaces. */
6081 p
= n
+ strlen(n
) - 1;
6085 /* Insert the identifier into the symbol table. */
6090 /* Now check that identifier is valid under C rules. */
6093 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6098 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6100 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6108 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6109 given, and set the binding label in either the given symbol (if not
6110 NULL), or in the current_ts. The symbol may be NULL because we may
6111 encounter the BIND(C) before the declaration itself. Return
6112 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6113 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6114 or MATCH_YES if the specifier was correct and the binding label and
6115 bind(c) fields were set correctly for the given symbol or the
6116 current_ts. If allow_binding_name is false, no binding name may be
6120 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6122 char *binding_label
= NULL
;
6125 /* Initialize the flag that specifies whether we encountered a NAME=
6126 specifier or not. */
6127 has_name_equals
= 0;
6129 /* This much we have to be able to match, in this order, if
6130 there is a bind(c) label. */
6131 if (gfc_match (" bind ( c ") != MATCH_YES
)
6134 /* Now see if there is a binding label, or if we've reached the
6135 end of the bind(c) attribute without one. */
6136 if (gfc_match_char (',') == MATCH_YES
)
6138 if (gfc_match (" name = ") != MATCH_YES
)
6140 gfc_error ("Syntax error in NAME= specifier for binding label "
6142 /* should give an error message here */
6146 has_name_equals
= 1;
6148 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6154 if (!gfc_simplify_expr(e
, 0))
6156 gfc_error ("NAME= specifier at %C should be a constant expression");
6161 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6162 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6164 gfc_error ("NAME= specifier at %C should be a scalar of "
6165 "default character kind");
6170 // Get a C string from the Fortran string constant
6171 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6172 e
->value
.character
.length
);
6175 // Check that it is valid (old gfc_match_name_C)
6176 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6180 /* Get the required right paren. */
6181 if (gfc_match_char (')') != MATCH_YES
)
6183 gfc_error ("Missing closing paren for binding label at %C");
6187 if (has_name_equals
&& !allow_binding_name
)
6189 gfc_error ("No binding name is allowed in BIND(C) at %C");
6193 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6195 gfc_error ("For dummy procedure %s, no binding name is "
6196 "allowed in BIND(C) at %C", sym
->name
);
6201 /* Save the binding label to the symbol. If sym is null, we're
6202 probably matching the typespec attributes of a declaration and
6203 haven't gotten the name yet, and therefore, no symbol yet. */
6207 sym
->binding_label
= binding_label
;
6209 curr_binding_label
= binding_label
;
6211 else if (allow_binding_name
)
6213 /* No binding label, but if symbol isn't null, we
6214 can set the label for it here.
6215 If name="" or allow_binding_name is false, no C binding name is
6217 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6218 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6221 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6222 && current_interface
.type
== INTERFACE_ABSTRACT
)
6224 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6232 /* Return nonzero if we're currently compiling a contained procedure. */
6235 contained_procedure (void)
6237 gfc_state_data
*s
= gfc_state_stack
;
6239 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6240 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6246 /* Set the kind of each enumerator. The kind is selected such that it is
6247 interoperable with the corresponding C enumeration type, making
6248 sure that -fshort-enums is honored. */
6253 enumerator_history
*current_history
= NULL
;
6257 if (max_enum
== NULL
|| enum_history
== NULL
)
6260 if (!flag_short_enums
)
6266 kind
= gfc_integer_kinds
[i
++].kind
;
6268 while (kind
< gfc_c_int_kind
6269 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6272 current_history
= enum_history
;
6273 while (current_history
!= NULL
)
6275 current_history
->sym
->ts
.kind
= kind
;
6276 current_history
= current_history
->next
;
6281 /* Match any of the various end-block statements. Returns the type of
6282 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6283 and END BLOCK statements cannot be replaced by a single END statement. */
6286 gfc_match_end (gfc_statement
*st
)
6288 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6289 gfc_compile_state state
;
6291 const char *block_name
;
6295 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6296 gfc_namespace
**nsp
;
6297 bool abreviated_modproc_decl
;
6299 old_loc
= gfc_current_locus
;
6300 if (gfc_match ("end") != MATCH_YES
)
6303 state
= gfc_current_state ();
6304 block_name
= gfc_current_block () == NULL
6305 ? NULL
: gfc_current_block ()->name
;
6309 case COMP_ASSOCIATE
:
6311 if (!strncmp (block_name
, "block@", strlen("block@")))
6316 case COMP_DERIVED_CONTAINS
:
6317 state
= gfc_state_stack
->previous
->state
;
6318 block_name
= gfc_state_stack
->previous
->sym
== NULL
6319 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6326 abreviated_modproc_decl
6327 = gfc_current_block ()
6328 && gfc_current_block ()->abr_modproc_decl
;
6334 *st
= ST_END_PROGRAM
;
6335 target
= " program";
6339 case COMP_SUBROUTINE
:
6340 *st
= ST_END_SUBROUTINE
;
6341 if (!abreviated_modproc_decl
)
6342 target
= " subroutine";
6344 target
= " procedure";
6345 eos_ok
= !contained_procedure ();
6349 *st
= ST_END_FUNCTION
;
6350 if (!abreviated_modproc_decl
)
6351 target
= " function";
6353 target
= " procedure";
6354 eos_ok
= !contained_procedure ();
6357 case COMP_BLOCK_DATA
:
6358 *st
= ST_END_BLOCK_DATA
;
6359 target
= " block data";
6364 *st
= ST_END_MODULE
;
6369 case COMP_SUBMODULE
:
6370 *st
= ST_END_SUBMODULE
;
6371 target
= " submodule";
6375 case COMP_INTERFACE
:
6376 *st
= ST_END_INTERFACE
;
6377 target
= " interface";
6382 case COMP_DERIVED_CONTAINS
:
6388 case COMP_ASSOCIATE
:
6389 *st
= ST_END_ASSOCIATE
;
6390 target
= " associate";
6407 case COMP_DO_CONCURRENT
:
6414 *st
= ST_END_CRITICAL
;
6415 target
= " critical";
6420 case COMP_SELECT_TYPE
:
6421 *st
= ST_END_SELECT
;
6427 *st
= ST_END_FORALL
;
6442 last_initializer
= NULL
;
6444 gfc_free_enum_history ();
6448 gfc_error ("Unexpected END statement at %C");
6452 old_loc
= gfc_current_locus
;
6453 if (gfc_match_eos () == MATCH_YES
)
6455 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6457 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6458 "instead of %s statement at %L",
6459 abreviated_modproc_decl
? "END PROCEDURE"
6460 : gfc_ascii_statement(*st
), &old_loc
))
6465 /* We would have required END [something]. */
6466 gfc_error ("%s statement expected at %L",
6467 gfc_ascii_statement (*st
), &old_loc
);
6474 /* Verify that we've got the sort of end-block that we're expecting. */
6475 if (gfc_match (target
) != MATCH_YES
)
6477 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6478 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6482 old_loc
= gfc_current_locus
;
6483 /* If we're at the end, make sure a block name wasn't required. */
6484 if (gfc_match_eos () == MATCH_YES
)
6487 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6488 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6489 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6495 gfc_error ("Expected block name of %qs in %s statement at %L",
6496 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6501 /* END INTERFACE has a special handler for its several possible endings. */
6502 if (*st
== ST_END_INTERFACE
)
6503 return gfc_match_end_interface ();
6505 /* We haven't hit the end of statement, so what is left must be an
6507 m
= gfc_match_space ();
6509 m
= gfc_match_name (name
);
6512 gfc_error ("Expected terminating name at %C");
6516 if (block_name
== NULL
)
6519 /* We have to pick out the declared submodule name from the composite
6520 required by F2008:11.2.3 para 2, which ends in the declared name. */
6521 if (state
== COMP_SUBMODULE
)
6522 block_name
= strchr (block_name
, '.') + 1;
6524 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6526 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6527 gfc_ascii_statement (*st
));
6530 /* Procedure pointer as function result. */
6531 else if (strcmp (block_name
, "ppr@") == 0
6532 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6534 gfc_error ("Expected label %qs for %s statement at %C",
6535 gfc_current_block ()->ns
->proc_name
->name
,
6536 gfc_ascii_statement (*st
));
6540 if (gfc_match_eos () == MATCH_YES
)
6544 gfc_syntax_error (*st
);
6547 gfc_current_locus
= old_loc
;
6549 /* If we are missing an END BLOCK, we created a half-ready namespace.
6550 Remove it from the parent namespace's sibling list. */
6552 while (state
== COMP_BLOCK
)
6554 parent_ns
= gfc_current_ns
->parent
;
6556 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6562 if (ns
== gfc_current_ns
)
6564 if (prev_ns
== NULL
)
6567 prev_ns
->sibling
= ns
->sibling
;
6573 gfc_free_namespace (gfc_current_ns
);
6574 gfc_current_ns
= parent_ns
;
6575 gfc_state_stack
= gfc_state_stack
->previous
;
6576 state
= gfc_current_state ();
6584 /***************** Attribute declaration statements ****************/
6586 /* Set the attribute of a single variable. */
6591 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6594 /* Workaround -Wmaybe-uninitialized false positive during
6595 profiledbootstrap by initializing them. */
6596 gfc_symbol
*sym
= NULL
;
6602 m
= gfc_match_name (name
);
6606 if (find_special (name
, &sym
, false))
6609 if (!check_function_name (name
))
6615 var_locus
= gfc_current_locus
;
6617 /* Deal with possible array specification for certain attributes. */
6618 if (current_attr
.dimension
6619 || current_attr
.codimension
6620 || current_attr
.allocatable
6621 || current_attr
.pointer
6622 || current_attr
.target
)
6624 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6625 !current_attr
.dimension
6626 && !current_attr
.pointer
6627 && !current_attr
.target
);
6628 if (m
== MATCH_ERROR
)
6631 if (current_attr
.dimension
&& m
== MATCH_NO
)
6633 gfc_error ("Missing array specification at %L in DIMENSION "
6634 "statement", &var_locus
);
6639 if (current_attr
.dimension
&& sym
->value
)
6641 gfc_error ("Dimensions specified for %s at %L after its "
6642 "initialisation", sym
->name
, &var_locus
);
6647 if (current_attr
.codimension
&& m
== MATCH_NO
)
6649 gfc_error ("Missing array specification at %L in CODIMENSION "
6650 "statement", &var_locus
);
6655 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6656 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6658 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6664 /* Update symbol table. DIMENSION attribute is set in
6665 gfc_set_array_spec(). For CLASS variables, this must be applied
6666 to the first component, or '_data' field. */
6667 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6669 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6677 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6678 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6685 if (sym
->ts
.type
== BT_CLASS
6686 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6692 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6698 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6700 /* Fix the array spec. */
6701 m
= gfc_mod_pointee_as (sym
->as
);
6702 if (m
== MATCH_ERROR
)
6706 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6712 if ((current_attr
.external
|| current_attr
.intrinsic
)
6713 && sym
->attr
.flavor
!= FL_PROCEDURE
6714 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6720 add_hidden_procptr_result (sym
);
6725 gfc_free_array_spec (as
);
6730 /* Generic attribute declaration subroutine. Used for attributes that
6731 just have a list of names. */
6738 /* Gobble the optional double colon, by simply ignoring the result
6748 if (gfc_match_eos () == MATCH_YES
)
6754 if (gfc_match_char (',') != MATCH_YES
)
6756 gfc_error ("Unexpected character in variable list at %C");
6766 /* This routine matches Cray Pointer declarations of the form:
6767 pointer ( <pointer>, <pointee> )
6769 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6770 The pointer, if already declared, should be an integer. Otherwise, we
6771 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6772 be either a scalar, or an array declaration. No space is allocated for
6773 the pointee. For the statement
6774 pointer (ipt, ar(10))
6775 any subsequent uses of ar will be translated (in C-notation) as
6776 ar(i) => ((<type> *) ipt)(i)
6777 After gimplification, pointee variable will disappear in the code. */
6780 cray_pointer_decl (void)
6783 gfc_array_spec
*as
= NULL
;
6784 gfc_symbol
*cptr
; /* Pointer symbol. */
6785 gfc_symbol
*cpte
; /* Pointee symbol. */
6791 if (gfc_match_char ('(') != MATCH_YES
)
6793 gfc_error ("Expected %<(%> at %C");
6797 /* Match pointer. */
6798 var_locus
= gfc_current_locus
;
6799 gfc_clear_attr (¤t_attr
);
6800 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6801 current_ts
.type
= BT_INTEGER
;
6802 current_ts
.kind
= gfc_index_integer_kind
;
6804 m
= gfc_match_symbol (&cptr
, 0);
6807 gfc_error ("Expected variable name at %C");
6811 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6814 gfc_set_sym_referenced (cptr
);
6816 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6818 cptr
->ts
.type
= BT_INTEGER
;
6819 cptr
->ts
.kind
= gfc_index_integer_kind
;
6821 else if (cptr
->ts
.type
!= BT_INTEGER
)
6823 gfc_error ("Cray pointer at %C must be an integer");
6826 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6827 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6828 " memory addresses require %d bytes",
6829 cptr
->ts
.kind
, gfc_index_integer_kind
);
6831 if (gfc_match_char (',') != MATCH_YES
)
6833 gfc_error ("Expected \",\" at %C");
6837 /* Match Pointee. */
6838 var_locus
= gfc_current_locus
;
6839 gfc_clear_attr (¤t_attr
);
6840 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6841 current_ts
.type
= BT_UNKNOWN
;
6842 current_ts
.kind
= 0;
6844 m
= gfc_match_symbol (&cpte
, 0);
6847 gfc_error ("Expected variable name at %C");
6851 /* Check for an optional array spec. */
6852 m
= gfc_match_array_spec (&as
, true, false);
6853 if (m
== MATCH_ERROR
)
6855 gfc_free_array_spec (as
);
6858 else if (m
== MATCH_NO
)
6860 gfc_free_array_spec (as
);
6864 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6867 gfc_set_sym_referenced (cpte
);
6869 if (cpte
->as
== NULL
)
6871 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6872 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6874 else if (as
!= NULL
)
6876 gfc_error ("Duplicate array spec for Cray pointee at %C");
6877 gfc_free_array_spec (as
);
6883 if (cpte
->as
!= NULL
)
6885 /* Fix array spec. */
6886 m
= gfc_mod_pointee_as (cpte
->as
);
6887 if (m
== MATCH_ERROR
)
6891 /* Point the Pointee at the Pointer. */
6892 cpte
->cp_pointer
= cptr
;
6894 if (gfc_match_char (')') != MATCH_YES
)
6896 gfc_error ("Expected \")\" at %C");
6899 m
= gfc_match_char (',');
6901 done
= true; /* Stop searching for more declarations. */
6905 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6906 || gfc_match_eos () != MATCH_YES
)
6908 gfc_error ("Expected %<,%> or end of statement at %C");
6916 gfc_match_external (void)
6919 gfc_clear_attr (¤t_attr
);
6920 current_attr
.external
= 1;
6922 return attr_decl ();
6927 gfc_match_intent (void)
6931 /* This is not allowed within a BLOCK construct! */
6932 if (gfc_current_state () == COMP_BLOCK
)
6934 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6938 intent
= match_intent_spec ();
6939 if (intent
== INTENT_UNKNOWN
)
6942 gfc_clear_attr (¤t_attr
);
6943 current_attr
.intent
= intent
;
6945 return attr_decl ();
6950 gfc_match_intrinsic (void)
6953 gfc_clear_attr (¤t_attr
);
6954 current_attr
.intrinsic
= 1;
6956 return attr_decl ();
6961 gfc_match_optional (void)
6963 /* This is not allowed within a BLOCK construct! */
6964 if (gfc_current_state () == COMP_BLOCK
)
6966 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6970 gfc_clear_attr (¤t_attr
);
6971 current_attr
.optional
= 1;
6973 return attr_decl ();
6978 gfc_match_pointer (void)
6980 gfc_gobble_whitespace ();
6981 if (gfc_peek_ascii_char () == '(')
6983 if (!flag_cray_pointer
)
6985 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6989 return cray_pointer_decl ();
6993 gfc_clear_attr (¤t_attr
);
6994 current_attr
.pointer
= 1;
6996 return attr_decl ();
7002 gfc_match_allocatable (void)
7004 gfc_clear_attr (¤t_attr
);
7005 current_attr
.allocatable
= 1;
7007 return attr_decl ();
7012 gfc_match_codimension (void)
7014 gfc_clear_attr (¤t_attr
);
7015 current_attr
.codimension
= 1;
7017 return attr_decl ();
7022 gfc_match_contiguous (void)
7024 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7027 gfc_clear_attr (¤t_attr
);
7028 current_attr
.contiguous
= 1;
7030 return attr_decl ();
7035 gfc_match_dimension (void)
7037 gfc_clear_attr (¤t_attr
);
7038 current_attr
.dimension
= 1;
7040 return attr_decl ();
7045 gfc_match_target (void)
7047 gfc_clear_attr (¤t_attr
);
7048 current_attr
.target
= 1;
7050 return attr_decl ();
7054 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7058 access_attr_decl (gfc_statement st
)
7060 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7061 interface_type type
;
7063 gfc_symbol
*sym
, *dt_sym
;
7064 gfc_intrinsic_op op
;
7067 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7072 m
= gfc_match_generic_spec (&type
, name
, &op
);
7075 if (m
== MATCH_ERROR
)
7080 case INTERFACE_NAMELESS
:
7081 case INTERFACE_ABSTRACT
:
7084 case INTERFACE_GENERIC
:
7085 if (gfc_get_symbol (name
, NULL
, &sym
))
7088 if (!gfc_add_access (&sym
->attr
,
7090 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7094 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7095 && !gfc_add_access (&dt_sym
->attr
,
7097 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7103 case INTERFACE_INTRINSIC_OP
:
7104 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7106 gfc_intrinsic_op other_op
;
7108 gfc_current_ns
->operator_access
[op
] =
7109 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7111 /* Handle the case if there is another op with the same
7112 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7113 other_op
= gfc_equivalent_op (op
);
7115 if (other_op
!= INTRINSIC_NONE
)
7116 gfc_current_ns
->operator_access
[other_op
] =
7117 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7122 gfc_error ("Access specification of the %s operator at %C has "
7123 "already been specified", gfc_op2string (op
));
7129 case INTERFACE_USER_OP
:
7130 uop
= gfc_get_uop (name
);
7132 if (uop
->access
== ACCESS_UNKNOWN
)
7134 uop
->access
= (st
== ST_PUBLIC
)
7135 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7139 gfc_error ("Access specification of the .%s. operator at %C "
7140 "has already been specified", sym
->name
);
7147 if (gfc_match_char (',') == MATCH_NO
)
7151 if (gfc_match_eos () != MATCH_YES
)
7156 gfc_syntax_error (st
);
7164 gfc_match_protected (void)
7169 if (!gfc_current_ns
->proc_name
7170 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7172 gfc_error ("PROTECTED at %C only allowed in specification "
7173 "part of a module");
7178 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7181 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7186 if (gfc_match_eos () == MATCH_YES
)
7191 m
= gfc_match_symbol (&sym
, 0);
7195 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7207 if (gfc_match_eos () == MATCH_YES
)
7209 if (gfc_match_char (',') != MATCH_YES
)
7216 gfc_error ("Syntax error in PROTECTED statement at %C");
7221 /* The PRIVATE statement is a bit weird in that it can be an attribute
7222 declaration, but also works as a standalone statement inside of a
7223 type declaration or a module. */
7226 gfc_match_private (gfc_statement
*st
)
7229 if (gfc_match ("private") != MATCH_YES
)
7232 if (gfc_current_state () != COMP_MODULE
7233 && !(gfc_current_state () == COMP_DERIVED
7234 && gfc_state_stack
->previous
7235 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7236 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7237 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7238 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7240 gfc_error ("PRIVATE statement at %C is only allowed in the "
7241 "specification part of a module");
7245 if (gfc_current_state () == COMP_DERIVED
)
7247 if (gfc_match_eos () == MATCH_YES
)
7253 gfc_syntax_error (ST_PRIVATE
);
7257 if (gfc_match_eos () == MATCH_YES
)
7264 return access_attr_decl (ST_PRIVATE
);
7269 gfc_match_public (gfc_statement
*st
)
7272 if (gfc_match ("public") != MATCH_YES
)
7275 if (gfc_current_state () != COMP_MODULE
)
7277 gfc_error ("PUBLIC statement at %C is only allowed in the "
7278 "specification part of a module");
7282 if (gfc_match_eos () == MATCH_YES
)
7289 return access_attr_decl (ST_PUBLIC
);
7293 /* Workhorse for gfc_match_parameter. */
7303 m
= gfc_match_symbol (&sym
, 0);
7305 gfc_error ("Expected variable name at %C in PARAMETER statement");
7310 if (gfc_match_char ('=') == MATCH_NO
)
7312 gfc_error ("Expected = sign in PARAMETER statement at %C");
7316 m
= gfc_match_init_expr (&init
);
7318 gfc_error ("Expected expression at %C in PARAMETER statement");
7322 if (sym
->ts
.type
== BT_UNKNOWN
7323 && !gfc_set_default_type (sym
, 1, NULL
))
7329 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7330 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7338 gfc_error ("Initializing already initialized variable at %C");
7343 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7344 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7347 gfc_free_expr (init
);
7352 /* Match a parameter statement, with the weird syntax that these have. */
7355 gfc_match_parameter (void)
7359 if (gfc_match_char ('(') == MATCH_NO
)
7368 if (gfc_match (" )%t") == MATCH_YES
)
7371 if (gfc_match_char (',') != MATCH_YES
)
7373 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7383 /* Save statements have a special syntax. */
7386 gfc_match_save (void)
7388 char n
[GFC_MAX_SYMBOL_LEN
+1];
7393 if (gfc_match_eos () == MATCH_YES
)
7395 if (gfc_current_ns
->seen_save
)
7397 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7398 "follows previous SAVE statement"))
7402 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7406 if (gfc_current_ns
->save_all
)
7408 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7409 "blanket SAVE statement"))
7417 m
= gfc_match_symbol (&sym
, 0);
7421 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7422 &gfc_current_locus
))
7433 m
= gfc_match (" / %n /", &n
);
7434 if (m
== MATCH_ERROR
)
7439 c
= gfc_get_common (n
, 0);
7442 gfc_current_ns
->seen_save
= 1;
7445 if (gfc_match_eos () == MATCH_YES
)
7447 if (gfc_match_char (',') != MATCH_YES
)
7454 gfc_error ("Syntax error in SAVE statement at %C");
7460 gfc_match_value (void)
7465 /* This is not allowed within a BLOCK construct! */
7466 if (gfc_current_state () == COMP_BLOCK
)
7468 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7472 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7475 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7480 if (gfc_match_eos () == MATCH_YES
)
7485 m
= gfc_match_symbol (&sym
, 0);
7489 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7501 if (gfc_match_eos () == MATCH_YES
)
7503 if (gfc_match_char (',') != MATCH_YES
)
7510 gfc_error ("Syntax error in VALUE statement at %C");
7516 gfc_match_volatile (void)
7521 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7524 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7529 if (gfc_match_eos () == MATCH_YES
)
7534 /* VOLATILE is special because it can be added to host-associated
7535 symbols locally. Except for coarrays. */
7536 m
= gfc_match_symbol (&sym
, 1);
7540 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7541 for variable in a BLOCK which is defined outside of the BLOCK. */
7542 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7544 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7545 "%C, which is use-/host-associated", sym
->name
);
7548 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7560 if (gfc_match_eos () == MATCH_YES
)
7562 if (gfc_match_char (',') != MATCH_YES
)
7569 gfc_error ("Syntax error in VOLATILE statement at %C");
7575 gfc_match_asynchronous (void)
7580 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7583 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7588 if (gfc_match_eos () == MATCH_YES
)
7593 /* ASYNCHRONOUS is special because it can be added to host-associated
7595 m
= gfc_match_symbol (&sym
, 1);
7599 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7611 if (gfc_match_eos () == MATCH_YES
)
7613 if (gfc_match_char (',') != MATCH_YES
)
7620 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7625 /* Match a module procedure statement in a submodule. */
7628 gfc_match_submod_proc (void)
7630 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7631 gfc_symbol
*sym
, *fsym
;
7633 gfc_formal_arglist
*formal
, *head
, *tail
;
7635 if (gfc_current_state () != COMP_CONTAINS
7636 || !(gfc_state_stack
->previous
7637 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7640 m
= gfc_match (" module% procedure% %n", name
);
7644 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7648 if (get_proc_name (name
, &sym
, false))
7651 /* Make sure that the result field is appropriately filled, even though
7652 the result symbol will be replaced later on. */
7653 if (sym
->ts
.interface
->attr
.function
)
7655 if (sym
->ts
.interface
->result
7656 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7657 sym
->result
= sym
->ts
.interface
->result
;
7662 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7663 the symbol existed before. */
7664 sym
->declared_at
= gfc_current_locus
;
7666 if (!sym
->attr
.module_procedure
)
7669 /* Signal match_end to expect "end procedure". */
7670 sym
->abr_modproc_decl
= 1;
7672 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7673 sym
->attr
.if_source
= IFSRC_DECL
;
7675 gfc_new_block
= sym
;
7677 /* Make a new formal arglist with the symbols in the procedure
7680 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7682 if (formal
== sym
->formal
)
7683 head
= tail
= gfc_get_formal_arglist ();
7686 tail
->next
= gfc_get_formal_arglist ();
7690 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7694 gfc_set_sym_referenced (fsym
);
7697 /* The dummy symbols get cleaned up, when the formal_namespace of the
7698 interface declaration is cleared. This allows us to add the
7699 explicit interface as is done for other type of procedure. */
7700 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7701 &gfc_current_locus
))
7704 if (gfc_match_eos () != MATCH_YES
)
7706 gfc_syntax_error (ST_MODULE_PROC
);
7713 gfc_free_formal_arglist (head
);
7718 /* Match a module procedure statement. Note that we have to modify
7719 symbols in the parent's namespace because the current one was there
7720 to receive symbols that are in an interface's formal argument list. */
7723 gfc_match_modproc (void)
7725 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7729 gfc_namespace
*module_ns
;
7730 gfc_interface
*old_interface_head
, *interface
;
7732 if (gfc_state_stack
->state
!= COMP_INTERFACE
7733 || gfc_state_stack
->previous
== NULL
7734 || current_interface
.type
== INTERFACE_NAMELESS
7735 || current_interface
.type
== INTERFACE_ABSTRACT
)
7737 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7742 module_ns
= gfc_current_ns
->parent
;
7743 for (; module_ns
; module_ns
= module_ns
->parent
)
7744 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7745 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7746 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7747 && !module_ns
->proc_name
->attr
.contained
))
7750 if (module_ns
== NULL
)
7753 /* Store the current state of the interface. We will need it if we
7754 end up with a syntax error and need to recover. */
7755 old_interface_head
= gfc_current_interface_head ();
7757 /* Check if the F2008 optional double colon appears. */
7758 gfc_gobble_whitespace ();
7759 old_locus
= gfc_current_locus
;
7760 if (gfc_match ("::") == MATCH_YES
)
7762 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7763 "MODULE PROCEDURE statement at %L", &old_locus
))
7767 gfc_current_locus
= old_locus
;
7772 old_locus
= gfc_current_locus
;
7774 m
= gfc_match_name (name
);
7780 /* Check for syntax error before starting to add symbols to the
7781 current namespace. */
7782 if (gfc_match_eos () == MATCH_YES
)
7785 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7788 /* Now we're sure the syntax is valid, we process this item
7790 if (gfc_get_symbol (name
, module_ns
, &sym
))
7793 if (sym
->attr
.intrinsic
)
7795 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7796 "PROCEDURE", &old_locus
);
7800 if (sym
->attr
.proc
!= PROC_MODULE
7801 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7804 if (!gfc_add_interface (sym
))
7807 sym
->attr
.mod_proc
= 1;
7808 sym
->declared_at
= old_locus
;
7817 /* Restore the previous state of the interface. */
7818 interface
= gfc_current_interface_head ();
7819 gfc_set_current_interface_head (old_interface_head
);
7821 /* Free the new interfaces. */
7822 while (interface
!= old_interface_head
)
7824 gfc_interface
*i
= interface
->next
;
7829 /* And issue a syntax error. */
7830 gfc_syntax_error (ST_MODULE_PROC
);
7835 /* Check a derived type that is being extended. */
7838 check_extended_derived_type (char *name
)
7840 gfc_symbol
*extended
;
7842 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7844 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7848 extended
= gfc_find_dt_in_generic (extended
);
7853 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7857 if (extended
->attr
.flavor
!= FL_DERIVED
)
7859 gfc_error ("%qs in EXTENDS expression at %C is not a "
7860 "derived type", name
);
7864 if (extended
->attr
.is_bind_c
)
7866 gfc_error ("%qs cannot be extended at %C because it "
7867 "is BIND(C)", extended
->name
);
7871 if (extended
->attr
.sequence
)
7873 gfc_error ("%qs cannot be extended at %C because it "
7874 "is a SEQUENCE type", extended
->name
);
7882 /* Match the optional attribute specifiers for a type declaration.
7883 Return MATCH_ERROR if an error is encountered in one of the handled
7884 attributes (public, private, bind(c)), MATCH_NO if what's found is
7885 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7886 checking on attribute conflicts needs to be done. */
7889 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7891 /* See if the derived type is marked as private. */
7892 if (gfc_match (" , private") == MATCH_YES
)
7894 if (gfc_current_state () != COMP_MODULE
)
7896 gfc_error ("Derived type at %C can only be PRIVATE in the "
7897 "specification part of a module");
7901 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7904 else if (gfc_match (" , public") == MATCH_YES
)
7906 if (gfc_current_state () != COMP_MODULE
)
7908 gfc_error ("Derived type at %C can only be PUBLIC in the "
7909 "specification part of a module");
7913 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7916 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7918 /* If the type is defined to be bind(c) it then needs to make
7919 sure that all fields are interoperable. This will
7920 need to be a semantic check on the finished derived type.
7921 See 15.2.3 (lines 9-12) of F2003 draft. */
7922 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7925 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7927 else if (gfc_match (" , abstract") == MATCH_YES
)
7929 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7932 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7935 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7937 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7943 /* If we get here, something matched. */
7948 /* Match the beginning of a derived type declaration. If a type name
7949 was the result of a function, then it is possible to have a symbol
7950 already to be known as a derived type yet have no components. */
7953 gfc_match_derived_decl (void)
7955 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7956 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7957 symbol_attribute attr
;
7958 gfc_symbol
*sym
, *gensym
;
7959 gfc_symbol
*extended
;
7961 match is_type_attr_spec
= MATCH_NO
;
7962 bool seen_attr
= false;
7963 gfc_interface
*intr
= NULL
, *head
;
7965 if (gfc_current_state () == COMP_DERIVED
)
7970 gfc_clear_attr (&attr
);
7975 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7976 if (is_type_attr_spec
== MATCH_ERROR
)
7978 if (is_type_attr_spec
== MATCH_YES
)
7980 } while (is_type_attr_spec
== MATCH_YES
);
7982 /* Deal with derived type extensions. The extension attribute has
7983 been added to 'attr' but now the parent type must be found and
7986 extended
= check_extended_derived_type (parent
);
7988 if (parent
[0] && !extended
)
7991 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7993 gfc_error ("Expected :: in TYPE definition at %C");
7997 m
= gfc_match (" %n%t", name
);
8001 /* Make sure the name is not the name of an intrinsic type. */
8002 if (gfc_is_intrinsic_typename (name
))
8004 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8009 if (gfc_get_symbol (name
, NULL
, &gensym
))
8012 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8014 gfc_error ("Derived type name %qs at %C already has a basic type "
8015 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8019 if (!gensym
->attr
.generic
8020 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8023 if (!gensym
->attr
.function
8024 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8027 sym
= gfc_find_dt_in_generic (gensym
);
8029 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8031 gfc_error ("Derived type definition of %qs at %C has already been "
8032 "defined", sym
->name
);
8038 /* Use upper case to save the actual derived-type symbol. */
8039 gfc_get_symbol (gfc_get_string ("%c%s",
8040 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
8041 &gensym
->name
[1]), NULL
, &sym
);
8042 sym
->name
= gfc_get_string (gensym
->name
);
8043 head
= gensym
->generic
;
8044 intr
= gfc_get_interface ();
8046 intr
->where
= gfc_current_locus
;
8047 intr
->sym
->declared_at
= gfc_current_locus
;
8049 gensym
->generic
= intr
;
8050 gensym
->attr
.if_source
= IFSRC_DECL
;
8053 /* The symbol may already have the derived attribute without the
8054 components. The ways this can happen is via a function
8055 definition, an INTRINSIC statement or a subtype in another
8056 derived type that is a pointer. The first part of the AND clause
8057 is true if the symbol is not the return value of a function. */
8058 if (sym
->attr
.flavor
!= FL_DERIVED
8059 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8062 if (attr
.access
!= ACCESS_UNKNOWN
8063 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8065 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8066 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8067 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8071 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8072 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8073 gensym
->attr
.access
= sym
->attr
.access
;
8075 /* See if the derived type was labeled as bind(c). */
8076 if (attr
.is_bind_c
!= 0)
8077 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8079 /* Construct the f2k_derived namespace if it is not yet there. */
8080 if (!sym
->f2k_derived
)
8081 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8083 if (extended
&& !sym
->components
)
8087 /* Add the extended derived type as the first component. */
8088 gfc_add_component (sym
, parent
, &p
);
8090 gfc_set_sym_referenced (extended
);
8092 p
->ts
.type
= BT_DERIVED
;
8093 p
->ts
.u
.derived
= extended
;
8094 p
->initializer
= gfc_default_initializer (&p
->ts
);
8096 /* Set extension level. */
8097 if (extended
->attr
.extension
== 255)
8099 /* Since the extension field is 8 bit wide, we can only have
8100 up to 255 extension levels. */
8101 gfc_error ("Maximum extension level reached with type %qs at %L",
8102 extended
->name
, &extended
->declared_at
);
8105 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8107 /* Provide the links between the extended type and its extension. */
8108 if (!extended
->f2k_derived
)
8109 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8112 if (!sym
->hash_value
)
8113 /* Set the hash for the compound name for this type. */
8114 sym
->hash_value
= gfc_hash_value (sym
);
8116 /* Take over the ABSTRACT attribute. */
8117 sym
->attr
.abstract
= attr
.abstract
;
8119 gfc_new_block
= sym
;
8125 /* Cray Pointees can be declared as:
8126 pointer (ipt, a (n,m,...,*)) */
8129 gfc_mod_pointee_as (gfc_array_spec
*as
)
8131 as
->cray_pointee
= true; /* This will be useful to know later. */
8132 if (as
->type
== AS_ASSUMED_SIZE
)
8133 as
->cp_was_assumed
= true;
8134 else if (as
->type
== AS_ASSUMED_SHAPE
)
8136 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8143 /* Match the enum definition statement, here we are trying to match
8144 the first line of enum definition statement.
8145 Returns MATCH_YES if match is found. */
8148 gfc_match_enum (void)
8152 m
= gfc_match_eos ();
8156 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8163 /* Returns an initializer whose value is one higher than the value of the
8164 LAST_INITIALIZER argument. If the argument is NULL, the
8165 initializers value will be set to zero. The initializer's kind
8166 will be set to gfc_c_int_kind.
8168 If -fshort-enums is given, the appropriate kind will be selected
8169 later after all enumerators have been parsed. A warning is issued
8170 here if an initializer exceeds gfc_c_int_kind. */
8173 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8176 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8178 mpz_init (result
->value
.integer
);
8180 if (last_initializer
!= NULL
)
8182 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8183 result
->where
= last_initializer
->where
;
8185 if (gfc_check_integer_range (result
->value
.integer
,
8186 gfc_c_int_kind
) != ARITH_OK
)
8188 gfc_error ("Enumerator exceeds the C integer type at %C");
8194 /* Control comes here, if it's the very first enumerator and no
8195 initializer has been given. It will be initialized to zero. */
8196 mpz_set_si (result
->value
.integer
, 0);
8203 /* Match a variable name with an optional initializer. When this
8204 subroutine is called, a variable is expected to be parsed next.
8205 Depending on what is happening at the moment, updates either the
8206 symbol table or the current interface. */
8209 enumerator_decl (void)
8211 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8212 gfc_expr
*initializer
;
8213 gfc_array_spec
*as
= NULL
;
8221 old_locus
= gfc_current_locus
;
8223 /* When we get here, we've just matched a list of attributes and
8224 maybe a type and a double colon. The next thing we expect to see
8225 is the name of the symbol. */
8226 m
= gfc_match_name (name
);
8230 var_locus
= gfc_current_locus
;
8232 /* OK, we've successfully matched the declaration. Now put the
8233 symbol in the current namespace. If we fail to create the symbol,
8235 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8241 /* The double colon must be present in order to have initializers.
8242 Otherwise the statement is ambiguous with an assignment statement. */
8245 if (gfc_match_char ('=') == MATCH_YES
)
8247 m
= gfc_match_init_expr (&initializer
);
8250 gfc_error ("Expected an initialization expression at %C");
8259 /* If we do not have an initializer, the initialization value of the
8260 previous enumerator (stored in last_initializer) is incremented
8261 by 1 and is used to initialize the current enumerator. */
8262 if (initializer
== NULL
)
8263 initializer
= enum_initializer (last_initializer
, old_locus
);
8265 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8267 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8273 /* Store this current initializer, for the next enumerator variable
8274 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8275 use last_initializer below. */
8276 last_initializer
= initializer
;
8277 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8279 /* Maintain enumerator history. */
8280 gfc_find_symbol (name
, NULL
, 0, &sym
);
8281 create_enum_history (sym
, last_initializer
);
8283 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8286 /* Free stuff up and return. */
8287 gfc_free_expr (initializer
);
8293 /* Match the enumerator definition statement. */
8296 gfc_match_enumerator_def (void)
8301 gfc_clear_ts (¤t_ts
);
8303 m
= gfc_match (" enumerator");
8307 m
= gfc_match (" :: ");
8308 if (m
== MATCH_ERROR
)
8311 colon_seen
= (m
== MATCH_YES
);
8313 if (gfc_current_state () != COMP_ENUM
)
8315 gfc_error ("ENUM definition statement expected before %C");
8316 gfc_free_enum_history ();
8320 (¤t_ts
)->type
= BT_INTEGER
;
8321 (¤t_ts
)->kind
= gfc_c_int_kind
;
8323 gfc_clear_attr (¤t_attr
);
8324 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8333 m
= enumerator_decl ();
8334 if (m
== MATCH_ERROR
)
8336 gfc_free_enum_history ();
8342 if (gfc_match_eos () == MATCH_YES
)
8344 if (gfc_match_char (',') != MATCH_YES
)
8348 if (gfc_current_state () == COMP_ENUM
)
8350 gfc_free_enum_history ();
8351 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8356 gfc_free_array_spec (current_as
);
8363 /* Match binding attributes. */
8366 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8368 bool found_passing
= false;
8369 bool seen_ptr
= false;
8370 match m
= MATCH_YES
;
8372 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8373 this case the defaults are in there. */
8374 ba
->access
= ACCESS_UNKNOWN
;
8375 ba
->pass_arg
= NULL
;
8376 ba
->pass_arg_num
= 0;
8378 ba
->non_overridable
= 0;
8382 /* If we find a comma, we believe there are binding attributes. */
8383 m
= gfc_match_char (',');
8389 /* Access specifier. */
8391 m
= gfc_match (" public");
8392 if (m
== MATCH_ERROR
)
8396 if (ba
->access
!= ACCESS_UNKNOWN
)
8398 gfc_error ("Duplicate access-specifier at %C");
8402 ba
->access
= ACCESS_PUBLIC
;
8406 m
= gfc_match (" private");
8407 if (m
== MATCH_ERROR
)
8411 if (ba
->access
!= ACCESS_UNKNOWN
)
8413 gfc_error ("Duplicate access-specifier at %C");
8417 ba
->access
= ACCESS_PRIVATE
;
8421 /* If inside GENERIC, the following is not allowed. */
8426 m
= gfc_match (" nopass");
8427 if (m
== MATCH_ERROR
)
8433 gfc_error ("Binding attributes already specify passing,"
8434 " illegal NOPASS at %C");
8438 found_passing
= true;
8443 /* PASS possibly including argument. */
8444 m
= gfc_match (" pass");
8445 if (m
== MATCH_ERROR
)
8449 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8453 gfc_error ("Binding attributes already specify passing,"
8454 " illegal PASS at %C");
8458 m
= gfc_match (" ( %n )", arg
);
8459 if (m
== MATCH_ERROR
)
8462 ba
->pass_arg
= gfc_get_string (arg
);
8463 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8465 found_passing
= true;
8473 m
= gfc_match (" pointer");
8474 if (m
== MATCH_ERROR
)
8480 gfc_error ("Duplicate POINTER attribute at %C");
8490 /* NON_OVERRIDABLE flag. */
8491 m
= gfc_match (" non_overridable");
8492 if (m
== MATCH_ERROR
)
8496 if (ba
->non_overridable
)
8498 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8502 ba
->non_overridable
= 1;
8506 /* DEFERRED flag. */
8507 m
= gfc_match (" deferred");
8508 if (m
== MATCH_ERROR
)
8514 gfc_error ("Duplicate DEFERRED at %C");
8525 /* Nothing matching found. */
8527 gfc_error ("Expected access-specifier at %C");
8529 gfc_error ("Expected binding attribute at %C");
8532 while (gfc_match_char (',') == MATCH_YES
);
8534 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8535 if (ba
->non_overridable
&& ba
->deferred
)
8537 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8544 if (ba
->access
== ACCESS_UNKNOWN
)
8545 ba
->access
= gfc_typebound_default_access
;
8547 if (ppc
&& !seen_ptr
)
8549 gfc_error ("POINTER attribute is required for procedure pointer component"
8561 /* Match a PROCEDURE specific binding inside a derived type. */
8564 match_procedure_in_type (void)
8566 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8567 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8568 char* target
= NULL
, *ifc
= NULL
;
8569 gfc_typebound_proc tb
;
8578 /* Check current state. */
8579 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8580 block
= gfc_state_stack
->previous
->sym
;
8583 /* Try to match PROCEDURE(interface). */
8584 if (gfc_match (" (") == MATCH_YES
)
8586 m
= gfc_match_name (target_buf
);
8587 if (m
== MATCH_ERROR
)
8591 gfc_error ("Interface-name expected after %<(%> at %C");
8595 if (gfc_match (" )") != MATCH_YES
)
8597 gfc_error ("%<)%> expected at %C");
8604 /* Construct the data structure. */
8605 memset (&tb
, 0, sizeof (tb
));
8606 tb
.where
= gfc_current_locus
;
8608 /* Match binding attributes. */
8609 m
= match_binding_attributes (&tb
, false, false);
8610 if (m
== MATCH_ERROR
)
8612 seen_attrs
= (m
== MATCH_YES
);
8614 /* Check that attribute DEFERRED is given if an interface is specified. */
8615 if (tb
.deferred
&& !ifc
)
8617 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8620 if (ifc
&& !tb
.deferred
)
8622 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8626 /* Match the colons. */
8627 m
= gfc_match (" ::");
8628 if (m
== MATCH_ERROR
)
8630 seen_colons
= (m
== MATCH_YES
);
8631 if (seen_attrs
&& !seen_colons
)
8633 gfc_error ("Expected %<::%> after binding-attributes at %C");
8637 /* Match the binding names. */
8640 m
= gfc_match_name (name
);
8641 if (m
== MATCH_ERROR
)
8645 gfc_error ("Expected binding name at %C");
8649 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8652 /* Try to match the '=> target', if it's there. */
8654 m
= gfc_match (" =>");
8655 if (m
== MATCH_ERROR
)
8661 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8667 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8672 m
= gfc_match_name (target_buf
);
8673 if (m
== MATCH_ERROR
)
8677 gfc_error ("Expected binding target after %<=>%> at %C");
8680 target
= target_buf
;
8683 /* If no target was found, it has the same name as the binding. */
8687 /* Get the namespace to insert the symbols into. */
8688 ns
= block
->f2k_derived
;
8691 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8692 if (tb
.deferred
&& !block
->attr
.abstract
)
8694 gfc_error ("Type %qs containing DEFERRED binding at %C "
8695 "is not ABSTRACT", block
->name
);
8699 /* See if we already have a binding with this name in the symtree which
8700 would be an error. If a GENERIC already targeted this binding, it may
8701 be already there but then typebound is still NULL. */
8702 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8703 if (stree
&& stree
->n
.tb
)
8705 gfc_error ("There is already a procedure with binding name %qs for "
8706 "the derived type %qs at %C", name
, block
->name
);
8710 /* Insert it and set attributes. */
8714 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8717 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8719 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8722 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8724 if (gfc_match_eos () == MATCH_YES
)
8726 if (gfc_match_char (',') != MATCH_YES
)
8731 gfc_error ("Syntax error in PROCEDURE statement at %C");
8736 /* Match a GENERIC procedure binding inside a derived type. */
8739 gfc_match_generic (void)
8741 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8742 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8744 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8745 gfc_typebound_proc
* tb
;
8747 interface_type op_type
;
8748 gfc_intrinsic_op op
;
8751 /* Check current state. */
8752 if (gfc_current_state () == COMP_DERIVED
)
8754 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8757 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8759 block
= gfc_state_stack
->previous
->sym
;
8760 ns
= block
->f2k_derived
;
8761 gcc_assert (block
&& ns
);
8763 memset (&tbattr
, 0, sizeof (tbattr
));
8764 tbattr
.where
= gfc_current_locus
;
8766 /* See if we get an access-specifier. */
8767 m
= match_binding_attributes (&tbattr
, true, false);
8768 if (m
== MATCH_ERROR
)
8771 /* Now the colons, those are required. */
8772 if (gfc_match (" ::") != MATCH_YES
)
8774 gfc_error ("Expected %<::%> at %C");
8778 /* Match the binding name; depending on type (operator / generic) format
8779 it for future error messages into bind_name. */
8781 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8782 if (m
== MATCH_ERROR
)
8786 gfc_error ("Expected generic name or operator descriptor at %C");
8792 case INTERFACE_GENERIC
:
8793 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8796 case INTERFACE_USER_OP
:
8797 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8800 case INTERFACE_INTRINSIC_OP
:
8801 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8802 gfc_op2string (op
));
8805 case INTERFACE_NAMELESS
:
8806 gfc_error ("Malformed GENERIC statement at %C");
8814 /* Match the required =>. */
8815 if (gfc_match (" =>") != MATCH_YES
)
8817 gfc_error ("Expected %<=>%> at %C");
8821 /* Try to find existing GENERIC binding with this name / for this operator;
8822 if there is something, check that it is another GENERIC and then extend
8823 it rather than building a new node. Otherwise, create it and put it
8824 at the right position. */
8828 case INTERFACE_USER_OP
:
8829 case INTERFACE_GENERIC
:
8831 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8834 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8846 case INTERFACE_INTRINSIC_OP
:
8856 if (!tb
->is_generic
)
8858 gcc_assert (op_type
== INTERFACE_GENERIC
);
8859 gfc_error ("There's already a non-generic procedure with binding name"
8860 " %qs for the derived type %qs at %C",
8861 bind_name
, block
->name
);
8865 if (tb
->access
!= tbattr
.access
)
8867 gfc_error ("Binding at %C must have the same access as already"
8868 " defined binding %qs", bind_name
);
8874 tb
= gfc_get_typebound_proc (NULL
);
8875 tb
->where
= gfc_current_locus
;
8876 tb
->access
= tbattr
.access
;
8878 tb
->u
.generic
= NULL
;
8882 case INTERFACE_GENERIC
:
8883 case INTERFACE_USER_OP
:
8885 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8888 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8896 case INTERFACE_INTRINSIC_OP
:
8905 /* Now, match all following names as specific targets. */
8908 gfc_symtree
* target_st
;
8909 gfc_tbp_generic
* target
;
8911 m
= gfc_match_name (name
);
8912 if (m
== MATCH_ERROR
)
8916 gfc_error ("Expected specific binding name at %C");
8920 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8922 /* See if this is a duplicate specification. */
8923 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8924 if (target_st
== target
->specific_st
)
8926 gfc_error ("%qs already defined as specific binding for the"
8927 " generic %qs at %C", name
, bind_name
);
8931 target
= gfc_get_tbp_generic ();
8932 target
->specific_st
= target_st
;
8933 target
->specific
= NULL
;
8934 target
->next
= tb
->u
.generic
;
8935 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8936 || (op_type
== INTERFACE_INTRINSIC_OP
));
8937 tb
->u
.generic
= target
;
8939 while (gfc_match (" ,") == MATCH_YES
);
8941 /* Here should be the end. */
8942 if (gfc_match_eos () != MATCH_YES
)
8944 gfc_error ("Junk after GENERIC binding at %C");
8955 /* Match a FINAL declaration inside a derived type. */
8958 gfc_match_final_decl (void)
8960 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8963 gfc_namespace
* module_ns
;
8967 if (gfc_current_form
== FORM_FREE
)
8969 char c
= gfc_peek_ascii_char ();
8970 if (!gfc_is_whitespace (c
) && c
!= ':')
8974 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8976 if (gfc_current_form
== FORM_FIXED
)
8979 gfc_error ("FINAL declaration at %C must be inside a derived type "
8980 "CONTAINS section");
8984 block
= gfc_state_stack
->previous
->sym
;
8987 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8988 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8990 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8991 " specification part of a MODULE");
8995 module_ns
= gfc_current_ns
;
8996 gcc_assert (module_ns
);
8997 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8999 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9000 if (gfc_match (" ::") == MATCH_ERROR
)
9003 /* Match the sequence of procedure names. */
9010 if (first
&& gfc_match_eos () == MATCH_YES
)
9012 gfc_error ("Empty FINAL at %C");
9016 m
= gfc_match_name (name
);
9019 gfc_error ("Expected module procedure name at %C");
9022 else if (m
!= MATCH_YES
)
9025 if (gfc_match_eos () == MATCH_YES
)
9027 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9029 gfc_error ("Expected %<,%> at %C");
9033 if (gfc_get_symbol (name
, module_ns
, &sym
))
9035 gfc_error ("Unknown procedure name %qs at %C", name
);
9039 /* Mark the symbol as module procedure. */
9040 if (sym
->attr
.proc
!= PROC_MODULE
9041 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9044 /* Check if we already have this symbol in the list, this is an error. */
9045 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9046 if (f
->proc_sym
== sym
)
9048 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9053 /* Add this symbol to the list of finalizers. */
9054 gcc_assert (block
->f2k_derived
);
9056 f
= XCNEW (gfc_finalizer
);
9058 f
->proc_tree
= NULL
;
9059 f
->where
= gfc_current_locus
;
9060 f
->next
= block
->f2k_derived
->finalizers
;
9061 block
->f2k_derived
->finalizers
= f
;
9071 const ext_attr_t ext_attr_list
[] = {
9072 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9073 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9074 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9075 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9076 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9077 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9078 { NULL
, EXT_ATTR_LAST
, NULL
}
9081 /* Match a !GCC$ ATTRIBUTES statement of the form:
9082 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9083 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9085 TODO: We should support all GCC attributes using the same syntax for
9086 the attribute list, i.e. the list in C
9087 __attributes(( attribute-list ))
9089 !GCC$ ATTRIBUTES attribute-list ::
9090 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9093 As there is absolutely no risk of confusion, we should never return
9096 gfc_match_gcc_attributes (void)
9098 symbol_attribute attr
;
9099 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9104 gfc_clear_attr (&attr
);
9109 if (gfc_match_name (name
) != MATCH_YES
)
9112 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9113 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9116 if (id
== EXT_ATTR_LAST
)
9118 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9122 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9125 gfc_gobble_whitespace ();
9126 ch
= gfc_next_ascii_char ();
9129 /* This is the successful exit condition for the loop. */
9130 if (gfc_next_ascii_char () == ':')
9140 if (gfc_match_eos () == MATCH_YES
)
9145 m
= gfc_match_name (name
);
9149 if (find_special (name
, &sym
, true))
9152 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9154 if (gfc_match_eos () == MATCH_YES
)
9157 if (gfc_match_char (',') != MATCH_YES
)
9164 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");