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"
28 #include "constructor.h"
31 #include "stringpool.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
)->value
.function
.actual
719 && (*expr
)->value
.function
.actual
->expr
->symtree
)
722 e
= (*expr
)->value
.function
.actual
->expr
;
723 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
724 && e
->expr_type
== EXPR_VARIABLE
)
726 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
728 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
729 && e
->symtree
->n
.sym
->ts
.u
.cl
730 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->ts
.type
== BT_UNKNOWN
)
736 /* F2008, 4.4.3.1: The length is a type parameter; its kind is processor
737 dependent and its value is greater than or equal to zero.
738 F2008, 4.4.3.2: If the character length parameter value evaluates to
739 a negative value, the length of character entities declared is zero. */
740 if ((*expr
)->expr_type
== EXPR_CONSTANT
741 && mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
742 mpz_set_si ((*expr
)->value
.integer
, 0);
747 gfc_error ("Conflict in attributes of function argument at %C");
752 /* A character length is a '*' followed by a literal integer or a
753 char_len_param_value in parenthesis. */
756 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
762 m
= gfc_match_char ('*');
766 m
= gfc_match_small_literal_int (&length
, NULL
);
767 if (m
== MATCH_ERROR
)
772 if (obsolescent_check
773 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
775 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
779 if (gfc_match_char ('(') == MATCH_NO
)
782 m
= char_len_param_value (expr
, deferred
);
783 if (m
!= MATCH_YES
&& gfc_matching_function
)
789 if (m
== MATCH_ERROR
)
794 if (gfc_match_char (')') == MATCH_NO
)
796 gfc_free_expr (*expr
);
804 gfc_error ("Syntax error in character length specification at %C");
809 /* Special subroutine for finding a symbol. Check if the name is found
810 in the current name space. If not, and we're compiling a function or
811 subroutine and the parent compilation unit is an interface, then check
812 to see if the name we've been given is the name of the interface
813 (located in another namespace). */
816 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
822 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
825 *result
= st
? st
->n
.sym
: NULL
;
829 if (gfc_current_state () != COMP_SUBROUTINE
830 && gfc_current_state () != COMP_FUNCTION
)
833 s
= gfc_state_stack
->previous
;
837 if (s
->state
!= COMP_INTERFACE
)
840 goto end
; /* Nameless interface. */
842 if (strcmp (name
, s
->sym
->name
) == 0)
853 /* Special subroutine for getting a symbol node associated with a
854 procedure name, used in SUBROUTINE and FUNCTION statements. The
855 symbol is created in the parent using with symtree node in the
856 child unit pointing to the symbol. If the current namespace has no
857 parent, then the symbol is just created in the current unit. */
860 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
866 /* Module functions have to be left in their own namespace because
867 they have potentially (almost certainly!) already been referenced.
868 In this sense, they are rather like external functions. This is
869 fixed up in resolve.c(resolve_entries), where the symbol name-
870 space is set to point to the master function, so that the fake
871 result mechanism can work. */
872 if (module_fcn_entry
)
874 /* Present if entry is declared to be a module procedure. */
875 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
878 rc
= gfc_get_symbol (name
, NULL
, result
);
879 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
880 && (*result
)->ts
.type
== BT_UNKNOWN
881 && sym
->attr
.flavor
== FL_UNKNOWN
)
882 /* Pick up the typespec for the entry, if declared in the function
883 body. Note that this symbol is FL_UNKNOWN because it will
884 only have appeared in a type declaration. The local symtree
885 is set to point to the module symbol and a unique symtree
886 to the local version. This latter ensures a correct clearing
889 /* If the ENTRY proceeds its specification, we need to ensure
890 that this does not raise a "has no IMPLICIT type" error. */
891 if (sym
->ts
.type
== BT_UNKNOWN
)
892 sym
->attr
.untyped
= 1;
894 (*result
)->ts
= sym
->ts
;
896 /* Put the symbol in the procedure namespace so that, should
897 the ENTRY precede its specification, the specification
899 (*result
)->ns
= gfc_current_ns
;
901 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
903 st
= gfc_get_unique_symtree (gfc_current_ns
);
908 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
914 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
917 if (sym
->attr
.module_procedure
918 && sym
->attr
.if_source
== IFSRC_IFBODY
)
920 /* Create a partially populated interface symbol to carry the
921 characteristics of the procedure and the result. */
922 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
923 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
925 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
926 if (sym
->attr
.dimension
)
927 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
929 /* Ideally, at this point, a copy would be made of the formal
930 arguments and their namespace. However, this does not appear
931 to be necessary, albeit at the expense of not being able to
932 use gfc_compare_interfaces directly. */
934 if (sym
->result
&& sym
->result
!= sym
)
936 sym
->ts
.interface
->result
= sym
->result
;
939 else if (sym
->result
)
941 sym
->ts
.interface
->result
= sym
->ts
.interface
;
944 else if (sym
&& !sym
->gfc_new
945 && gfc_current_state () != COMP_INTERFACE
)
947 /* Trap another encompassed procedure with the same name. All
948 these conditions are necessary to avoid picking up an entry
949 whose name clashes with that of the encompassing procedure;
950 this is handled using gsymbols to register unique,globally
952 if (sym
->attr
.flavor
!= 0
953 && sym
->attr
.proc
!= 0
954 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
955 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
956 gfc_error_now ("Procedure %qs at %C is already defined at %L",
957 name
, &sym
->declared_at
);
959 /* Trap a procedure with a name the same as interface in the
960 encompassing scope. */
961 if (sym
->attr
.generic
!= 0
962 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
963 && !sym
->attr
.mod_proc
)
964 gfc_error_now ("Name %qs at %C is already defined"
965 " as a generic interface at %L",
966 name
, &sym
->declared_at
);
968 /* Trap declarations of attributes in encompassing scope. The
969 signature for this is that ts.kind is set. Legitimate
970 references only set ts.type. */
971 if (sym
->ts
.kind
!= 0
972 && !sym
->attr
.implicit_type
973 && sym
->attr
.proc
== 0
974 && gfc_current_ns
->parent
!= NULL
975 && sym
->attr
.access
== 0
976 && !module_fcn_entry
)
977 gfc_error_now ("Procedure %qs at %C has an explicit interface "
978 "and must not have attributes declared at %L",
979 name
, &sym
->declared_at
);
982 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
985 /* Module function entries will already have a symtree in
986 the current namespace but will need one at module level. */
987 if (module_fcn_entry
)
989 /* Present if entry is declared to be a module procedure. */
990 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
992 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
995 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1000 /* See if the procedure should be a module procedure. */
1002 if (((sym
->ns
->proc_name
!= NULL
1003 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1004 && sym
->attr
.proc
!= PROC_MODULE
)
1005 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1006 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1013 /* Verify that the given symbol representing a parameter is C
1014 interoperable, by checking to see if it was marked as such after
1015 its declaration. If the given symbol is not interoperable, a
1016 warning is reported, thus removing the need to return the status to
1017 the calling function. The standard does not require the user use
1018 one of the iso_c_binding named constants to declare an
1019 interoperable parameter, but we can't be sure if the param is C
1020 interop or not if the user doesn't. For example, integer(4) may be
1021 legal Fortran, but doesn't have meaning in C. It may interop with
1022 a number of the C types, which causes a problem because the
1023 compiler can't know which one. This code is almost certainly not
1024 portable, and the user will get what they deserve if the C type
1025 across platforms isn't always interoperable with integer(4). If
1026 the user had used something like integer(c_int) or integer(c_long),
1027 the compiler could have automatically handled the varying sizes
1028 across platforms. */
1031 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1033 int is_c_interop
= 0;
1036 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1037 Don't repeat the checks here. */
1038 if (sym
->attr
.implicit_type
)
1041 /* For subroutines or functions that are passed to a BIND(C) procedure,
1042 they're interoperable if they're BIND(C) and their params are all
1044 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1046 if (sym
->attr
.is_bind_c
== 0)
1048 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1049 "attribute to be C interoperable", sym
->name
,
1050 &(sym
->declared_at
));
1055 if (sym
->attr
.is_c_interop
== 1)
1056 /* We've already checked this procedure; don't check it again. */
1059 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1064 /* See if we've stored a reference to a procedure that owns sym. */
1065 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1067 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1069 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1071 if (is_c_interop
!= 1)
1073 /* Make personalized messages to give better feedback. */
1074 if (sym
->ts
.type
== BT_DERIVED
)
1075 gfc_error ("Variable %qs at %L is a dummy argument to the "
1076 "BIND(C) procedure %qs but is not C interoperable "
1077 "because derived type %qs is not C interoperable",
1078 sym
->name
, &(sym
->declared_at
),
1079 sym
->ns
->proc_name
->name
,
1080 sym
->ts
.u
.derived
->name
);
1081 else if (sym
->ts
.type
== BT_CLASS
)
1082 gfc_error ("Variable %qs at %L is a dummy argument to the "
1083 "BIND(C) procedure %qs but is not C interoperable "
1084 "because it is polymorphic",
1085 sym
->name
, &(sym
->declared_at
),
1086 sym
->ns
->proc_name
->name
);
1087 else if (warn_c_binding_type
)
1088 gfc_warning (OPT_Wc_binding_type
,
1089 "Variable %qs at %L is a dummy argument of the "
1090 "BIND(C) procedure %qs but may not be C "
1092 sym
->name
, &(sym
->declared_at
),
1093 sym
->ns
->proc_name
->name
);
1096 /* Character strings are only C interoperable if they have a
1098 if (sym
->ts
.type
== BT_CHARACTER
)
1100 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1101 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1102 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1104 gfc_error ("Character argument %qs at %L "
1105 "must be length 1 because "
1106 "procedure %qs is BIND(C)",
1107 sym
->name
, &sym
->declared_at
,
1108 sym
->ns
->proc_name
->name
);
1113 /* We have to make sure that any param to a bind(c) routine does
1114 not have the allocatable, pointer, or optional attributes,
1115 according to J3/04-007, section 5.1. */
1116 if (sym
->attr
.allocatable
== 1
1117 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1118 "ALLOCATABLE attribute in procedure %qs "
1119 "with BIND(C)", sym
->name
,
1120 &(sym
->declared_at
),
1121 sym
->ns
->proc_name
->name
))
1124 if (sym
->attr
.pointer
== 1
1125 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1126 "POINTER attribute in procedure %qs "
1127 "with BIND(C)", sym
->name
,
1128 &(sym
->declared_at
),
1129 sym
->ns
->proc_name
->name
))
1132 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1134 gfc_error ("Scalar variable %qs at %L with POINTER or "
1135 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1136 " supported", sym
->name
, &(sym
->declared_at
),
1137 sym
->ns
->proc_name
->name
);
1141 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1143 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1144 "and the VALUE attribute because procedure %qs "
1145 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1146 sym
->ns
->proc_name
->name
);
1149 else if (sym
->attr
.optional
== 1
1150 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1151 "at %L with OPTIONAL attribute in "
1152 "procedure %qs which is BIND(C)",
1153 sym
->name
, &(sym
->declared_at
),
1154 sym
->ns
->proc_name
->name
))
1157 /* Make sure that if it has the dimension attribute, that it is
1158 either assumed size or explicit shape. Deferred shape is already
1159 covered by the pointer/allocatable attribute. */
1160 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1161 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1162 "at %L as dummy argument to the BIND(C) "
1163 "procedure '%s' at %L", sym
->name
,
1164 &(sym
->declared_at
),
1165 sym
->ns
->proc_name
->name
,
1166 &(sym
->ns
->proc_name
->declared_at
)))
1176 /* Function called by variable_decl() that adds a name to the symbol table. */
1179 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1180 gfc_array_spec
**as
, locus
*var_locus
)
1182 symbol_attribute attr
;
1185 if (gfc_get_symbol (name
, NULL
, &sym
))
1188 /* Start updating the symbol table. Add basic type attribute if present. */
1189 if (current_ts
.type
!= BT_UNKNOWN
1190 && (sym
->attr
.implicit_type
== 0
1191 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1192 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1195 if (sym
->ts
.type
== BT_CHARACTER
)
1198 sym
->ts
.deferred
= cl_deferred
;
1201 /* Add dimension attribute if present. */
1202 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1206 /* Add attribute to symbol. The copy is so that we can reset the
1207 dimension attribute. */
1208 attr
= current_attr
;
1210 attr
.codimension
= 0;
1212 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1215 /* Finish any work that may need to be done for the binding label,
1216 if it's a bind(c). The bind(c) attr is found before the symbol
1217 is made, and before the symbol name (for data decls), so the
1218 current_ts is holding the binding label, or nothing if the
1219 name= attr wasn't given. Therefore, test here if we're dealing
1220 with a bind(c) and make sure the binding label is set correctly. */
1221 if (sym
->attr
.is_bind_c
== 1)
1223 if (!sym
->binding_label
)
1225 /* Set the binding label and verify that if a NAME= was specified
1226 then only one identifier was in the entity-decl-list. */
1227 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1228 num_idents_on_line
))
1233 /* See if we know we're in a common block, and if it's a bind(c)
1234 common then we need to make sure we're an interoperable type. */
1235 if (sym
->attr
.in_common
== 1)
1237 /* Test the common block object. */
1238 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1239 && sym
->ts
.is_c_interop
!= 1)
1241 gfc_error_now ("Variable %qs in common block %qs at %C "
1242 "must be declared with a C interoperable "
1243 "kind since common block %qs is BIND(C)",
1244 sym
->name
, sym
->common_block
->name
,
1245 sym
->common_block
->name
);
1250 sym
->attr
.implied_index
= 0;
1252 if (sym
->ts
.type
== BT_CLASS
)
1253 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1259 /* Set character constant to the given length. The constant will be padded or
1260 truncated. If we're inside an array constructor without a typespec, we
1261 additionally check that all elements have the same length; check_len -1
1262 means no checking. */
1265 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1270 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1271 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1273 slen
= expr
->value
.character
.length
;
1276 s
= gfc_get_wide_string (len
+ 1);
1277 memcpy (s
, expr
->value
.character
.string
,
1278 MIN (len
, slen
) * sizeof (gfc_char_t
));
1280 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1282 if (warn_character_truncation
&& slen
> len
)
1283 gfc_warning_now (OPT_Wcharacter_truncation
,
1284 "CHARACTER expression at %L is being truncated "
1285 "(%d/%d)", &expr
->where
, slen
, len
);
1287 /* Apply the standard by 'hand' otherwise it gets cleared for
1289 if (check_len
!= -1 && slen
!= check_len
1290 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1291 gfc_error_now ("The CHARACTER elements of the array constructor "
1292 "at %L must have the same length (%d/%d)",
1293 &expr
->where
, slen
, check_len
);
1296 free (expr
->value
.character
.string
);
1297 expr
->value
.character
.string
= s
;
1298 expr
->value
.character
.length
= len
;
1303 /* Function to create and update the enumerator history
1304 using the information passed as arguments.
1305 Pointer "max_enum" is also updated, to point to
1306 enum history node containing largest initializer.
1308 SYM points to the symbol node of enumerator.
1309 INIT points to its enumerator value. */
1312 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1314 enumerator_history
*new_enum_history
;
1315 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1317 new_enum_history
= XCNEW (enumerator_history
);
1319 new_enum_history
->sym
= sym
;
1320 new_enum_history
->initializer
= init
;
1321 new_enum_history
->next
= NULL
;
1323 if (enum_history
== NULL
)
1325 enum_history
= new_enum_history
;
1326 max_enum
= enum_history
;
1330 new_enum_history
->next
= enum_history
;
1331 enum_history
= new_enum_history
;
1333 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1334 new_enum_history
->initializer
->value
.integer
) < 0)
1335 max_enum
= new_enum_history
;
1340 /* Function to free enum kind history. */
1343 gfc_free_enum_history (void)
1345 enumerator_history
*current
= enum_history
;
1346 enumerator_history
*next
;
1348 while (current
!= NULL
)
1350 next
= current
->next
;
1355 enum_history
= NULL
;
1359 /* Function called by variable_decl() that adds an initialization
1360 expression to a symbol. */
1363 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1365 symbol_attribute attr
;
1370 if (find_special (name
, &sym
, false))
1375 /* If this symbol is confirming an implicit parameter type,
1376 then an initialization expression is not allowed. */
1377 if (attr
.flavor
== FL_PARAMETER
1378 && sym
->value
!= NULL
1381 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1388 /* An initializer is required for PARAMETER declarations. */
1389 if (attr
.flavor
== FL_PARAMETER
)
1391 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1397 /* If a variable appears in a DATA block, it cannot have an
1401 gfc_error ("Variable %qs at %C with an initializer already "
1402 "appears in a DATA statement", sym
->name
);
1406 /* Check if the assignment can happen. This has to be put off
1407 until later for derived type variables and procedure pointers. */
1408 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1409 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1410 && !sym
->attr
.proc_pointer
1411 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1414 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1415 && init
->ts
.type
== BT_CHARACTER
)
1417 /* Update symbol character length according initializer. */
1418 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1421 if (sym
->ts
.u
.cl
->length
== NULL
)
1424 /* If there are multiple CHARACTER variables declared on the
1425 same line, we don't want them to share the same length. */
1426 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1428 if (sym
->attr
.flavor
== FL_PARAMETER
)
1430 if (init
->expr_type
== EXPR_CONSTANT
)
1432 clen
= init
->value
.character
.length
;
1433 sym
->ts
.u
.cl
->length
1434 = gfc_get_int_expr (gfc_default_integer_kind
,
1437 else if (init
->expr_type
== EXPR_ARRAY
)
1439 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1440 sym
->ts
.u
.cl
->length
1441 = gfc_get_int_expr (gfc_default_integer_kind
,
1444 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1445 sym
->ts
.u
.cl
->length
=
1446 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1449 /* Update initializer character length according symbol. */
1450 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1454 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1457 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1459 if (init
->expr_type
== EXPR_CONSTANT
)
1460 gfc_set_constant_character_len (len
, init
, -1);
1461 else if (init
->expr_type
== EXPR_ARRAY
)
1465 /* Build a new charlen to prevent simplification from
1466 deleting the length before it is resolved. */
1467 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1468 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1470 for (c
= gfc_constructor_first (init
->value
.constructor
);
1471 c
; c
= gfc_constructor_next (c
))
1472 gfc_set_constant_character_len (len
, c
->expr
, -1);
1477 /* If sym is implied-shape, set its upper bounds from init. */
1478 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1479 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1483 if (init
->rank
== 0)
1485 gfc_error ("Can't initialize implied-shape array at %L"
1486 " with scalar", &sym
->declared_at
);
1489 gcc_assert (sym
->as
->rank
== init
->rank
);
1491 /* Shape should be present, we get an initialization expression. */
1492 gcc_assert (init
->shape
);
1494 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1500 lower
= sym
->as
->lower
[dim
];
1501 if (lower
->expr_type
!= EXPR_CONSTANT
)
1503 gfc_error ("Non-constant lower bound in implied-shape"
1504 " declaration at %L", &lower
->where
);
1508 /* All dimensions must be without upper bound. */
1509 gcc_assert (!sym
->as
->upper
[dim
]);
1512 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1513 mpz_add (e
->value
.integer
,
1514 lower
->value
.integer
, init
->shape
[dim
]);
1515 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1516 sym
->as
->upper
[dim
] = e
;
1519 sym
->as
->type
= AS_EXPLICIT
;
1522 /* Need to check if the expression we initialized this
1523 to was one of the iso_c_binding named constants. If so,
1524 and we're a parameter (constant), let it be iso_c.
1526 integer(c_int), parameter :: my_int = c_int
1527 integer(my_int) :: my_int_2
1528 If we mark my_int as iso_c (since we can see it's value
1529 is equal to one of the named constants), then my_int_2
1530 will be considered C interoperable. */
1531 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1533 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1534 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1535 /* attr bits needed for module files. */
1536 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1537 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1538 if (init
->ts
.is_iso_c
)
1539 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1542 /* Add initializer. Make sure we keep the ranks sane. */
1543 if (sym
->attr
.dimension
&& init
->rank
== 0)
1548 if (sym
->attr
.flavor
== FL_PARAMETER
1549 && init
->expr_type
== EXPR_CONSTANT
1550 && spec_size (sym
->as
, &size
)
1551 && mpz_cmp_si (size
, 0) > 0)
1553 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1555 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1556 gfc_constructor_append_expr (&array
->value
.constructor
,
1559 : gfc_copy_expr (init
),
1562 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1563 for (n
= 0; n
< sym
->as
->rank
; n
++)
1564 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1569 init
->rank
= sym
->as
->rank
;
1573 if (sym
->attr
.save
== SAVE_NONE
)
1574 sym
->attr
.save
= SAVE_IMPLICIT
;
1582 /* Function called by variable_decl() that adds a name to a structure
1586 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1587 gfc_array_spec
**as
)
1592 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1593 constructing, it must have the pointer attribute. */
1594 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1595 && current_ts
.u
.derived
== gfc_current_block ()
1596 && current_attr
.pointer
== 0)
1598 gfc_error ("Component at %C must have the POINTER attribute");
1602 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1604 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1606 gfc_error ("Array component of structure at %C must have explicit "
1607 "or deferred shape");
1612 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1616 if (c
->ts
.type
== BT_CHARACTER
)
1618 c
->attr
= current_attr
;
1620 c
->initializer
= *init
;
1627 c
->attr
.codimension
= 1;
1629 c
->attr
.dimension
= 1;
1633 /* Should this ever get more complicated, combine with similar section
1634 in add_init_expr_to_sym into a separate function. */
1635 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1637 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1641 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1642 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1643 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1645 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1647 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1648 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1649 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1650 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1652 gfc_constructor
*ctor
;
1653 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1658 bool has_ts
= (c
->initializer
->ts
.u
.cl
1659 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1661 /* Remember the length of the first element for checking
1662 that all elements *in the constructor* have the same
1663 length. This need not be the length of the LHS! */
1664 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1665 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1666 first_len
= ctor
->expr
->value
.character
.length
;
1668 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1669 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1671 gfc_set_constant_character_len (len
, ctor
->expr
,
1672 has_ts
? -1 : first_len
);
1673 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1679 /* Check array components. */
1680 if (!c
->attr
.dimension
)
1683 if (c
->attr
.pointer
)
1685 if (c
->as
->type
!= AS_DEFERRED
)
1687 gfc_error ("Pointer array component of structure at %C must have a "
1692 else if (c
->attr
.allocatable
)
1694 if (c
->as
->type
!= AS_DEFERRED
)
1696 gfc_error ("Allocatable component of structure at %C must have a "
1703 if (c
->as
->type
!= AS_EXPLICIT
)
1705 gfc_error ("Array component of structure at %C must have an "
1712 if (c
->ts
.type
== BT_CLASS
)
1714 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1724 /* Match a 'NULL()', and possibly take care of some side effects. */
1727 gfc_match_null (gfc_expr
**result
)
1730 match m
, m2
= MATCH_NO
;
1732 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1738 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1740 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1743 old_loc
= gfc_current_locus
;
1744 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1747 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1751 gfc_current_locus
= old_loc
;
1756 /* The NULL symbol now has to be/become an intrinsic function. */
1757 if (gfc_get_symbol ("null", NULL
, &sym
))
1759 gfc_error ("NULL() initialization at %C is ambiguous");
1763 gfc_intrinsic_symbol (sym
);
1765 if (sym
->attr
.proc
!= PROC_INTRINSIC
1766 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1767 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1768 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1771 *result
= gfc_get_null_expr (&gfc_current_locus
);
1773 /* Invalid per F2008, C512. */
1774 if (m2
== MATCH_YES
)
1776 gfc_error ("NULL() initialization at %C may not have MOLD");
1784 /* Match the initialization expr for a data pointer or procedure pointer. */
1787 match_pointer_init (gfc_expr
**init
, int procptr
)
1791 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1793 gfc_error ("Initialization of pointer at %C is not allowed in "
1794 "a PURE procedure");
1797 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1799 /* Match NULL() initialization. */
1800 m
= gfc_match_null (init
);
1804 /* Match non-NULL initialization. */
1805 gfc_matching_ptr_assignment
= !procptr
;
1806 gfc_matching_procptr_assignment
= procptr
;
1807 m
= gfc_match_rvalue (init
);
1808 gfc_matching_ptr_assignment
= 0;
1809 gfc_matching_procptr_assignment
= 0;
1810 if (m
== MATCH_ERROR
)
1812 else if (m
== MATCH_NO
)
1814 gfc_error ("Error in pointer initialization at %C");
1818 if (!procptr
&& !gfc_resolve_expr (*init
))
1821 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1822 "initialization at %C"))
1830 check_function_name (char *name
)
1832 /* In functions that have a RESULT variable defined, the function name always
1833 refers to function calls. Therefore, the name is not allowed to appear in
1834 specification statements. When checking this, be careful about
1835 'hidden' procedure pointer results ('ppr@'). */
1837 if (gfc_current_state () == COMP_FUNCTION
)
1839 gfc_symbol
*block
= gfc_current_block ();
1840 if (block
&& block
->result
&& block
->result
!= block
1841 && strcmp (block
->result
->name
, "ppr@") != 0
1842 && strcmp (block
->name
, name
) == 0)
1844 gfc_error ("Function name %qs not allowed at %C", name
);
1853 /* Match a variable name with an optional initializer. When this
1854 subroutine is called, a variable is expected to be parsed next.
1855 Depending on what is happening at the moment, updates either the
1856 symbol table or the current interface. */
1859 variable_decl (int elem
)
1861 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1862 gfc_expr
*initializer
, *char_len
;
1864 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1876 /* When we get here, we've just matched a list of attributes and
1877 maybe a type and a double colon. The next thing we expect to see
1878 is the name of the symbol. */
1879 m
= gfc_match_name (name
);
1883 var_locus
= gfc_current_locus
;
1885 /* Now we could see the optional array spec. or character length. */
1886 m
= gfc_match_array_spec (&as
, true, true);
1887 if (m
== MATCH_ERROR
)
1891 as
= gfc_copy_array_spec (current_as
);
1893 && !merge_array_spec (current_as
, as
, true))
1899 if (flag_cray_pointer
)
1900 cp_as
= gfc_copy_array_spec (as
);
1902 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1903 determine (and check) whether it can be implied-shape. If it
1904 was parsed as assumed-size, change it because PARAMETERs can not
1908 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1911 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1916 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1917 && current_attr
.flavor
== FL_PARAMETER
)
1918 as
->type
= AS_IMPLIED_SHAPE
;
1920 if (as
->type
== AS_IMPLIED_SHAPE
1921 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1931 cl_deferred
= false;
1933 if (current_ts
.type
== BT_CHARACTER
)
1935 switch (match_char_length (&char_len
, &cl_deferred
, false))
1938 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1940 cl
->length
= char_len
;
1943 /* Non-constant lengths need to be copied after the first
1944 element. Also copy assumed lengths. */
1947 && (current_ts
.u
.cl
->length
== NULL
1948 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1950 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1951 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1954 cl
= current_ts
.u
.cl
;
1956 cl_deferred
= current_ts
.deferred
;
1965 /* The dummy arguments and result of the abreviated form of MODULE
1966 PROCEDUREs, used in SUBMODULES should not be redefined. */
1967 if (gfc_current_ns
->proc_name
1968 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
1970 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1971 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
1974 gfc_error ("'%s' at %C is a redefinition of the declaration "
1975 "in the corresponding interface for MODULE "
1976 "PROCEDURE '%s'", sym
->name
,
1977 gfc_current_ns
->proc_name
->name
);
1982 /* If this symbol has already shown up in a Cray Pointer declaration,
1983 and this is not a component declaration,
1984 then we want to set the type & bail out. */
1985 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
1987 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1988 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1990 sym
->ts
.type
= current_ts
.type
;
1991 sym
->ts
.kind
= current_ts
.kind
;
1993 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1994 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1995 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1998 /* Check to see if we have an array specification. */
2001 if (sym
->as
!= NULL
)
2003 gfc_error ("Duplicate array spec for Cray pointee at %C");
2004 gfc_free_array_spec (cp_as
);
2010 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2011 gfc_internal_error ("Couldn't set pointee array spec.");
2013 /* Fix the array spec. */
2014 m
= gfc_mod_pointee_as (sym
->as
);
2015 if (m
== MATCH_ERROR
)
2023 gfc_free_array_spec (cp_as
);
2027 /* Procedure pointer as function result. */
2028 if (gfc_current_state () == COMP_FUNCTION
2029 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2030 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2031 strcpy (name
, "ppr@");
2033 if (gfc_current_state () == COMP_FUNCTION
2034 && strcmp (name
, gfc_current_block ()->name
) == 0
2035 && gfc_current_block ()->result
2036 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2037 strcpy (name
, "ppr@");
2039 /* OK, we've successfully matched the declaration. Now put the
2040 symbol in the current namespace, because it might be used in the
2041 optional initialization expression for this symbol, e.g. this is
2044 integer, parameter :: i = huge(i)
2046 This is only true for parameters or variables of a basic type.
2047 For components of derived types, it is not true, so we don't
2048 create a symbol for those yet. If we fail to create the symbol,
2050 if (gfc_current_state () != COMP_DERIVED
2051 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2057 if (!check_function_name (name
))
2063 /* We allow old-style initializations of the form
2064 integer i /2/, j(4) /3*3, 1/
2065 (if no colon has been seen). These are different from data
2066 statements in that initializers are only allowed to apply to the
2067 variable immediately preceding, i.e.
2069 is not allowed. Therefore we have to do some work manually, that
2070 could otherwise be left to the matchers for DATA statements. */
2072 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2074 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2075 "initialization at %C"))
2077 else if (gfc_current_state () == COMP_DERIVED
)
2079 gfc_error ("Invalid old style initialization for derived type "
2085 return match_old_style_init (name
);
2088 /* The double colon must be present in order to have initializers.
2089 Otherwise the statement is ambiguous with an assignment statement. */
2092 if (gfc_match (" =>") == MATCH_YES
)
2094 if (!current_attr
.pointer
)
2096 gfc_error ("Initialization at %C isn't for a pointer variable");
2101 m
= match_pointer_init (&initializer
, 0);
2105 else if (gfc_match_char ('=') == MATCH_YES
)
2107 if (current_attr
.pointer
)
2109 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2115 m
= gfc_match_init_expr (&initializer
);
2118 gfc_error ("Expected an initialization expression at %C");
2122 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2123 && gfc_state_stack
->state
!= COMP_DERIVED
)
2125 gfc_error ("Initialization of variable at %C is not allowed in "
2126 "a PURE procedure");
2130 if (current_attr
.flavor
!= FL_PARAMETER
2131 && gfc_state_stack
->state
!= COMP_DERIVED
)
2132 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2139 if (initializer
!= NULL
&& current_attr
.allocatable
2140 && gfc_current_state () == COMP_DERIVED
)
2142 gfc_error ("Initialization of allocatable component at %C is not "
2148 /* Add the initializer. Note that it is fine if initializer is
2149 NULL here, because we sometimes also need to check if a
2150 declaration *must* have an initialization expression. */
2151 if (gfc_current_state () != COMP_DERIVED
)
2152 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2155 if (current_ts
.type
== BT_DERIVED
2156 && !current_attr
.pointer
&& !initializer
)
2157 initializer
= gfc_default_initializer (¤t_ts
);
2158 t
= build_struct (name
, cl
, &initializer
, &as
);
2161 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2164 /* Free stuff up and return. */
2165 gfc_free_expr (initializer
);
2166 gfc_free_array_spec (as
);
2172 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2173 This assumes that the byte size is equal to the kind number for
2174 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2177 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2182 if (gfc_match_char ('*') != MATCH_YES
)
2185 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2189 original_kind
= ts
->kind
;
2191 /* Massage the kind numbers for complex types. */
2192 if (ts
->type
== BT_COMPLEX
)
2196 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2197 gfc_basic_typename (ts
->type
), original_kind
);
2204 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2207 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2211 if (flag_real4_kind
== 8)
2213 if (flag_real4_kind
== 10)
2215 if (flag_real4_kind
== 16)
2221 if (flag_real8_kind
== 4)
2223 if (flag_real8_kind
== 10)
2225 if (flag_real8_kind
== 16)
2230 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2232 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2233 gfc_basic_typename (ts
->type
), original_kind
);
2237 if (!gfc_notify_std (GFC_STD_GNU
,
2238 "Nonstandard type declaration %s*%d at %C",
2239 gfc_basic_typename(ts
->type
), original_kind
))
2246 /* Match a kind specification. Since kinds are generally optional, we
2247 usually return MATCH_NO if something goes wrong. If a "kind="
2248 string is found, then we know we have an error. */
2251 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2263 where
= loc
= gfc_current_locus
;
2268 if (gfc_match_char ('(') == MATCH_NO
)
2271 /* Also gobbles optional text. */
2272 if (gfc_match (" kind = ") == MATCH_YES
)
2275 loc
= gfc_current_locus
;
2278 n
= gfc_match_init_expr (&e
);
2282 if (gfc_matching_function
)
2284 /* The function kind expression might include use associated or
2285 imported parameters and try again after the specification
2287 if (gfc_match_char (')') != MATCH_YES
)
2289 gfc_error ("Missing right parenthesis at %C");
2295 gfc_undo_symbols ();
2300 /* ....or else, the match is real. */
2302 gfc_error ("Expected initialization expression at %C");
2310 gfc_error ("Expected scalar initialization expression at %C");
2315 msg
= gfc_extract_int (e
, &ts
->kind
);
2324 /* Before throwing away the expression, let's see if we had a
2325 C interoperable kind (and store the fact). */
2326 if (e
->ts
.is_c_interop
== 1)
2328 /* Mark this as C interoperable if being declared with one
2329 of the named constants from iso_c_binding. */
2330 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2331 ts
->f90_type
= e
->ts
.f90_type
;
2337 /* Ignore errors to this point, if we've gotten here. This means
2338 we ignore the m=MATCH_ERROR from above. */
2339 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2341 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2342 gfc_basic_typename (ts
->type
));
2343 gfc_current_locus
= where
;
2347 /* Warn if, e.g., c_int is used for a REAL variable, but not
2348 if, e.g., c_double is used for COMPLEX as the standard
2349 explicitly says that the kind type parameter for complex and real
2350 variable is the same, i.e. c_float == c_float_complex. */
2351 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2352 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2353 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2354 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2355 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2356 gfc_basic_typename (ts
->type
));
2358 gfc_gobble_whitespace ();
2359 if ((c
= gfc_next_ascii_char ()) != ')'
2360 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2362 if (ts
->type
== BT_CHARACTER
)
2363 gfc_error ("Missing right parenthesis or comma at %C");
2365 gfc_error ("Missing right parenthesis at %C");
2369 /* All tests passed. */
2372 if(m
== MATCH_ERROR
)
2373 gfc_current_locus
= where
;
2375 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2378 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2382 if (flag_real4_kind
== 8)
2384 if (flag_real4_kind
== 10)
2386 if (flag_real4_kind
== 16)
2392 if (flag_real8_kind
== 4)
2394 if (flag_real8_kind
== 10)
2396 if (flag_real8_kind
== 16)
2401 /* Return what we know from the test(s). */
2406 gfc_current_locus
= where
;
2412 match_char_kind (int * kind
, int * is_iso_c
)
2421 where
= gfc_current_locus
;
2423 n
= gfc_match_init_expr (&e
);
2425 if (n
!= MATCH_YES
&& gfc_matching_function
)
2427 /* The expression might include use-associated or imported
2428 parameters and try again after the specification
2431 gfc_undo_symbols ();
2436 gfc_error ("Expected initialization expression at %C");
2442 gfc_error ("Expected scalar initialization expression at %C");
2447 msg
= gfc_extract_int (e
, kind
);
2448 *is_iso_c
= e
->ts
.is_iso_c
;
2458 /* Ignore errors to this point, if we've gotten here. This means
2459 we ignore the m=MATCH_ERROR from above. */
2460 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2462 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2466 /* All tests passed. */
2469 if (m
== MATCH_ERROR
)
2470 gfc_current_locus
= where
;
2472 /* Return what we know from the test(s). */
2477 gfc_current_locus
= where
;
2482 /* Match the various kind/length specifications in a CHARACTER
2483 declaration. We don't return MATCH_NO. */
2486 gfc_match_char_spec (gfc_typespec
*ts
)
2488 int kind
, seen_length
, is_iso_c
;
2500 /* Try the old-style specification first. */
2501 old_char_selector
= 0;
2503 m
= match_char_length (&len
, &deferred
, true);
2507 old_char_selector
= 1;
2512 m
= gfc_match_char ('(');
2515 m
= MATCH_YES
; /* Character without length is a single char. */
2519 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2520 if (gfc_match (" kind =") == MATCH_YES
)
2522 m
= match_char_kind (&kind
, &is_iso_c
);
2524 if (m
== MATCH_ERROR
)
2529 if (gfc_match (" , len =") == MATCH_NO
)
2532 m
= char_len_param_value (&len
, &deferred
);
2535 if (m
== MATCH_ERROR
)
2542 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2543 if (gfc_match (" len =") == MATCH_YES
)
2545 m
= char_len_param_value (&len
, &deferred
);
2548 if (m
== MATCH_ERROR
)
2552 if (gfc_match_char (')') == MATCH_YES
)
2555 if (gfc_match (" , kind =") != MATCH_YES
)
2558 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2564 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2565 m
= char_len_param_value (&len
, &deferred
);
2568 if (m
== MATCH_ERROR
)
2572 m
= gfc_match_char (')');
2576 if (gfc_match_char (',') != MATCH_YES
)
2579 gfc_match (" kind ="); /* Gobble optional text. */
2581 m
= match_char_kind (&kind
, &is_iso_c
);
2582 if (m
== MATCH_ERROR
)
2588 /* Require a right-paren at this point. */
2589 m
= gfc_match_char (')');
2594 gfc_error ("Syntax error in CHARACTER declaration at %C");
2596 gfc_free_expr (len
);
2600 /* Deal with character functions after USE and IMPORT statements. */
2601 if (gfc_matching_function
)
2603 gfc_free_expr (len
);
2604 gfc_undo_symbols ();
2610 gfc_free_expr (len
);
2614 /* Do some final massaging of the length values. */
2615 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2617 if (seen_length
== 0)
2618 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2623 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2624 ts
->deferred
= deferred
;
2626 /* We have to know if it was a C interoperable kind so we can
2627 do accurate type checking of bind(c) procs, etc. */
2629 /* Mark this as C interoperable if being declared with one
2630 of the named constants from iso_c_binding. */
2631 ts
->is_c_interop
= is_iso_c
;
2632 else if (len
!= NULL
)
2633 /* Here, we might have parsed something such as: character(c_char)
2634 In this case, the parsing code above grabs the c_char when
2635 looking for the length (line 1690, roughly). it's the last
2636 testcase for parsing the kind params of a character variable.
2637 However, it's not actually the length. this seems like it
2639 To see if the user used a C interop kind, test the expr
2640 of the so called length, and see if it's C interoperable. */
2641 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2647 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2648 structure to the matched specification. This is necessary for FUNCTION and
2649 IMPLICIT statements.
2651 If implicit_flag is nonzero, then we don't check for the optional
2652 kind specification. Not doing so is needed for matching an IMPLICIT
2653 statement correctly. */
2656 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2658 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2659 gfc_symbol
*sym
, *dt_sym
;
2662 bool seen_deferred_kind
, matched_type
;
2663 const char *dt_name
;
2665 /* A belt and braces check that the typespec is correctly being treated
2666 as a deferred characteristic association. */
2667 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2668 && (gfc_current_block ()->result
->ts
.kind
== -1)
2669 && (ts
->kind
== -1);
2671 if (seen_deferred_kind
)
2674 /* Clear the current binding label, in case one is given. */
2675 curr_binding_label
= NULL
;
2677 if (gfc_match (" byte") == MATCH_YES
)
2679 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2682 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2684 gfc_error ("BYTE type used at %C "
2685 "is not available on the target machine");
2689 ts
->type
= BT_INTEGER
;
2695 m
= gfc_match (" type (");
2696 matched_type
= (m
== MATCH_YES
);
2699 gfc_gobble_whitespace ();
2700 if (gfc_peek_ascii_char () == '*')
2702 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2704 if (gfc_current_state () == COMP_DERIVED
)
2706 gfc_error ("Assumed type at %C is not allowed for components");
2709 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2712 ts
->type
= BT_ASSUMED
;
2716 m
= gfc_match ("%n", name
);
2717 matched_type
= (m
== MATCH_YES
);
2720 if ((matched_type
&& strcmp ("integer", name
) == 0)
2721 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2723 ts
->type
= BT_INTEGER
;
2724 ts
->kind
= gfc_default_integer_kind
;
2728 if ((matched_type
&& strcmp ("character", name
) == 0)
2729 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2732 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2733 "intrinsic-type-spec at %C"))
2736 ts
->type
= BT_CHARACTER
;
2737 if (implicit_flag
== 0)
2738 m
= gfc_match_char_spec (ts
);
2742 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2748 if ((matched_type
&& strcmp ("real", name
) == 0)
2749 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2752 ts
->kind
= gfc_default_real_kind
;
2757 && (strcmp ("doubleprecision", name
) == 0
2758 || (strcmp ("double", name
) == 0
2759 && gfc_match (" precision") == MATCH_YES
)))
2760 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2763 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2764 "intrinsic-type-spec at %C"))
2766 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2770 ts
->kind
= gfc_default_double_kind
;
2774 if ((matched_type
&& strcmp ("complex", name
) == 0)
2775 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2777 ts
->type
= BT_COMPLEX
;
2778 ts
->kind
= gfc_default_complex_kind
;
2783 && (strcmp ("doublecomplex", name
) == 0
2784 || (strcmp ("double", name
) == 0
2785 && gfc_match (" complex") == MATCH_YES
)))
2786 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2788 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2792 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2793 "intrinsic-type-spec at %C"))
2796 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2799 ts
->type
= BT_COMPLEX
;
2800 ts
->kind
= gfc_default_double_kind
;
2804 if ((matched_type
&& strcmp ("logical", name
) == 0)
2805 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2807 ts
->type
= BT_LOGICAL
;
2808 ts
->kind
= gfc_default_logical_kind
;
2813 m
= gfc_match_char (')');
2816 ts
->type
= BT_DERIVED
;
2819 /* Match CLASS declarations. */
2820 m
= gfc_match (" class ( * )");
2821 if (m
== MATCH_ERROR
)
2823 else if (m
== MATCH_YES
)
2827 ts
->type
= BT_CLASS
;
2828 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2831 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2832 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2834 gfc_set_sym_referenced (upe
);
2836 upe
->ts
.type
= BT_VOID
;
2837 upe
->attr
.unlimited_polymorphic
= 1;
2838 /* This is essential to force the construction of
2839 unlimited polymorphic component class containers. */
2840 upe
->attr
.zero_comp
= 1;
2841 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2842 &gfc_current_locus
))
2847 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2849 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2853 ts
->u
.derived
= upe
;
2857 m
= gfc_match (" class ( %n )", name
);
2860 ts
->type
= BT_CLASS
;
2862 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2866 /* Defer association of the derived type until the end of the
2867 specification block. However, if the derived type can be
2868 found, add it to the typespec. */
2869 if (gfc_matching_function
)
2871 ts
->u
.derived
= NULL
;
2872 if (gfc_current_state () != COMP_INTERFACE
2873 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2875 sym
= gfc_find_dt_in_generic (sym
);
2876 ts
->u
.derived
= sym
;
2881 /* Search for the name but allow the components to be defined later. If
2882 type = -1, this typespec has been seen in a function declaration but
2883 the type could not be accessed at that point. The actual derived type is
2884 stored in a symtree with the first letter of the name capitalized; the
2885 symtree with the all lower-case name contains the associated
2886 generic function. */
2887 dt_name
= gfc_get_string ("%c%s",
2888 (char) TOUPPER ((unsigned char) name
[0]),
2889 (const char*)&name
[1]);
2894 gfc_get_ha_symbol (name
, &sym
);
2895 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2897 gfc_error ("Type name %qs at %C is ambiguous", name
);
2900 if (sym
->generic
&& !dt_sym
)
2901 dt_sym
= gfc_find_dt_in_generic (sym
);
2903 else if (ts
->kind
== -1)
2905 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2906 || gfc_current_ns
->has_import_set
;
2907 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2908 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2910 gfc_error ("Type name %qs at %C is ambiguous", name
);
2913 if (sym
&& sym
->generic
&& !dt_sym
)
2914 dt_sym
= gfc_find_dt_in_generic (sym
);
2921 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2922 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2923 || sym
->attr
.subroutine
)
2925 gfc_error ("Type name %qs at %C conflicts with previously declared "
2926 "entity at %L, which has the same name", name
,
2931 gfc_save_symbol_data (sym
);
2932 gfc_set_sym_referenced (sym
);
2933 if (!sym
->attr
.generic
2934 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2937 if (!sym
->attr
.function
2938 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2943 gfc_interface
*intr
, *head
;
2945 /* Use upper case to save the actual derived-type symbol. */
2946 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2947 dt_sym
->name
= gfc_get_string (sym
->name
);
2948 head
= sym
->generic
;
2949 intr
= gfc_get_interface ();
2951 intr
->where
= gfc_current_locus
;
2953 sym
->generic
= intr
;
2954 sym
->attr
.if_source
= IFSRC_DECL
;
2957 gfc_save_symbol_data (dt_sym
);
2959 gfc_set_sym_referenced (dt_sym
);
2961 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2962 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2965 ts
->u
.derived
= dt_sym
;
2971 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2972 "intrinsic-type-spec at %C"))
2975 /* For all types except double, derived and character, look for an
2976 optional kind specifier. MATCH_NO is actually OK at this point. */
2977 if (implicit_flag
== 1)
2979 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2985 if (gfc_current_form
== FORM_FREE
)
2987 c
= gfc_peek_ascii_char ();
2988 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2989 && c
!= ':' && c
!= ',')
2991 if (matched_type
&& c
== ')')
2993 gfc_next_ascii_char ();
3000 m
= gfc_match_kind_spec (ts
, false);
3001 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3002 m
= gfc_match_old_kind_spec (ts
);
3004 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3007 /* Defer association of the KIND expression of function results
3008 until after USE and IMPORT statements. */
3009 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3010 || gfc_matching_function
)
3014 m
= MATCH_YES
; /* No kind specifier found. */
3020 /* Match an IMPLICIT NONE statement. Actually, this statement is
3021 already matched in parse.c, or we would not end up here in the
3022 first place. So the only thing we need to check, is if there is
3023 trailing garbage. If not, the match is successful. */
3026 gfc_match_implicit_none (void)
3030 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3032 bool external
= false;
3033 locus cur_loc
= gfc_current_locus
;
3035 if (gfc_current_ns
->seen_implicit_none
3036 || gfc_current_ns
->has_implicit_none_export
)
3038 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3042 gfc_gobble_whitespace ();
3043 c
= gfc_peek_ascii_char ();
3046 (void) gfc_next_ascii_char ();
3047 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3050 gfc_gobble_whitespace ();
3051 if (gfc_peek_ascii_char () == ')')
3053 (void) gfc_next_ascii_char ();
3059 m
= gfc_match (" %n", name
);
3063 if (strcmp (name
, "type") == 0)
3065 else if (strcmp (name
, "external") == 0)
3070 gfc_gobble_whitespace ();
3071 c
= gfc_next_ascii_char ();
3082 if (gfc_match_eos () != MATCH_YES
)
3085 gfc_set_implicit_none (type
, external
, &cur_loc
);
3091 /* Match the letter range(s) of an IMPLICIT statement. */
3094 match_implicit_range (void)
3100 cur_loc
= gfc_current_locus
;
3102 gfc_gobble_whitespace ();
3103 c
= gfc_next_ascii_char ();
3106 gfc_error ("Missing character range in IMPLICIT at %C");
3113 gfc_gobble_whitespace ();
3114 c1
= gfc_next_ascii_char ();
3118 gfc_gobble_whitespace ();
3119 c
= gfc_next_ascii_char ();
3124 inner
= 0; /* Fall through. */
3131 gfc_gobble_whitespace ();
3132 c2
= gfc_next_ascii_char ();
3136 gfc_gobble_whitespace ();
3137 c
= gfc_next_ascii_char ();
3139 if ((c
!= ',') && (c
!= ')'))
3152 gfc_error ("Letters must be in alphabetic order in "
3153 "IMPLICIT statement at %C");
3157 /* See if we can add the newly matched range to the pending
3158 implicits from this IMPLICIT statement. We do not check for
3159 conflicts with whatever earlier IMPLICIT statements may have
3160 set. This is done when we've successfully finished matching
3162 if (!gfc_add_new_implicit_range (c1
, c2
))
3169 gfc_syntax_error (ST_IMPLICIT
);
3171 gfc_current_locus
= cur_loc
;
3176 /* Match an IMPLICIT statement, storing the types for
3177 gfc_set_implicit() if the statement is accepted by the parser.
3178 There is a strange looking, but legal syntactic construction
3179 possible. It looks like:
3181 IMPLICIT INTEGER (a-b) (c-d)
3183 This is legal if "a-b" is a constant expression that happens to
3184 equal one of the legal kinds for integers. The real problem
3185 happens with an implicit specification that looks like:
3187 IMPLICIT INTEGER (a-b)
3189 In this case, a typespec matcher that is "greedy" (as most of the
3190 matchers are) gobbles the character range as a kindspec, leaving
3191 nothing left. We therefore have to go a bit more slowly in the
3192 matching process by inhibiting the kindspec checking during
3193 typespec matching and checking for a kind later. */
3196 gfc_match_implicit (void)
3203 if (gfc_current_ns
->seen_implicit_none
)
3205 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3212 /* We don't allow empty implicit statements. */
3213 if (gfc_match_eos () == MATCH_YES
)
3215 gfc_error ("Empty IMPLICIT statement at %C");
3221 /* First cleanup. */
3222 gfc_clear_new_implicit ();
3224 /* A basic type is mandatory here. */
3225 m
= gfc_match_decl_type_spec (&ts
, 1);
3226 if (m
== MATCH_ERROR
)
3231 cur_loc
= gfc_current_locus
;
3232 m
= match_implicit_range ();
3236 /* We may have <TYPE> (<RANGE>). */
3237 gfc_gobble_whitespace ();
3238 c
= gfc_peek_ascii_char ();
3239 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3241 /* Check for CHARACTER with no length parameter. */
3242 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3244 ts
.kind
= gfc_default_character_kind
;
3245 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3246 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3250 /* Record the Successful match. */
3251 if (!gfc_merge_new_implicit (&ts
))
3254 c
= gfc_next_ascii_char ();
3255 else if (gfc_match_eos () == MATCH_ERROR
)
3260 gfc_current_locus
= cur_loc
;
3263 /* Discard the (incorrectly) matched range. */
3264 gfc_clear_new_implicit ();
3266 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3267 if (ts
.type
== BT_CHARACTER
)
3268 m
= gfc_match_char_spec (&ts
);
3271 m
= gfc_match_kind_spec (&ts
, false);
3274 m
= gfc_match_old_kind_spec (&ts
);
3275 if (m
== MATCH_ERROR
)
3281 if (m
== MATCH_ERROR
)
3284 m
= match_implicit_range ();
3285 if (m
== MATCH_ERROR
)
3290 gfc_gobble_whitespace ();
3291 c
= gfc_next_ascii_char ();
3292 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3295 if (!gfc_merge_new_implicit (&ts
))
3303 gfc_syntax_error (ST_IMPLICIT
);
3311 gfc_match_import (void)
3313 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3318 if (gfc_current_ns
->proc_name
== NULL
3319 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3321 gfc_error ("IMPORT statement at %C only permitted in "
3322 "an INTERFACE body");
3326 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3328 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3329 "in a module procedure interface body");
3333 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3336 if (gfc_match_eos () == MATCH_YES
)
3338 /* All host variables should be imported. */
3339 gfc_current_ns
->has_import_set
= 1;
3343 if (gfc_match (" ::") == MATCH_YES
)
3345 if (gfc_match_eos () == MATCH_YES
)
3347 gfc_error ("Expecting list of named entities at %C");
3355 m
= gfc_match (" %n", name
);
3359 if (gfc_current_ns
->parent
!= NULL
3360 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3362 gfc_error ("Type name %qs at %C is ambiguous", name
);
3365 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3366 && gfc_find_symbol (name
,
3367 gfc_current_ns
->proc_name
->ns
->parent
,
3370 gfc_error ("Type name %qs at %C is ambiguous", name
);
3376 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3377 "at %C - does not exist.", name
);
3381 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3383 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3388 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3391 sym
->attr
.imported
= 1;
3393 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3395 /* The actual derived type is stored in a symtree with the first
3396 letter of the name capitalized; the symtree with the all
3397 lower-case name contains the associated generic function. */
3398 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3399 gfc_get_string ("%c%s",
3400 (char) TOUPPER ((unsigned char) name
[0]),
3404 sym
->attr
.imported
= 1;
3417 if (gfc_match_eos () == MATCH_YES
)
3419 if (gfc_match_char (',') != MATCH_YES
)
3426 gfc_error ("Syntax error in IMPORT statement at %C");
3431 /* A minimal implementation of gfc_match without whitespace, escape
3432 characters or variable arguments. Returns true if the next
3433 characters match the TARGET template exactly. */
3436 match_string_p (const char *target
)
3440 for (p
= target
; *p
; p
++)
3441 if ((char) gfc_next_ascii_char () != *p
)
3446 /* Matches an attribute specification including array specs. If
3447 successful, leaves the variables current_attr and current_as
3448 holding the specification. Also sets the colon_seen variable for
3449 later use by matchers associated with initializations.
3451 This subroutine is a little tricky in the sense that we don't know
3452 if we really have an attr-spec until we hit the double colon.
3453 Until that time, we can only return MATCH_NO. This forces us to
3454 check for duplicate specification at this level. */
3457 match_attr_spec (void)
3459 /* Modifiers that can exist in a type statement. */
3461 { GFC_DECL_BEGIN
= 0,
3462 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3463 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3464 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3465 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3466 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3467 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3470 /* GFC_DECL_END is the sentinel, index starts at 0. */
3471 #define NUM_DECL GFC_DECL_END
3473 locus start
, seen_at
[NUM_DECL
];
3480 gfc_clear_attr (¤t_attr
);
3481 start
= gfc_current_locus
;
3486 /* See if we get all of the keywords up to the final double colon. */
3487 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3495 gfc_gobble_whitespace ();
3497 ch
= gfc_next_ascii_char ();
3500 /* This is the successful exit condition for the loop. */
3501 if (gfc_next_ascii_char () == ':')
3506 gfc_gobble_whitespace ();
3507 switch (gfc_peek_ascii_char ())
3510 gfc_next_ascii_char ();
3511 switch (gfc_next_ascii_char ())
3514 if (match_string_p ("locatable"))
3516 /* Matched "allocatable". */
3517 d
= DECL_ALLOCATABLE
;
3522 if (match_string_p ("ynchronous"))
3524 /* Matched "asynchronous". */
3525 d
= DECL_ASYNCHRONOUS
;
3532 /* Try and match the bind(c). */
3533 m
= gfc_match_bind_c (NULL
, true);
3536 else if (m
== MATCH_ERROR
)
3541 gfc_next_ascii_char ();
3542 if ('o' != gfc_next_ascii_char ())
3544 switch (gfc_next_ascii_char ())
3547 if (match_string_p ("imension"))
3549 d
= DECL_CODIMENSION
;
3553 if (match_string_p ("tiguous"))
3555 d
= DECL_CONTIGUOUS
;
3562 if (match_string_p ("dimension"))
3567 if (match_string_p ("external"))
3572 if (match_string_p ("int"))
3574 ch
= gfc_next_ascii_char ();
3577 if (match_string_p ("nt"))
3579 /* Matched "intent". */
3580 /* TODO: Call match_intent_spec from here. */
3581 if (gfc_match (" ( in out )") == MATCH_YES
)
3583 else if (gfc_match (" ( in )") == MATCH_YES
)
3585 else if (gfc_match (" ( out )") == MATCH_YES
)
3591 if (match_string_p ("insic"))
3593 /* Matched "intrinsic". */
3601 if (match_string_p ("optional"))
3606 gfc_next_ascii_char ();
3607 switch (gfc_next_ascii_char ())
3610 if (match_string_p ("rameter"))
3612 /* Matched "parameter". */
3618 if (match_string_p ("inter"))
3620 /* Matched "pointer". */
3626 ch
= gfc_next_ascii_char ();
3629 if (match_string_p ("vate"))
3631 /* Matched "private". */
3637 if (match_string_p ("tected"))
3639 /* Matched "protected". */
3646 if (match_string_p ("blic"))
3648 /* Matched "public". */
3656 if (match_string_p ("save"))
3661 if (match_string_p ("target"))
3666 gfc_next_ascii_char ();
3667 ch
= gfc_next_ascii_char ();
3670 if (match_string_p ("lue"))
3672 /* Matched "value". */
3678 if (match_string_p ("latile"))
3680 /* Matched "volatile". */
3688 /* No double colon and no recognizable decl_type, so assume that
3689 we've been looking at something else the whole time. */
3696 /* Check to make sure any parens are paired up correctly. */
3697 if (gfc_match_parens () == MATCH_ERROR
)
3704 seen_at
[d
] = gfc_current_locus
;
3706 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3708 gfc_array_spec
*as
= NULL
;
3710 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3711 d
== DECL_CODIMENSION
);
3713 if (current_as
== NULL
)
3715 else if (m
== MATCH_YES
)
3717 if (!merge_array_spec (as
, current_as
, false))
3724 if (d
== DECL_CODIMENSION
)
3725 gfc_error ("Missing codimension specification at %C");
3727 gfc_error ("Missing dimension specification at %C");
3731 if (m
== MATCH_ERROR
)
3736 /* Since we've seen a double colon, we have to be looking at an
3737 attr-spec. This means that we can now issue errors. */
3738 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3743 case DECL_ALLOCATABLE
:
3744 attr
= "ALLOCATABLE";
3746 case DECL_ASYNCHRONOUS
:
3747 attr
= "ASYNCHRONOUS";
3749 case DECL_CODIMENSION
:
3750 attr
= "CODIMENSION";
3752 case DECL_CONTIGUOUS
:
3753 attr
= "CONTIGUOUS";
3755 case DECL_DIMENSION
:
3762 attr
= "INTENT (IN)";
3765 attr
= "INTENT (OUT)";
3768 attr
= "INTENT (IN OUT)";
3770 case DECL_INTRINSIC
:
3776 case DECL_PARAMETER
:
3782 case DECL_PROTECTED
:
3797 case DECL_IS_BIND_C
:
3807 attr
= NULL
; /* This shouldn't happen. */
3810 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3815 /* Now that we've dealt with duplicate attributes, add the attributes
3816 to the current attribute. */
3817 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3822 if (gfc_current_state () == COMP_DERIVED
3823 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3824 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3825 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3827 if (d
== DECL_ALLOCATABLE
)
3829 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3830 "attribute at %C in a TYPE definition"))
3838 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3845 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3846 && gfc_current_state () != COMP_MODULE
)
3848 if (d
== DECL_PRIVATE
)
3852 if (gfc_current_state () == COMP_DERIVED
3853 && gfc_state_stack
->previous
3854 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3856 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3857 "at %L in a TYPE definition", attr
,
3866 gfc_error ("%s attribute at %L is not allowed outside of the "
3867 "specification part of a module", attr
, &seen_at
[d
]);
3875 case DECL_ALLOCATABLE
:
3876 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3879 case DECL_ASYNCHRONOUS
:
3880 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3883 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3886 case DECL_CODIMENSION
:
3887 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3890 case DECL_CONTIGUOUS
:
3891 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3894 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3897 case DECL_DIMENSION
:
3898 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3902 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3906 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3910 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3914 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3917 case DECL_INTRINSIC
:
3918 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3922 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3925 case DECL_PARAMETER
:
3926 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3930 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3933 case DECL_PROTECTED
:
3934 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3936 gfc_error ("PROTECTED at %C only allowed in specification "
3937 "part of a module");
3942 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3945 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3949 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3954 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3959 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3963 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3966 case DECL_IS_BIND_C
:
3967 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3971 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3974 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3978 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3981 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3985 gfc_internal_error ("match_attr_spec(): Bad attribute");
3995 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3996 if ((gfc_current_state () == COMP_MODULE
3997 || gfc_current_state () == COMP_SUBMODULE
)
3998 && !current_attr
.save
3999 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4000 current_attr
.save
= SAVE_IMPLICIT
;
4006 gfc_current_locus
= start
;
4007 gfc_free_array_spec (current_as
);
4013 /* Set the binding label, dest_label, either with the binding label
4014 stored in the given gfc_typespec, ts, or if none was provided, it
4015 will be the symbol name in all lower case, as required by the draft
4016 (J3/04-007, section 15.4.1). If a binding label was given and
4017 there is more than one argument (num_idents), it is an error. */
4020 set_binding_label (const char **dest_label
, const char *sym_name
,
4023 if (num_idents
> 1 && has_name_equals
)
4025 gfc_error ("Multiple identifiers provided with "
4026 "single NAME= specifier at %C");
4030 if (curr_binding_label
)
4031 /* Binding label given; store in temp holder till have sym. */
4032 *dest_label
= curr_binding_label
;
4035 /* No binding label given, and the NAME= specifier did not exist,
4036 which means there was no NAME="". */
4037 if (sym_name
!= NULL
&& has_name_equals
== 0)
4038 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4045 /* Set the status of the given common block as being BIND(C) or not,
4046 depending on the given parameter, is_bind_c. */
4049 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4051 com_block
->is_bind_c
= is_bind_c
;
4056 /* Verify that the given gfc_typespec is for a C interoperable type. */
4059 gfc_verify_c_interop (gfc_typespec
*ts
)
4061 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4062 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4064 else if (ts
->type
== BT_CLASS
)
4066 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4073 /* Verify that the variables of a given common block, which has been
4074 defined with the attribute specifier bind(c), to be of a C
4075 interoperable type. Errors will be reported here, if
4079 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4081 gfc_symbol
*curr_sym
= NULL
;
4084 curr_sym
= com_block
->head
;
4086 /* Make sure we have at least one symbol. */
4087 if (curr_sym
== NULL
)
4090 /* Here we know we have a symbol, so we'll execute this loop
4094 /* The second to last param, 1, says this is in a common block. */
4095 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4096 curr_sym
= curr_sym
->common_next
;
4097 } while (curr_sym
!= NULL
);
4103 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4104 an appropriate error message is reported. */
4107 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4108 int is_in_common
, gfc_common_head
*com_block
)
4110 bool bind_c_function
= false;
4113 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4114 bind_c_function
= true;
4116 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4118 tmp_sym
= tmp_sym
->result
;
4119 /* Make sure it wasn't an implicitly typed result. */
4120 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4122 gfc_warning (OPT_Wc_binding_type
,
4123 "Implicitly declared BIND(C) function %qs at "
4124 "%L may not be C interoperable", tmp_sym
->name
,
4125 &tmp_sym
->declared_at
);
4126 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4127 /* Mark it as C interoperable to prevent duplicate warnings. */
4128 tmp_sym
->ts
.is_c_interop
= 1;
4129 tmp_sym
->attr
.is_c_interop
= 1;
4133 /* Here, we know we have the bind(c) attribute, so if we have
4134 enough type info, then verify that it's a C interop kind.
4135 The info could be in the symbol already, or possibly still in
4136 the given ts (current_ts), so look in both. */
4137 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4139 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4141 /* See if we're dealing with a sym in a common block or not. */
4142 if (is_in_common
== 1 && warn_c_binding_type
)
4144 gfc_warning (OPT_Wc_binding_type
,
4145 "Variable %qs in common block %qs at %L "
4146 "may not be a C interoperable "
4147 "kind though common block %qs is BIND(C)",
4148 tmp_sym
->name
, com_block
->name
,
4149 &(tmp_sym
->declared_at
), com_block
->name
);
4153 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4154 gfc_error ("Type declaration %qs at %L is not C "
4155 "interoperable but it is BIND(C)",
4156 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4157 else if (warn_c_binding_type
)
4158 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4159 "may not be a C interoperable "
4160 "kind but it is BIND(C)",
4161 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4165 /* Variables declared w/in a common block can't be bind(c)
4166 since there's no way for C to see these variables, so there's
4167 semantically no reason for the attribute. */
4168 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4170 gfc_error ("Variable %qs in common block %qs at "
4171 "%L cannot be declared with BIND(C) "
4172 "since it is not a global",
4173 tmp_sym
->name
, com_block
->name
,
4174 &(tmp_sym
->declared_at
));
4178 /* Scalar variables that are bind(c) can not have the pointer
4179 or allocatable attributes. */
4180 if (tmp_sym
->attr
.is_bind_c
== 1)
4182 if (tmp_sym
->attr
.pointer
== 1)
4184 gfc_error ("Variable %qs at %L cannot have both the "
4185 "POINTER and BIND(C) attributes",
4186 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4190 if (tmp_sym
->attr
.allocatable
== 1)
4192 gfc_error ("Variable %qs at %L cannot have both the "
4193 "ALLOCATABLE and BIND(C) attributes",
4194 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4200 /* If it is a BIND(C) function, make sure the return value is a
4201 scalar value. The previous tests in this function made sure
4202 the type is interoperable. */
4203 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4204 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4205 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4207 /* BIND(C) functions can not return a character string. */
4208 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4209 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4210 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4211 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4212 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4213 "be a character string", tmp_sym
->name
,
4214 &(tmp_sym
->declared_at
));
4217 /* See if the symbol has been marked as private. If it has, make sure
4218 there is no binding label and warn the user if there is one. */
4219 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4220 && tmp_sym
->binding_label
)
4221 /* Use gfc_warning_now because we won't say that the symbol fails
4222 just because of this. */
4223 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4224 "given the binding label %qs", tmp_sym
->name
,
4225 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4231 /* Set the appropriate fields for a symbol that's been declared as
4232 BIND(C) (the is_bind_c flag and the binding label), and verify that
4233 the type is C interoperable. Errors are reported by the functions
4234 used to set/test these fields. */
4237 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4241 /* TODO: Do we need to make sure the vars aren't marked private? */
4243 /* Set the is_bind_c bit in symbol_attribute. */
4244 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4246 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4253 /* Set the fields marking the given common block as BIND(C), including
4254 a binding label, and report any errors encountered. */
4257 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4261 /* destLabel, common name, typespec (which may have binding label). */
4262 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4266 /* Set the given common block (com_block) to being bind(c) (1). */
4267 set_com_block_bind_c (com_block
, 1);
4273 /* Retrieve the list of one or more identifiers that the given bind(c)
4274 attribute applies to. */
4277 get_bind_c_idents (void)
4279 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4281 gfc_symbol
*tmp_sym
= NULL
;
4283 gfc_common_head
*com_block
= NULL
;
4285 if (gfc_match_name (name
) == MATCH_YES
)
4287 found_id
= MATCH_YES
;
4288 gfc_get_ha_symbol (name
, &tmp_sym
);
4290 else if (match_common_name (name
) == MATCH_YES
)
4292 found_id
= MATCH_YES
;
4293 com_block
= gfc_get_common (name
, 0);
4297 gfc_error ("Need either entity or common block name for "
4298 "attribute specification statement at %C");
4302 /* Save the current identifier and look for more. */
4305 /* Increment the number of identifiers found for this spec stmt. */
4308 /* Make sure we have a sym or com block, and verify that it can
4309 be bind(c). Set the appropriate field(s) and look for more
4311 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4313 if (tmp_sym
!= NULL
)
4315 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4320 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4324 /* Look to see if we have another identifier. */
4326 if (gfc_match_eos () == MATCH_YES
)
4327 found_id
= MATCH_NO
;
4328 else if (gfc_match_char (',') != MATCH_YES
)
4329 found_id
= MATCH_NO
;
4330 else if (gfc_match_name (name
) == MATCH_YES
)
4332 found_id
= MATCH_YES
;
4333 gfc_get_ha_symbol (name
, &tmp_sym
);
4335 else if (match_common_name (name
) == MATCH_YES
)
4337 found_id
= MATCH_YES
;
4338 com_block
= gfc_get_common (name
, 0);
4342 gfc_error ("Missing entity or common block name for "
4343 "attribute specification statement at %C");
4349 gfc_internal_error ("Missing symbol");
4351 } while (found_id
== MATCH_YES
);
4353 /* if we get here we were successful */
4358 /* Try and match a BIND(C) attribute specification statement. */
4361 gfc_match_bind_c_stmt (void)
4363 match found_match
= MATCH_NO
;
4368 /* This may not be necessary. */
4370 /* Clear the temporary binding label holder. */
4371 curr_binding_label
= NULL
;
4373 /* Look for the bind(c). */
4374 found_match
= gfc_match_bind_c (NULL
, true);
4376 if (found_match
== MATCH_YES
)
4378 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4381 /* Look for the :: now, but it is not required. */
4384 /* Get the identifier(s) that needs to be updated. This may need to
4385 change to hand the flag(s) for the attr specified so all identifiers
4386 found can have all appropriate parts updated (assuming that the same
4387 spec stmt can have multiple attrs, such as both bind(c) and
4389 if (!get_bind_c_idents ())
4390 /* Error message should have printed already. */
4398 /* Match a data declaration statement. */
4401 gfc_match_data_decl (void)
4407 num_idents_on_line
= 0;
4409 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4413 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4414 && gfc_current_state () != COMP_DERIVED
)
4416 sym
= gfc_use_derived (current_ts
.u
.derived
);
4424 current_ts
.u
.derived
= sym
;
4427 m
= match_attr_spec ();
4428 if (m
== MATCH_ERROR
)
4434 if (current_ts
.type
== BT_CLASS
4435 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4438 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4439 && current_ts
.u
.derived
->components
== NULL
4440 && !current_ts
.u
.derived
->attr
.zero_comp
)
4443 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4446 gfc_find_symbol (current_ts
.u
.derived
->name
,
4447 current_ts
.u
.derived
->ns
, 1, &sym
);
4449 /* Any symbol that we find had better be a type definition
4450 which has its components defined. */
4451 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4452 && (current_ts
.u
.derived
->components
!= NULL
4453 || current_ts
.u
.derived
->attr
.zero_comp
))
4456 gfc_error ("Derived type at %C has not been previously defined "
4457 "and so cannot appear in a derived type definition");
4463 /* If we have an old-style character declaration, and no new-style
4464 attribute specifications, then there a comma is optional between
4465 the type specification and the variable list. */
4466 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4467 gfc_match_char (',');
4469 /* Give the types/attributes to symbols that follow. Give the element
4470 a number so that repeat character length expressions can be copied. */
4474 num_idents_on_line
++;
4475 m
= variable_decl (elem
++);
4476 if (m
== MATCH_ERROR
)
4481 if (gfc_match_eos () == MATCH_YES
)
4483 if (gfc_match_char (',') != MATCH_YES
)
4487 if (!gfc_error_flag_test ())
4488 gfc_error ("Syntax error in data declaration at %C");
4491 gfc_free_data_all (gfc_current_ns
);
4494 gfc_free_array_spec (current_as
);
4500 /* Match a prefix associated with a function or subroutine
4501 declaration. If the typespec pointer is nonnull, then a typespec
4502 can be matched. Note that if nothing matches, MATCH_YES is
4503 returned (the null string was matched). */
4506 gfc_match_prefix (gfc_typespec
*ts
)
4512 gfc_clear_attr (¤t_attr
);
4514 seen_impure
= false;
4516 gcc_assert (!gfc_matching_prefix
);
4517 gfc_matching_prefix
= true;
4521 found_prefix
= false;
4523 if (!seen_type
&& ts
!= NULL
4524 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4525 && gfc_match_space () == MATCH_YES
)
4529 found_prefix
= true;
4532 if (gfc_match ("elemental% ") == MATCH_YES
)
4534 if (!gfc_add_elemental (¤t_attr
, NULL
))
4537 found_prefix
= true;
4540 if (gfc_match ("pure% ") == MATCH_YES
)
4542 if (!gfc_add_pure (¤t_attr
, NULL
))
4545 found_prefix
= true;
4548 if (gfc_match ("recursive% ") == MATCH_YES
)
4550 if (!gfc_add_recursive (¤t_attr
, NULL
))
4553 found_prefix
= true;
4556 /* IMPURE is a somewhat special case, as it needs not set an actual
4557 attribute but rather only prevents ELEMENTAL routines from being
4558 automatically PURE. */
4559 if (gfc_match ("impure% ") == MATCH_YES
)
4561 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4565 found_prefix
= true;
4568 while (found_prefix
);
4570 /* IMPURE and PURE must not both appear, of course. */
4571 if (seen_impure
&& current_attr
.pure
)
4573 gfc_error ("PURE and IMPURE must not appear both at %C");
4577 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4578 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4580 if (!gfc_add_pure (¤t_attr
, NULL
))
4584 /* At this point, the next item is not a prefix. */
4585 gcc_assert (gfc_matching_prefix
);
4587 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4588 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4589 corresponding attribute seems natural and distinguishes these
4590 procedures from procedure types of PROC_MODULE, which these are
4592 if ((gfc_current_state () == COMP_INTERFACE
4593 || gfc_current_state () == COMP_CONTAINS
)
4594 && gfc_match ("module% ") == MATCH_YES
)
4596 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4599 current_attr
.module_procedure
= 1;
4602 gfc_matching_prefix
= false;
4606 gcc_assert (gfc_matching_prefix
);
4607 gfc_matching_prefix
= false;
4612 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4615 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4617 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4620 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4623 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4630 /* Match a formal argument list. */
4633 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4635 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4636 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4639 gfc_formal_arglist
*formal
= NULL
;
4643 /* Keep the interface formal argument list and null it so that the
4644 matching for the new declaration can be done. The numbers and
4645 names of the arguments are checked here. The interface formal
4646 arguments are retained in formal_arglist and the characteristics
4647 are compared in resolve.c(resolve_fl_procedure). See the remark
4648 in get_proc_name about the eventual need to copy the formal_arglist
4649 and populate the formal namespace of the interface symbol. */
4650 if (progname
->attr
.module_procedure
4651 && progname
->attr
.host_assoc
)
4653 formal
= progname
->formal
;
4654 progname
->formal
= NULL
;
4657 if (gfc_match_char ('(') != MATCH_YES
)
4664 if (gfc_match_char (')') == MATCH_YES
)
4669 if (gfc_match_char ('*') == MATCH_YES
)
4672 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4681 m
= gfc_match_name (name
);
4685 if (gfc_get_symbol (name
, NULL
, &sym
))
4689 p
= gfc_get_formal_arglist ();
4701 /* We don't add the VARIABLE flavor because the name could be a
4702 dummy procedure. We don't apply these attributes to formal
4703 arguments of statement functions. */
4704 if (sym
!= NULL
&& !st_flag
4705 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4706 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4712 /* The name of a program unit can be in a different namespace,
4713 so check for it explicitly. After the statement is accepted,
4714 the name is checked for especially in gfc_get_symbol(). */
4715 if (gfc_new_block
!= NULL
&& sym
!= NULL
4716 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4718 gfc_error ("Name %qs at %C is the name of the procedure",
4724 if (gfc_match_char (')') == MATCH_YES
)
4727 m
= gfc_match_char (',');
4730 gfc_error ("Unexpected junk in formal argument list at %C");
4736 /* Check for duplicate symbols in the formal argument list. */
4739 for (p
= head
; p
->next
; p
= p
->next
)
4744 for (q
= p
->next
; q
; q
= q
->next
)
4745 if (p
->sym
== q
->sym
)
4747 gfc_error ("Duplicate symbol %qs in formal argument list "
4748 "at %C", p
->sym
->name
);
4756 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4764 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4766 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4767 || (p
->next
== NULL
&& q
->next
!= NULL
))
4768 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4769 "formal arguments at %C");
4770 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4771 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4774 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4775 "argument names (%s/%s) at %C",
4776 p
->sym
->name
, q
->sym
->name
);
4783 gfc_free_formal_arglist (head
);
4788 /* Match a RESULT specification following a function declaration or
4789 ENTRY statement. Also matches the end-of-statement. */
4792 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4794 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4798 if (gfc_match (" result (") != MATCH_YES
)
4801 m
= gfc_match_name (name
);
4805 /* Get the right paren, and that's it because there could be the
4806 bind(c) attribute after the result clause. */
4807 if (gfc_match_char (')') != MATCH_YES
)
4809 /* TODO: should report the missing right paren here. */
4813 if (strcmp (function
->name
, name
) == 0)
4815 gfc_error ("RESULT variable at %C must be different than function name");
4819 if (gfc_get_symbol (name
, NULL
, &r
))
4822 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4831 /* Match a function suffix, which could be a combination of a result
4832 clause and BIND(C), either one, or neither. The draft does not
4833 require them to come in a specific order. */
4836 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4838 match is_bind_c
; /* Found bind(c). */
4839 match is_result
; /* Found result clause. */
4840 match found_match
; /* Status of whether we've found a good match. */
4841 char peek_char
; /* Character we're going to peek at. */
4842 bool allow_binding_name
;
4844 /* Initialize to having found nothing. */
4845 found_match
= MATCH_NO
;
4846 is_bind_c
= MATCH_NO
;
4847 is_result
= MATCH_NO
;
4849 /* Get the next char to narrow between result and bind(c). */
4850 gfc_gobble_whitespace ();
4851 peek_char
= gfc_peek_ascii_char ();
4853 /* C binding names are not allowed for internal procedures. */
4854 if (gfc_current_state () == COMP_CONTAINS
4855 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4856 allow_binding_name
= false;
4858 allow_binding_name
= true;
4863 /* Look for result clause. */
4864 is_result
= match_result (sym
, result
);
4865 if (is_result
== MATCH_YES
)
4867 /* Now see if there is a bind(c) after it. */
4868 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4869 /* We've found the result clause and possibly bind(c). */
4870 found_match
= MATCH_YES
;
4873 /* This should only be MATCH_ERROR. */
4874 found_match
= is_result
;
4877 /* Look for bind(c) first. */
4878 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4879 if (is_bind_c
== MATCH_YES
)
4881 /* Now see if a result clause followed it. */
4882 is_result
= match_result (sym
, result
);
4883 found_match
= MATCH_YES
;
4887 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4888 found_match
= MATCH_ERROR
;
4892 gfc_error ("Unexpected junk after function declaration at %C");
4893 found_match
= MATCH_ERROR
;
4897 if (is_bind_c
== MATCH_YES
)
4899 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4900 if (gfc_current_state () == COMP_CONTAINS
4901 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4902 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4903 "at %L may not be specified for an internal "
4904 "procedure", &gfc_current_locus
))
4907 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4915 /* Procedure pointer return value without RESULT statement:
4916 Add "hidden" result variable named "ppr@". */
4919 add_hidden_procptr_result (gfc_symbol
*sym
)
4923 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4926 /* First usage case: PROCEDURE and EXTERNAL statements. */
4927 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4928 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4929 && sym
->attr
.external
;
4930 /* Second usage case: INTERFACE statements. */
4931 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4932 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4933 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4939 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4943 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4944 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4945 st2
->n
.sym
= stree
->n
.sym
;
4947 sym
->result
= stree
->n
.sym
;
4949 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4950 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4951 sym
->result
->attr
.external
= sym
->attr
.external
;
4952 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4953 sym
->result
->ts
= sym
->ts
;
4954 sym
->attr
.proc_pointer
= 0;
4955 sym
->attr
.pointer
= 0;
4956 sym
->attr
.external
= 0;
4957 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4959 sym
->result
->attr
.pointer
= 0;
4960 sym
->result
->attr
.proc_pointer
= 1;
4963 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4965 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4966 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4967 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4968 && sym
== gfc_current_ns
->proc_name
4969 && sym
== sym
->result
->ns
->proc_name
4970 && strcmp ("ppr@", sym
->result
->name
) == 0)
4972 sym
->result
->attr
.proc_pointer
= 1;
4973 sym
->attr
.pointer
= 0;
4981 /* Match the interface for a PROCEDURE declaration,
4982 including brackets (R1212). */
4985 match_procedure_interface (gfc_symbol
**proc_if
)
4989 locus old_loc
, entry_loc
;
4990 gfc_namespace
*old_ns
= gfc_current_ns
;
4991 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4993 old_loc
= entry_loc
= gfc_current_locus
;
4994 gfc_clear_ts (¤t_ts
);
4996 if (gfc_match (" (") != MATCH_YES
)
4998 gfc_current_locus
= entry_loc
;
5002 /* Get the type spec. for the procedure interface. */
5003 old_loc
= gfc_current_locus
;
5004 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5005 gfc_gobble_whitespace ();
5006 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5009 if (m
== MATCH_ERROR
)
5012 /* Procedure interface is itself a procedure. */
5013 gfc_current_locus
= old_loc
;
5014 m
= gfc_match_name (name
);
5016 /* First look to see if it is already accessible in the current
5017 namespace because it is use associated or contained. */
5019 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5022 /* If it is still not found, then try the parent namespace, if it
5023 exists and create the symbol there if it is still not found. */
5024 if (gfc_current_ns
->parent
)
5025 gfc_current_ns
= gfc_current_ns
->parent
;
5026 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5029 gfc_current_ns
= old_ns
;
5030 *proc_if
= st
->n
.sym
;
5035 /* Resolve interface if possible. That way, attr.procedure is only set
5036 if it is declared by a later procedure-declaration-stmt, which is
5037 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5038 while ((*proc_if
)->ts
.interface
)
5039 *proc_if
= (*proc_if
)->ts
.interface
;
5041 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5042 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5043 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5044 (*proc_if
)->name
, NULL
))
5049 if (gfc_match (" )") != MATCH_YES
)
5051 gfc_current_locus
= entry_loc
;
5059 /* Match a PROCEDURE declaration (R1211). */
5062 match_procedure_decl (void)
5065 gfc_symbol
*sym
, *proc_if
= NULL
;
5067 gfc_expr
*initializer
= NULL
;
5069 /* Parse interface (with brackets). */
5070 m
= match_procedure_interface (&proc_if
);
5074 /* Parse attributes (with colons). */
5075 m
= match_attr_spec();
5076 if (m
== MATCH_ERROR
)
5079 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5081 current_attr
.is_bind_c
= 1;
5082 has_name_equals
= 0;
5083 curr_binding_label
= NULL
;
5086 /* Get procedure symbols. */
5089 m
= gfc_match_symbol (&sym
, 0);
5092 else if (m
== MATCH_ERROR
)
5095 /* Add current_attr to the symbol attributes. */
5096 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5099 if (sym
->attr
.is_bind_c
)
5101 /* Check for C1218. */
5102 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5104 gfc_error ("BIND(C) attribute at %C requires "
5105 "an interface with BIND(C)");
5108 /* Check for C1217. */
5109 if (has_name_equals
&& sym
->attr
.pointer
)
5111 gfc_error ("BIND(C) procedure with NAME may not have "
5112 "POINTER attribute at %C");
5115 if (has_name_equals
&& sym
->attr
.dummy
)
5117 gfc_error ("Dummy procedure at %C may not have "
5118 "BIND(C) attribute with NAME");
5121 /* Set binding label for BIND(C). */
5122 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5126 if (!gfc_add_external (&sym
->attr
, NULL
))
5129 if (add_hidden_procptr_result (sym
))
5132 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5135 /* Set interface. */
5136 if (proc_if
!= NULL
)
5138 if (sym
->ts
.type
!= BT_UNKNOWN
)
5140 gfc_error ("Procedure %qs at %L already has basic type of %s",
5141 sym
->name
, &gfc_current_locus
,
5142 gfc_basic_typename (sym
->ts
.type
));
5145 sym
->ts
.interface
= proc_if
;
5146 sym
->attr
.untyped
= 1;
5147 sym
->attr
.if_source
= IFSRC_IFBODY
;
5149 else if (current_ts
.type
!= BT_UNKNOWN
)
5151 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5153 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5154 sym
->ts
.interface
->ts
= current_ts
;
5155 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5156 sym
->ts
.interface
->attr
.function
= 1;
5157 sym
->attr
.function
= 1;
5158 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5161 if (gfc_match (" =>") == MATCH_YES
)
5163 if (!current_attr
.pointer
)
5165 gfc_error ("Initialization at %C isn't for a pointer variable");
5170 m
= match_pointer_init (&initializer
, 1);
5174 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5179 if (gfc_match_eos () == MATCH_YES
)
5181 if (gfc_match_char (',') != MATCH_YES
)
5186 gfc_error ("Syntax error in PROCEDURE statement at %C");
5190 /* Free stuff up and return. */
5191 gfc_free_expr (initializer
);
5197 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5200 /* Match a procedure pointer component declaration (R445). */
5203 match_ppc_decl (void)
5206 gfc_symbol
*proc_if
= NULL
;
5210 gfc_expr
*initializer
= NULL
;
5211 gfc_typebound_proc
* tb
;
5212 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5214 /* Parse interface (with brackets). */
5215 m
= match_procedure_interface (&proc_if
);
5219 /* Parse attributes. */
5220 tb
= XCNEW (gfc_typebound_proc
);
5221 tb
->where
= gfc_current_locus
;
5222 m
= match_binding_attributes (tb
, false, true);
5223 if (m
== MATCH_ERROR
)
5226 gfc_clear_attr (¤t_attr
);
5227 current_attr
.procedure
= 1;
5228 current_attr
.proc_pointer
= 1;
5229 current_attr
.access
= tb
->access
;
5230 current_attr
.flavor
= FL_PROCEDURE
;
5232 /* Match the colons (required). */
5233 if (gfc_match (" ::") != MATCH_YES
)
5235 gfc_error ("Expected %<::%> after binding-attributes at %C");
5239 /* Check for C450. */
5240 if (!tb
->nopass
&& proc_if
== NULL
)
5242 gfc_error("NOPASS or explicit interface required at %C");
5246 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5249 /* Match PPC names. */
5253 m
= gfc_match_name (name
);
5256 else if (m
== MATCH_ERROR
)
5259 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5262 /* Add current_attr to the symbol attributes. */
5263 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5266 if (!gfc_add_external (&c
->attr
, NULL
))
5269 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5276 c
->tb
= XCNEW (gfc_typebound_proc
);
5277 c
->tb
->where
= gfc_current_locus
;
5281 /* Set interface. */
5282 if (proc_if
!= NULL
)
5284 c
->ts
.interface
= proc_if
;
5285 c
->attr
.untyped
= 1;
5286 c
->attr
.if_source
= IFSRC_IFBODY
;
5288 else if (ts
.type
!= BT_UNKNOWN
)
5291 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5292 c
->ts
.interface
->result
= c
->ts
.interface
;
5293 c
->ts
.interface
->ts
= ts
;
5294 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5295 c
->ts
.interface
->attr
.function
= 1;
5296 c
->attr
.function
= 1;
5297 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5300 if (gfc_match (" =>") == MATCH_YES
)
5302 m
= match_pointer_init (&initializer
, 1);
5305 gfc_free_expr (initializer
);
5308 c
->initializer
= initializer
;
5311 if (gfc_match_eos () == MATCH_YES
)
5313 if (gfc_match_char (',') != MATCH_YES
)
5318 gfc_error ("Syntax error in procedure pointer component at %C");
5323 /* Match a PROCEDURE declaration inside an interface (R1206). */
5326 match_procedure_in_interface (void)
5330 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5333 if (current_interface
.type
== INTERFACE_NAMELESS
5334 || current_interface
.type
== INTERFACE_ABSTRACT
)
5336 gfc_error ("PROCEDURE at %C must be in a generic interface");
5340 /* Check if the F2008 optional double colon appears. */
5341 gfc_gobble_whitespace ();
5342 old_locus
= gfc_current_locus
;
5343 if (gfc_match ("::") == MATCH_YES
)
5345 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5346 "MODULE PROCEDURE statement at %L", &old_locus
))
5350 gfc_current_locus
= old_locus
;
5354 m
= gfc_match_name (name
);
5357 else if (m
== MATCH_ERROR
)
5359 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5362 if (!gfc_add_interface (sym
))
5365 if (gfc_match_eos () == MATCH_YES
)
5367 if (gfc_match_char (',') != MATCH_YES
)
5374 gfc_error ("Syntax error in PROCEDURE statement at %C");
5379 /* General matcher for PROCEDURE declarations. */
5381 static match
match_procedure_in_type (void);
5384 gfc_match_procedure (void)
5388 switch (gfc_current_state ())
5393 case COMP_SUBMODULE
:
5394 case COMP_SUBROUTINE
:
5397 m
= match_procedure_decl ();
5399 case COMP_INTERFACE
:
5400 m
= match_procedure_in_interface ();
5403 m
= match_ppc_decl ();
5405 case COMP_DERIVED_CONTAINS
:
5406 m
= match_procedure_in_type ();
5415 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5422 /* Warn if a matched procedure has the same name as an intrinsic; this is
5423 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5424 parser-state-stack to find out whether we're in a module. */
5427 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5431 in_module
= (gfc_state_stack
->previous
5432 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5433 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5435 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5439 /* Match a function declaration. */
5442 gfc_match_function_decl (void)
5444 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5445 gfc_symbol
*sym
, *result
;
5449 match found_match
; /* Status returned by match func. */
5451 if (gfc_current_state () != COMP_NONE
5452 && gfc_current_state () != COMP_INTERFACE
5453 && gfc_current_state () != COMP_CONTAINS
)
5456 gfc_clear_ts (¤t_ts
);
5458 old_loc
= gfc_current_locus
;
5460 m
= gfc_match_prefix (¤t_ts
);
5463 gfc_current_locus
= old_loc
;
5467 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5469 gfc_current_locus
= old_loc
;
5473 if (get_proc_name (name
, &sym
, false))
5476 if (add_hidden_procptr_result (sym
))
5479 if (current_attr
.module_procedure
)
5480 sym
->attr
.module_procedure
= 1;
5482 gfc_new_block
= sym
;
5484 m
= gfc_match_formal_arglist (sym
, 0, 0);
5487 gfc_error ("Expected formal argument list in function "
5488 "definition at %C");
5492 else if (m
== MATCH_ERROR
)
5497 /* According to the draft, the bind(c) and result clause can
5498 come in either order after the formal_arg_list (i.e., either
5499 can be first, both can exist together or by themselves or neither
5500 one). Therefore, the match_result can't match the end of the
5501 string, and check for the bind(c) or result clause in either order. */
5502 found_match
= gfc_match_eos ();
5504 /* Make sure that it isn't already declared as BIND(C). If it is, it
5505 must have been marked BIND(C) with a BIND(C) attribute and that is
5506 not allowed for procedures. */
5507 if (sym
->attr
.is_bind_c
== 1)
5509 sym
->attr
.is_bind_c
= 0;
5510 if (sym
->old_symbol
!= NULL
)
5511 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5512 "variables or common blocks",
5513 &(sym
->old_symbol
->declared_at
));
5515 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5516 "variables or common blocks", &gfc_current_locus
);
5519 if (found_match
!= MATCH_YES
)
5521 /* If we haven't found the end-of-statement, look for a suffix. */
5522 suffix_match
= gfc_match_suffix (sym
, &result
);
5523 if (suffix_match
== MATCH_YES
)
5524 /* Need to get the eos now. */
5525 found_match
= gfc_match_eos ();
5527 found_match
= suffix_match
;
5530 if(found_match
!= MATCH_YES
)
5534 /* Make changes to the symbol. */
5537 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5540 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5541 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5544 /* Delay matching the function characteristics until after the
5545 specification block by signalling kind=-1. */
5546 sym
->declared_at
= old_loc
;
5547 if (current_ts
.type
!= BT_UNKNOWN
)
5548 current_ts
.kind
= -1;
5550 current_ts
.kind
= 0;
5554 if (current_ts
.type
!= BT_UNKNOWN
5555 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5561 if (current_ts
.type
!= BT_UNKNOWN
5562 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5564 sym
->result
= result
;
5567 /* Warn if this procedure has the same name as an intrinsic. */
5568 do_warn_intrinsic_shadow (sym
, true);
5574 gfc_current_locus
= old_loc
;
5579 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5580 pass the name of the entry, rather than the gfc_current_block name, and
5581 to return false upon finding an existing global entry. */
5584 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5588 enum gfc_symbol_type type
;
5590 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5592 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5593 name is a global identifier. */
5594 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5596 s
= gfc_get_gsymbol (name
);
5598 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5600 gfc_global_used (s
, where
);
5609 s
->ns
= gfc_current_ns
;
5613 /* Don't add the symbol multiple times. */
5615 && (!gfc_notification_std (GFC_STD_F2008
)
5616 || strcmp (name
, binding_label
) != 0))
5618 s
= gfc_get_gsymbol (binding_label
);
5620 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5622 gfc_global_used (s
, where
);
5629 s
->binding_label
= binding_label
;
5632 s
->ns
= gfc_current_ns
;
5640 /* Match an ENTRY statement. */
5643 gfc_match_entry (void)
5648 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5649 gfc_compile_state state
;
5653 bool module_procedure
;
5657 m
= gfc_match_name (name
);
5661 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5664 state
= gfc_current_state ();
5665 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5670 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5673 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5675 case COMP_SUBMODULE
:
5676 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5678 case COMP_BLOCK_DATA
:
5679 gfc_error ("ENTRY statement at %C cannot appear within "
5682 case COMP_INTERFACE
:
5683 gfc_error ("ENTRY statement at %C cannot appear within "
5687 gfc_error ("ENTRY statement at %C cannot appear within "
5688 "a DERIVED TYPE block");
5691 gfc_error ("ENTRY statement at %C cannot appear within "
5692 "an IF-THEN block");
5695 case COMP_DO_CONCURRENT
:
5696 gfc_error ("ENTRY statement at %C cannot appear within "
5700 gfc_error ("ENTRY statement at %C cannot appear within "
5704 gfc_error ("ENTRY statement at %C cannot appear within "
5708 gfc_error ("ENTRY statement at %C cannot appear within "
5712 gfc_error ("ENTRY statement at %C cannot appear within "
5713 "a contained subprogram");
5716 gfc_error ("Unexpected ENTRY statement at %C");
5721 module_procedure
= gfc_current_ns
->parent
!= NULL
5722 && gfc_current_ns
->parent
->proc_name
5723 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5726 if (gfc_current_ns
->parent
!= NULL
5727 && gfc_current_ns
->parent
->proc_name
5728 && !module_procedure
)
5730 gfc_error("ENTRY statement at %C cannot appear in a "
5731 "contained procedure");
5735 /* Module function entries need special care in get_proc_name
5736 because previous references within the function will have
5737 created symbols attached to the current namespace. */
5738 if (get_proc_name (name
, &entry
,
5739 gfc_current_ns
->parent
!= NULL
5740 && module_procedure
))
5743 proc
= gfc_current_block ();
5745 /* Make sure that it isn't already declared as BIND(C). If it is, it
5746 must have been marked BIND(C) with a BIND(C) attribute and that is
5747 not allowed for procedures. */
5748 if (entry
->attr
.is_bind_c
== 1)
5750 entry
->attr
.is_bind_c
= 0;
5751 if (entry
->old_symbol
!= NULL
)
5752 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5753 "variables or common blocks",
5754 &(entry
->old_symbol
->declared_at
));
5756 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5757 "variables or common blocks", &gfc_current_locus
);
5760 /* Check what next non-whitespace character is so we can tell if there
5761 is the required parens if we have a BIND(C). */
5762 old_loc
= gfc_current_locus
;
5763 gfc_gobble_whitespace ();
5764 peek_char
= gfc_peek_ascii_char ();
5766 if (state
== COMP_SUBROUTINE
)
5768 m
= gfc_match_formal_arglist (entry
, 0, 1);
5772 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5773 never be an internal procedure. */
5774 is_bind_c
= gfc_match_bind_c (entry
, true);
5775 if (is_bind_c
== MATCH_ERROR
)
5777 if (is_bind_c
== MATCH_YES
)
5779 if (peek_char
!= '(')
5781 gfc_error ("Missing required parentheses before BIND(C) at %C");
5784 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5785 &(entry
->declared_at
), 1))
5789 if (!gfc_current_ns
->parent
5790 && !add_global_entry (name
, entry
->binding_label
, true,
5794 /* An entry in a subroutine. */
5795 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5796 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5801 /* An entry in a function.
5802 We need to take special care because writing
5807 ENTRY f() RESULT (r)
5809 ENTRY f RESULT (r). */
5810 if (gfc_match_eos () == MATCH_YES
)
5812 gfc_current_locus
= old_loc
;
5813 /* Match the empty argument list, and add the interface to
5815 m
= gfc_match_formal_arglist (entry
, 0, 1);
5818 m
= gfc_match_formal_arglist (entry
, 0, 0);
5825 if (gfc_match_eos () == MATCH_YES
)
5827 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5828 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5831 entry
->result
= entry
;
5835 m
= gfc_match_suffix (entry
, &result
);
5837 gfc_syntax_error (ST_ENTRY
);
5843 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5844 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5845 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5847 entry
->result
= result
;
5851 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5852 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5854 entry
->result
= entry
;
5858 if (!gfc_current_ns
->parent
5859 && !add_global_entry (name
, entry
->binding_label
, false,
5864 if (gfc_match_eos () != MATCH_YES
)
5866 gfc_syntax_error (ST_ENTRY
);
5870 entry
->attr
.recursive
= proc
->attr
.recursive
;
5871 entry
->attr
.elemental
= proc
->attr
.elemental
;
5872 entry
->attr
.pure
= proc
->attr
.pure
;
5874 el
= gfc_get_entry_list ();
5876 el
->next
= gfc_current_ns
->entries
;
5877 gfc_current_ns
->entries
= el
;
5879 el
->id
= el
->next
->id
+ 1;
5883 new_st
.op
= EXEC_ENTRY
;
5884 new_st
.ext
.entry
= el
;
5890 /* Match a subroutine statement, including optional prefixes. */
5893 gfc_match_subroutine (void)
5895 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5900 bool allow_binding_name
;
5902 if (gfc_current_state () != COMP_NONE
5903 && gfc_current_state () != COMP_INTERFACE
5904 && gfc_current_state () != COMP_CONTAINS
)
5907 m
= gfc_match_prefix (NULL
);
5911 m
= gfc_match ("subroutine% %n", name
);
5915 if (get_proc_name (name
, &sym
, false))
5918 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5919 the symbol existed before. */
5920 sym
->declared_at
= gfc_current_locus
;
5922 if (current_attr
.module_procedure
)
5923 sym
->attr
.module_procedure
= 1;
5925 if (add_hidden_procptr_result (sym
))
5928 gfc_new_block
= sym
;
5930 /* Check what next non-whitespace character is so we can tell if there
5931 is the required parens if we have a BIND(C). */
5932 gfc_gobble_whitespace ();
5933 peek_char
= gfc_peek_ascii_char ();
5935 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5938 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5941 /* Make sure that it isn't already declared as BIND(C). If it is, it
5942 must have been marked BIND(C) with a BIND(C) attribute and that is
5943 not allowed for procedures. */
5944 if (sym
->attr
.is_bind_c
== 1)
5946 sym
->attr
.is_bind_c
= 0;
5947 if (sym
->old_symbol
!= NULL
)
5948 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5949 "variables or common blocks",
5950 &(sym
->old_symbol
->declared_at
));
5952 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5953 "variables or common blocks", &gfc_current_locus
);
5956 /* C binding names are not allowed for internal procedures. */
5957 if (gfc_current_state () == COMP_CONTAINS
5958 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5959 allow_binding_name
= false;
5961 allow_binding_name
= true;
5963 /* Here, we are just checking if it has the bind(c) attribute, and if
5964 so, then we need to make sure it's all correct. If it doesn't,
5965 we still need to continue matching the rest of the subroutine line. */
5966 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5967 if (is_bind_c
== MATCH_ERROR
)
5969 /* There was an attempt at the bind(c), but it was wrong. An
5970 error message should have been printed w/in the gfc_match_bind_c
5971 so here we'll just return the MATCH_ERROR. */
5975 if (is_bind_c
== MATCH_YES
)
5977 /* The following is allowed in the Fortran 2008 draft. */
5978 if (gfc_current_state () == COMP_CONTAINS
5979 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5980 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5981 "at %L may not be specified for an internal "
5982 "procedure", &gfc_current_locus
))
5985 if (peek_char
!= '(')
5987 gfc_error ("Missing required parentheses before BIND(C) at %C");
5990 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5991 &(sym
->declared_at
), 1))
5995 if (gfc_match_eos () != MATCH_YES
)
5997 gfc_syntax_error (ST_SUBROUTINE
);
6001 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6004 /* Warn if it has the same name as an intrinsic. */
6005 do_warn_intrinsic_shadow (sym
, false);
6011 /* Check that the NAME identifier in a BIND attribute or statement
6012 is conform to C identifier rules. */
6015 check_bind_name_identifier (char **name
)
6017 char *n
= *name
, *p
;
6019 /* Remove leading spaces. */
6023 /* On an empty string, free memory and set name to NULL. */
6031 /* Remove trailing spaces. */
6032 p
= n
+ strlen(n
) - 1;
6036 /* Insert the identifier into the symbol table. */
6041 /* Now check that identifier is valid under C rules. */
6044 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6049 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6051 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6059 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6060 given, and set the binding label in either the given symbol (if not
6061 NULL), or in the current_ts. The symbol may be NULL because we may
6062 encounter the BIND(C) before the declaration itself. Return
6063 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6064 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6065 or MATCH_YES if the specifier was correct and the binding label and
6066 bind(c) fields were set correctly for the given symbol or the
6067 current_ts. If allow_binding_name is false, no binding name may be
6071 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6073 char *binding_label
= NULL
;
6076 /* Initialize the flag that specifies whether we encountered a NAME=
6077 specifier or not. */
6078 has_name_equals
= 0;
6080 /* This much we have to be able to match, in this order, if
6081 there is a bind(c) label. */
6082 if (gfc_match (" bind ( c ") != MATCH_YES
)
6085 /* Now see if there is a binding label, or if we've reached the
6086 end of the bind(c) attribute without one. */
6087 if (gfc_match_char (',') == MATCH_YES
)
6089 if (gfc_match (" name = ") != MATCH_YES
)
6091 gfc_error ("Syntax error in NAME= specifier for binding label "
6093 /* should give an error message here */
6097 has_name_equals
= 1;
6099 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6105 if (!gfc_simplify_expr(e
, 0))
6107 gfc_error ("NAME= specifier at %C should be a constant expression");
6112 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6113 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6115 gfc_error ("NAME= specifier at %C should be a scalar of "
6116 "default character kind");
6121 // Get a C string from the Fortran string constant
6122 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6123 e
->value
.character
.length
);
6126 // Check that it is valid (old gfc_match_name_C)
6127 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6131 /* Get the required right paren. */
6132 if (gfc_match_char (')') != MATCH_YES
)
6134 gfc_error ("Missing closing paren for binding label at %C");
6138 if (has_name_equals
&& !allow_binding_name
)
6140 gfc_error ("No binding name is allowed in BIND(C) at %C");
6144 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6146 gfc_error ("For dummy procedure %s, no binding name is "
6147 "allowed in BIND(C) at %C", sym
->name
);
6152 /* Save the binding label to the symbol. If sym is null, we're
6153 probably matching the typespec attributes of a declaration and
6154 haven't gotten the name yet, and therefore, no symbol yet. */
6158 sym
->binding_label
= binding_label
;
6160 curr_binding_label
= binding_label
;
6162 else if (allow_binding_name
)
6164 /* No binding label, but if symbol isn't null, we
6165 can set the label for it here.
6166 If name="" or allow_binding_name is false, no C binding name is
6168 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6169 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6172 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6173 && current_interface
.type
== INTERFACE_ABSTRACT
)
6175 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6183 /* Return nonzero if we're currently compiling a contained procedure. */
6186 contained_procedure (void)
6188 gfc_state_data
*s
= gfc_state_stack
;
6190 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6191 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6197 /* Set the kind of each enumerator. The kind is selected such that it is
6198 interoperable with the corresponding C enumeration type, making
6199 sure that -fshort-enums is honored. */
6204 enumerator_history
*current_history
= NULL
;
6208 if (max_enum
== NULL
|| enum_history
== NULL
)
6211 if (!flag_short_enums
)
6217 kind
= gfc_integer_kinds
[i
++].kind
;
6219 while (kind
< gfc_c_int_kind
6220 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6223 current_history
= enum_history
;
6224 while (current_history
!= NULL
)
6226 current_history
->sym
->ts
.kind
= kind
;
6227 current_history
= current_history
->next
;
6232 /* Match any of the various end-block statements. Returns the type of
6233 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6234 and END BLOCK statements cannot be replaced by a single END statement. */
6237 gfc_match_end (gfc_statement
*st
)
6239 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6240 gfc_compile_state state
;
6242 const char *block_name
;
6246 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6247 gfc_namespace
**nsp
;
6248 bool abreviated_modproc_decl
;
6250 old_loc
= gfc_current_locus
;
6251 if (gfc_match ("end") != MATCH_YES
)
6254 state
= gfc_current_state ();
6255 block_name
= gfc_current_block () == NULL
6256 ? NULL
: gfc_current_block ()->name
;
6260 case COMP_ASSOCIATE
:
6262 if (!strncmp (block_name
, "block@", strlen("block@")))
6267 case COMP_DERIVED_CONTAINS
:
6268 state
= gfc_state_stack
->previous
->state
;
6269 block_name
= gfc_state_stack
->previous
->sym
== NULL
6270 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6277 abreviated_modproc_decl
6278 = gfc_current_block ()
6279 && gfc_current_block ()->abr_modproc_decl
;
6285 *st
= ST_END_PROGRAM
;
6286 target
= " program";
6290 case COMP_SUBROUTINE
:
6291 *st
= ST_END_SUBROUTINE
;
6292 if (!abreviated_modproc_decl
)
6293 target
= " subroutine";
6295 target
= " procedure";
6296 eos_ok
= !contained_procedure ();
6300 *st
= ST_END_FUNCTION
;
6301 if (!abreviated_modproc_decl
)
6302 target
= " function";
6304 target
= " procedure";
6305 eos_ok
= !contained_procedure ();
6308 case COMP_BLOCK_DATA
:
6309 *st
= ST_END_BLOCK_DATA
;
6310 target
= " block data";
6315 *st
= ST_END_MODULE
;
6320 case COMP_SUBMODULE
:
6321 *st
= ST_END_SUBMODULE
;
6322 target
= " submodule";
6326 case COMP_INTERFACE
:
6327 *st
= ST_END_INTERFACE
;
6328 target
= " interface";
6333 case COMP_DERIVED_CONTAINS
:
6339 case COMP_ASSOCIATE
:
6340 *st
= ST_END_ASSOCIATE
;
6341 target
= " associate";
6358 case COMP_DO_CONCURRENT
:
6365 *st
= ST_END_CRITICAL
;
6366 target
= " critical";
6371 case COMP_SELECT_TYPE
:
6372 *st
= ST_END_SELECT
;
6378 *st
= ST_END_FORALL
;
6393 last_initializer
= NULL
;
6395 gfc_free_enum_history ();
6399 gfc_error ("Unexpected END statement at %C");
6403 old_loc
= gfc_current_locus
;
6404 if (gfc_match_eos () == MATCH_YES
)
6406 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6408 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6409 "instead of %s statement at %L",
6410 abreviated_modproc_decl
? "END PROCEDURE"
6411 : gfc_ascii_statement(*st
), &old_loc
))
6416 /* We would have required END [something]. */
6417 gfc_error ("%s statement expected at %L",
6418 gfc_ascii_statement (*st
), &old_loc
);
6425 /* Verify that we've got the sort of end-block that we're expecting. */
6426 if (gfc_match (target
) != MATCH_YES
)
6428 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6429 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6433 old_loc
= gfc_current_locus
;
6434 /* If we're at the end, make sure a block name wasn't required. */
6435 if (gfc_match_eos () == MATCH_YES
)
6438 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6439 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6440 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6446 gfc_error ("Expected block name of %qs in %s statement at %L",
6447 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6452 /* END INTERFACE has a special handler for its several possible endings. */
6453 if (*st
== ST_END_INTERFACE
)
6454 return gfc_match_end_interface ();
6456 /* We haven't hit the end of statement, so what is left must be an
6458 m
= gfc_match_space ();
6460 m
= gfc_match_name (name
);
6463 gfc_error ("Expected terminating name at %C");
6467 if (block_name
== NULL
)
6470 /* We have to pick out the declared submodule name from the composite
6471 required by F2008:11.2.3 para 2, which ends in the declared name. */
6472 if (state
== COMP_SUBMODULE
)
6473 block_name
= strchr (block_name
, '.') + 1;
6475 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6477 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6478 gfc_ascii_statement (*st
));
6481 /* Procedure pointer as function result. */
6482 else if (strcmp (block_name
, "ppr@") == 0
6483 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6485 gfc_error ("Expected label %qs for %s statement at %C",
6486 gfc_current_block ()->ns
->proc_name
->name
,
6487 gfc_ascii_statement (*st
));
6491 if (gfc_match_eos () == MATCH_YES
)
6495 gfc_syntax_error (*st
);
6498 gfc_current_locus
= old_loc
;
6500 /* If we are missing an END BLOCK, we created a half-ready namespace.
6501 Remove it from the parent namespace's sibling list. */
6503 while (state
== COMP_BLOCK
)
6505 parent_ns
= gfc_current_ns
->parent
;
6507 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6513 if (ns
== gfc_current_ns
)
6515 if (prev_ns
== NULL
)
6518 prev_ns
->sibling
= ns
->sibling
;
6524 gfc_free_namespace (gfc_current_ns
);
6525 gfc_current_ns
= parent_ns
;
6526 gfc_state_stack
= gfc_state_stack
->previous
;
6527 state
= gfc_current_state ();
6535 /***************** Attribute declaration statements ****************/
6537 /* Set the attribute of a single variable. */
6542 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6545 /* Workaround -Wmaybe-uninitialized false positive during
6546 profiledbootstrap by initializing them. */
6547 gfc_symbol
*sym
= NULL
;
6553 m
= gfc_match_name (name
);
6557 if (find_special (name
, &sym
, false))
6560 if (!check_function_name (name
))
6566 var_locus
= gfc_current_locus
;
6568 /* Deal with possible array specification for certain attributes. */
6569 if (current_attr
.dimension
6570 || current_attr
.codimension
6571 || current_attr
.allocatable
6572 || current_attr
.pointer
6573 || current_attr
.target
)
6575 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6576 !current_attr
.dimension
6577 && !current_attr
.pointer
6578 && !current_attr
.target
);
6579 if (m
== MATCH_ERROR
)
6582 if (current_attr
.dimension
&& m
== MATCH_NO
)
6584 gfc_error ("Missing array specification at %L in DIMENSION "
6585 "statement", &var_locus
);
6590 if (current_attr
.dimension
&& sym
->value
)
6592 gfc_error ("Dimensions specified for %s at %L after its "
6593 "initialisation", sym
->name
, &var_locus
);
6598 if (current_attr
.codimension
&& m
== MATCH_NO
)
6600 gfc_error ("Missing array specification at %L in CODIMENSION "
6601 "statement", &var_locus
);
6606 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6607 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6609 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6615 /* Update symbol table. DIMENSION attribute is set in
6616 gfc_set_array_spec(). For CLASS variables, this must be applied
6617 to the first component, or '_data' field. */
6618 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6620 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6628 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6629 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6636 if (sym
->ts
.type
== BT_CLASS
6637 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6643 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6649 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6651 /* Fix the array spec. */
6652 m
= gfc_mod_pointee_as (sym
->as
);
6653 if (m
== MATCH_ERROR
)
6657 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6663 if ((current_attr
.external
|| current_attr
.intrinsic
)
6664 && sym
->attr
.flavor
!= FL_PROCEDURE
6665 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6671 add_hidden_procptr_result (sym
);
6676 gfc_free_array_spec (as
);
6681 /* Generic attribute declaration subroutine. Used for attributes that
6682 just have a list of names. */
6689 /* Gobble the optional double colon, by simply ignoring the result
6699 if (gfc_match_eos () == MATCH_YES
)
6705 if (gfc_match_char (',') != MATCH_YES
)
6707 gfc_error ("Unexpected character in variable list at %C");
6717 /* This routine matches Cray Pointer declarations of the form:
6718 pointer ( <pointer>, <pointee> )
6720 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6721 The pointer, if already declared, should be an integer. Otherwise, we
6722 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6723 be either a scalar, or an array declaration. No space is allocated for
6724 the pointee. For the statement
6725 pointer (ipt, ar(10))
6726 any subsequent uses of ar will be translated (in C-notation) as
6727 ar(i) => ((<type> *) ipt)(i)
6728 After gimplification, pointee variable will disappear in the code. */
6731 cray_pointer_decl (void)
6734 gfc_array_spec
*as
= NULL
;
6735 gfc_symbol
*cptr
; /* Pointer symbol. */
6736 gfc_symbol
*cpte
; /* Pointee symbol. */
6742 if (gfc_match_char ('(') != MATCH_YES
)
6744 gfc_error ("Expected %<(%> at %C");
6748 /* Match pointer. */
6749 var_locus
= gfc_current_locus
;
6750 gfc_clear_attr (¤t_attr
);
6751 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6752 current_ts
.type
= BT_INTEGER
;
6753 current_ts
.kind
= gfc_index_integer_kind
;
6755 m
= gfc_match_symbol (&cptr
, 0);
6758 gfc_error ("Expected variable name at %C");
6762 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6765 gfc_set_sym_referenced (cptr
);
6767 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6769 cptr
->ts
.type
= BT_INTEGER
;
6770 cptr
->ts
.kind
= gfc_index_integer_kind
;
6772 else if (cptr
->ts
.type
!= BT_INTEGER
)
6774 gfc_error ("Cray pointer at %C must be an integer");
6777 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6778 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6779 " memory addresses require %d bytes",
6780 cptr
->ts
.kind
, gfc_index_integer_kind
);
6782 if (gfc_match_char (',') != MATCH_YES
)
6784 gfc_error ("Expected \",\" at %C");
6788 /* Match Pointee. */
6789 var_locus
= gfc_current_locus
;
6790 gfc_clear_attr (¤t_attr
);
6791 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6792 current_ts
.type
= BT_UNKNOWN
;
6793 current_ts
.kind
= 0;
6795 m
= gfc_match_symbol (&cpte
, 0);
6798 gfc_error ("Expected variable name at %C");
6802 /* Check for an optional array spec. */
6803 m
= gfc_match_array_spec (&as
, true, false);
6804 if (m
== MATCH_ERROR
)
6806 gfc_free_array_spec (as
);
6809 else if (m
== MATCH_NO
)
6811 gfc_free_array_spec (as
);
6815 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6818 gfc_set_sym_referenced (cpte
);
6820 if (cpte
->as
== NULL
)
6822 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6823 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6825 else if (as
!= NULL
)
6827 gfc_error ("Duplicate array spec for Cray pointee at %C");
6828 gfc_free_array_spec (as
);
6834 if (cpte
->as
!= NULL
)
6836 /* Fix array spec. */
6837 m
= gfc_mod_pointee_as (cpte
->as
);
6838 if (m
== MATCH_ERROR
)
6842 /* Point the Pointee at the Pointer. */
6843 cpte
->cp_pointer
= cptr
;
6845 if (gfc_match_char (')') != MATCH_YES
)
6847 gfc_error ("Expected \")\" at %C");
6850 m
= gfc_match_char (',');
6852 done
= true; /* Stop searching for more declarations. */
6856 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6857 || gfc_match_eos () != MATCH_YES
)
6859 gfc_error ("Expected %<,%> or end of statement at %C");
6867 gfc_match_external (void)
6870 gfc_clear_attr (¤t_attr
);
6871 current_attr
.external
= 1;
6873 return attr_decl ();
6878 gfc_match_intent (void)
6882 /* This is not allowed within a BLOCK construct! */
6883 if (gfc_current_state () == COMP_BLOCK
)
6885 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6889 intent
= match_intent_spec ();
6890 if (intent
== INTENT_UNKNOWN
)
6893 gfc_clear_attr (¤t_attr
);
6894 current_attr
.intent
= intent
;
6896 return attr_decl ();
6901 gfc_match_intrinsic (void)
6904 gfc_clear_attr (¤t_attr
);
6905 current_attr
.intrinsic
= 1;
6907 return attr_decl ();
6912 gfc_match_optional (void)
6914 /* This is not allowed within a BLOCK construct! */
6915 if (gfc_current_state () == COMP_BLOCK
)
6917 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6921 gfc_clear_attr (¤t_attr
);
6922 current_attr
.optional
= 1;
6924 return attr_decl ();
6929 gfc_match_pointer (void)
6931 gfc_gobble_whitespace ();
6932 if (gfc_peek_ascii_char () == '(')
6934 if (!flag_cray_pointer
)
6936 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6940 return cray_pointer_decl ();
6944 gfc_clear_attr (¤t_attr
);
6945 current_attr
.pointer
= 1;
6947 return attr_decl ();
6953 gfc_match_allocatable (void)
6955 gfc_clear_attr (¤t_attr
);
6956 current_attr
.allocatable
= 1;
6958 return attr_decl ();
6963 gfc_match_codimension (void)
6965 gfc_clear_attr (¤t_attr
);
6966 current_attr
.codimension
= 1;
6968 return attr_decl ();
6973 gfc_match_contiguous (void)
6975 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6978 gfc_clear_attr (¤t_attr
);
6979 current_attr
.contiguous
= 1;
6981 return attr_decl ();
6986 gfc_match_dimension (void)
6988 gfc_clear_attr (¤t_attr
);
6989 current_attr
.dimension
= 1;
6991 return attr_decl ();
6996 gfc_match_target (void)
6998 gfc_clear_attr (¤t_attr
);
6999 current_attr
.target
= 1;
7001 return attr_decl ();
7005 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7009 access_attr_decl (gfc_statement st
)
7011 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7012 interface_type type
;
7014 gfc_symbol
*sym
, *dt_sym
;
7015 gfc_intrinsic_op op
;
7018 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7023 m
= gfc_match_generic_spec (&type
, name
, &op
);
7026 if (m
== MATCH_ERROR
)
7031 case INTERFACE_NAMELESS
:
7032 case INTERFACE_ABSTRACT
:
7035 case INTERFACE_GENERIC
:
7036 if (gfc_get_symbol (name
, NULL
, &sym
))
7039 if (!gfc_add_access (&sym
->attr
,
7041 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7045 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7046 && !gfc_add_access (&dt_sym
->attr
,
7048 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7054 case INTERFACE_INTRINSIC_OP
:
7055 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7057 gfc_intrinsic_op other_op
;
7059 gfc_current_ns
->operator_access
[op
] =
7060 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7062 /* Handle the case if there is another op with the same
7063 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7064 other_op
= gfc_equivalent_op (op
);
7066 if (other_op
!= INTRINSIC_NONE
)
7067 gfc_current_ns
->operator_access
[other_op
] =
7068 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7073 gfc_error ("Access specification of the %s operator at %C has "
7074 "already been specified", gfc_op2string (op
));
7080 case INTERFACE_USER_OP
:
7081 uop
= gfc_get_uop (name
);
7083 if (uop
->access
== ACCESS_UNKNOWN
)
7085 uop
->access
= (st
== ST_PUBLIC
)
7086 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7090 gfc_error ("Access specification of the .%s. operator at %C "
7091 "has already been specified", sym
->name
);
7098 if (gfc_match_char (',') == MATCH_NO
)
7102 if (gfc_match_eos () != MATCH_YES
)
7107 gfc_syntax_error (st
);
7115 gfc_match_protected (void)
7120 if (!gfc_current_ns
->proc_name
7121 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7123 gfc_error ("PROTECTED at %C only allowed in specification "
7124 "part of a module");
7129 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7132 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7137 if (gfc_match_eos () == MATCH_YES
)
7142 m
= gfc_match_symbol (&sym
, 0);
7146 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7158 if (gfc_match_eos () == MATCH_YES
)
7160 if (gfc_match_char (',') != MATCH_YES
)
7167 gfc_error ("Syntax error in PROTECTED statement at %C");
7172 /* The PRIVATE statement is a bit weird in that it can be an attribute
7173 declaration, but also works as a standalone statement inside of a
7174 type declaration or a module. */
7177 gfc_match_private (gfc_statement
*st
)
7180 if (gfc_match ("private") != MATCH_YES
)
7183 if (gfc_current_state () != COMP_MODULE
7184 && !(gfc_current_state () == COMP_DERIVED
7185 && gfc_state_stack
->previous
7186 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7187 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7188 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7189 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7191 gfc_error ("PRIVATE statement at %C is only allowed in the "
7192 "specification part of a module");
7196 if (gfc_current_state () == COMP_DERIVED
)
7198 if (gfc_match_eos () == MATCH_YES
)
7204 gfc_syntax_error (ST_PRIVATE
);
7208 if (gfc_match_eos () == MATCH_YES
)
7215 return access_attr_decl (ST_PRIVATE
);
7220 gfc_match_public (gfc_statement
*st
)
7223 if (gfc_match ("public") != MATCH_YES
)
7226 if (gfc_current_state () != COMP_MODULE
)
7228 gfc_error ("PUBLIC statement at %C is only allowed in the "
7229 "specification part of a module");
7233 if (gfc_match_eos () == MATCH_YES
)
7240 return access_attr_decl (ST_PUBLIC
);
7244 /* Workhorse for gfc_match_parameter. */
7254 m
= gfc_match_symbol (&sym
, 0);
7256 gfc_error ("Expected variable name at %C in PARAMETER statement");
7261 if (gfc_match_char ('=') == MATCH_NO
)
7263 gfc_error ("Expected = sign in PARAMETER statement at %C");
7267 m
= gfc_match_init_expr (&init
);
7269 gfc_error ("Expected expression at %C in PARAMETER statement");
7273 if (sym
->ts
.type
== BT_UNKNOWN
7274 && !gfc_set_default_type (sym
, 1, NULL
))
7280 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7281 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7289 gfc_error ("Initializing already initialized variable at %C");
7294 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7295 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7298 gfc_free_expr (init
);
7303 /* Match a parameter statement, with the weird syntax that these have. */
7306 gfc_match_parameter (void)
7310 if (gfc_match_char ('(') == MATCH_NO
)
7319 if (gfc_match (" )%t") == MATCH_YES
)
7322 if (gfc_match_char (',') != MATCH_YES
)
7324 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7334 /* Save statements have a special syntax. */
7337 gfc_match_save (void)
7339 char n
[GFC_MAX_SYMBOL_LEN
+1];
7344 if (gfc_match_eos () == MATCH_YES
)
7346 if (gfc_current_ns
->seen_save
)
7348 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7349 "follows previous SAVE statement"))
7353 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7357 if (gfc_current_ns
->save_all
)
7359 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7360 "blanket SAVE statement"))
7368 m
= gfc_match_symbol (&sym
, 0);
7372 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7373 &gfc_current_locus
))
7384 m
= gfc_match (" / %n /", &n
);
7385 if (m
== MATCH_ERROR
)
7390 c
= gfc_get_common (n
, 0);
7393 gfc_current_ns
->seen_save
= 1;
7396 if (gfc_match_eos () == MATCH_YES
)
7398 if (gfc_match_char (',') != MATCH_YES
)
7405 gfc_error ("Syntax error in SAVE statement at %C");
7411 gfc_match_value (void)
7416 /* This is not allowed within a BLOCK construct! */
7417 if (gfc_current_state () == COMP_BLOCK
)
7419 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7423 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7426 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7431 if (gfc_match_eos () == MATCH_YES
)
7436 m
= gfc_match_symbol (&sym
, 0);
7440 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7452 if (gfc_match_eos () == MATCH_YES
)
7454 if (gfc_match_char (',') != MATCH_YES
)
7461 gfc_error ("Syntax error in VALUE statement at %C");
7467 gfc_match_volatile (void)
7472 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7475 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7480 if (gfc_match_eos () == MATCH_YES
)
7485 /* VOLATILE is special because it can be added to host-associated
7486 symbols locally. Except for coarrays. */
7487 m
= gfc_match_symbol (&sym
, 1);
7491 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7492 for variable in a BLOCK which is defined outside of the BLOCK. */
7493 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7495 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7496 "%C, which is use-/host-associated", sym
->name
);
7499 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7511 if (gfc_match_eos () == MATCH_YES
)
7513 if (gfc_match_char (',') != MATCH_YES
)
7520 gfc_error ("Syntax error in VOLATILE statement at %C");
7526 gfc_match_asynchronous (void)
7531 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7534 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7539 if (gfc_match_eos () == MATCH_YES
)
7544 /* ASYNCHRONOUS is special because it can be added to host-associated
7546 m
= gfc_match_symbol (&sym
, 1);
7550 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7562 if (gfc_match_eos () == MATCH_YES
)
7564 if (gfc_match_char (',') != MATCH_YES
)
7571 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7576 /* Match a module procedure statement in a submodule. */
7579 gfc_match_submod_proc (void)
7581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7582 gfc_symbol
*sym
, *fsym
;
7584 gfc_formal_arglist
*formal
, *head
, *tail
;
7586 if (gfc_current_state () != COMP_CONTAINS
7587 || !(gfc_state_stack
->previous
7588 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7591 m
= gfc_match (" module% procedure% %n", name
);
7595 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7599 if (get_proc_name (name
, &sym
, false))
7602 /* Make sure that the result field is appropriately filled, even though
7603 the result symbol will be replaced later on. */
7604 if (sym
->ts
.interface
->attr
.function
)
7606 if (sym
->ts
.interface
->result
7607 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7608 sym
->result
= sym
->ts
.interface
->result
;
7613 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7614 the symbol existed before. */
7615 sym
->declared_at
= gfc_current_locus
;
7617 if (!sym
->attr
.module_procedure
)
7620 /* Signal match_end to expect "end procedure". */
7621 sym
->abr_modproc_decl
= 1;
7623 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7624 sym
->attr
.if_source
= IFSRC_DECL
;
7626 gfc_new_block
= sym
;
7628 /* Make a new formal arglist with the symbols in the procedure
7631 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7633 if (formal
== sym
->formal
)
7634 head
= tail
= gfc_get_formal_arglist ();
7637 tail
->next
= gfc_get_formal_arglist ();
7641 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7645 gfc_set_sym_referenced (fsym
);
7648 /* The dummy symbols get cleaned up, when the formal_namespace of the
7649 interface declaration is cleared. This allows us to add the
7650 explicit interface as is done for other type of procedure. */
7651 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7652 &gfc_current_locus
))
7655 if (gfc_match_eos () != MATCH_YES
)
7657 gfc_syntax_error (ST_MODULE_PROC
);
7664 gfc_free_formal_arglist (head
);
7669 /* Match a module procedure statement. Note that we have to modify
7670 symbols in the parent's namespace because the current one was there
7671 to receive symbols that are in an interface's formal argument list. */
7674 gfc_match_modproc (void)
7676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7680 gfc_namespace
*module_ns
;
7681 gfc_interface
*old_interface_head
, *interface
;
7683 if (gfc_state_stack
->state
!= COMP_INTERFACE
7684 || gfc_state_stack
->previous
== NULL
7685 || current_interface
.type
== INTERFACE_NAMELESS
7686 || current_interface
.type
== INTERFACE_ABSTRACT
)
7688 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7693 module_ns
= gfc_current_ns
->parent
;
7694 for (; module_ns
; module_ns
= module_ns
->parent
)
7695 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7696 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7697 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7698 && !module_ns
->proc_name
->attr
.contained
))
7701 if (module_ns
== NULL
)
7704 /* Store the current state of the interface. We will need it if we
7705 end up with a syntax error and need to recover. */
7706 old_interface_head
= gfc_current_interface_head ();
7708 /* Check if the F2008 optional double colon appears. */
7709 gfc_gobble_whitespace ();
7710 old_locus
= gfc_current_locus
;
7711 if (gfc_match ("::") == MATCH_YES
)
7713 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7714 "MODULE PROCEDURE statement at %L", &old_locus
))
7718 gfc_current_locus
= old_locus
;
7723 old_locus
= gfc_current_locus
;
7725 m
= gfc_match_name (name
);
7731 /* Check for syntax error before starting to add symbols to the
7732 current namespace. */
7733 if (gfc_match_eos () == MATCH_YES
)
7736 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7739 /* Now we're sure the syntax is valid, we process this item
7741 if (gfc_get_symbol (name
, module_ns
, &sym
))
7744 if (sym
->attr
.intrinsic
)
7746 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7747 "PROCEDURE", &old_locus
);
7751 if (sym
->attr
.proc
!= PROC_MODULE
7752 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7755 if (!gfc_add_interface (sym
))
7758 sym
->attr
.mod_proc
= 1;
7759 sym
->declared_at
= old_locus
;
7768 /* Restore the previous state of the interface. */
7769 interface
= gfc_current_interface_head ();
7770 gfc_set_current_interface_head (old_interface_head
);
7772 /* Free the new interfaces. */
7773 while (interface
!= old_interface_head
)
7775 gfc_interface
*i
= interface
->next
;
7780 /* And issue a syntax error. */
7781 gfc_syntax_error (ST_MODULE_PROC
);
7786 /* Check a derived type that is being extended. */
7789 check_extended_derived_type (char *name
)
7791 gfc_symbol
*extended
;
7793 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7795 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7799 extended
= gfc_find_dt_in_generic (extended
);
7804 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7808 if (extended
->attr
.flavor
!= FL_DERIVED
)
7810 gfc_error ("%qs in EXTENDS expression at %C is not a "
7811 "derived type", name
);
7815 if (extended
->attr
.is_bind_c
)
7817 gfc_error ("%qs cannot be extended at %C because it "
7818 "is BIND(C)", extended
->name
);
7822 if (extended
->attr
.sequence
)
7824 gfc_error ("%qs cannot be extended at %C because it "
7825 "is a SEQUENCE type", extended
->name
);
7833 /* Match the optional attribute specifiers for a type declaration.
7834 Return MATCH_ERROR if an error is encountered in one of the handled
7835 attributes (public, private, bind(c)), MATCH_NO if what's found is
7836 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7837 checking on attribute conflicts needs to be done. */
7840 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7842 /* See if the derived type is marked as private. */
7843 if (gfc_match (" , private") == MATCH_YES
)
7845 if (gfc_current_state () != COMP_MODULE
)
7847 gfc_error ("Derived type at %C can only be PRIVATE in the "
7848 "specification part of a module");
7852 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7855 else if (gfc_match (" , public") == MATCH_YES
)
7857 if (gfc_current_state () != COMP_MODULE
)
7859 gfc_error ("Derived type at %C can only be PUBLIC in the "
7860 "specification part of a module");
7864 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7867 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7869 /* If the type is defined to be bind(c) it then needs to make
7870 sure that all fields are interoperable. This will
7871 need to be a semantic check on the finished derived type.
7872 See 15.2.3 (lines 9-12) of F2003 draft. */
7873 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7876 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7878 else if (gfc_match (" , abstract") == MATCH_YES
)
7880 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7883 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7886 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7888 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7894 /* If we get here, something matched. */
7899 /* Match the beginning of a derived type declaration. If a type name
7900 was the result of a function, then it is possible to have a symbol
7901 already to be known as a derived type yet have no components. */
7904 gfc_match_derived_decl (void)
7906 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7907 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7908 symbol_attribute attr
;
7909 gfc_symbol
*sym
, *gensym
;
7910 gfc_symbol
*extended
;
7912 match is_type_attr_spec
= MATCH_NO
;
7913 bool seen_attr
= false;
7914 gfc_interface
*intr
= NULL
, *head
;
7916 if (gfc_current_state () == COMP_DERIVED
)
7921 gfc_clear_attr (&attr
);
7926 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7927 if (is_type_attr_spec
== MATCH_ERROR
)
7929 if (is_type_attr_spec
== MATCH_YES
)
7931 } while (is_type_attr_spec
== MATCH_YES
);
7933 /* Deal with derived type extensions. The extension attribute has
7934 been added to 'attr' but now the parent type must be found and
7937 extended
= check_extended_derived_type (parent
);
7939 if (parent
[0] && !extended
)
7942 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7944 gfc_error ("Expected :: in TYPE definition at %C");
7948 m
= gfc_match (" %n%t", name
);
7952 /* Make sure the name is not the name of an intrinsic type. */
7953 if (gfc_is_intrinsic_typename (name
))
7955 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
7960 if (gfc_get_symbol (name
, NULL
, &gensym
))
7963 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7965 gfc_error ("Derived type name %qs at %C already has a basic type "
7966 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7970 if (!gensym
->attr
.generic
7971 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7974 if (!gensym
->attr
.function
7975 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7978 sym
= gfc_find_dt_in_generic (gensym
);
7980 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7982 gfc_error ("Derived type definition of %qs at %C has already been "
7983 "defined", sym
->name
);
7989 /* Use upper case to save the actual derived-type symbol. */
7990 gfc_get_symbol (gfc_get_string ("%c%s",
7991 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7992 &gensym
->name
[1]), NULL
, &sym
);
7993 sym
->name
= gfc_get_string (gensym
->name
);
7994 head
= gensym
->generic
;
7995 intr
= gfc_get_interface ();
7997 intr
->where
= gfc_current_locus
;
7998 intr
->sym
->declared_at
= gfc_current_locus
;
8000 gensym
->generic
= intr
;
8001 gensym
->attr
.if_source
= IFSRC_DECL
;
8004 /* The symbol may already have the derived attribute without the
8005 components. The ways this can happen is via a function
8006 definition, an INTRINSIC statement or a subtype in another
8007 derived type that is a pointer. The first part of the AND clause
8008 is true if the symbol is not the return value of a function. */
8009 if (sym
->attr
.flavor
!= FL_DERIVED
8010 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8013 if (attr
.access
!= ACCESS_UNKNOWN
8014 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8016 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8017 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8018 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8022 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8023 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8024 gensym
->attr
.access
= sym
->attr
.access
;
8026 /* See if the derived type was labeled as bind(c). */
8027 if (attr
.is_bind_c
!= 0)
8028 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8030 /* Construct the f2k_derived namespace if it is not yet there. */
8031 if (!sym
->f2k_derived
)
8032 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8034 if (extended
&& !sym
->components
)
8038 /* Add the extended derived type as the first component. */
8039 gfc_add_component (sym
, parent
, &p
);
8041 gfc_set_sym_referenced (extended
);
8043 p
->ts
.type
= BT_DERIVED
;
8044 p
->ts
.u
.derived
= extended
;
8045 p
->initializer
= gfc_default_initializer (&p
->ts
);
8047 /* Set extension level. */
8048 if (extended
->attr
.extension
== 255)
8050 /* Since the extension field is 8 bit wide, we can only have
8051 up to 255 extension levels. */
8052 gfc_error ("Maximum extension level reached with type %qs at %L",
8053 extended
->name
, &extended
->declared_at
);
8056 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8058 /* Provide the links between the extended type and its extension. */
8059 if (!extended
->f2k_derived
)
8060 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8063 if (!sym
->hash_value
)
8064 /* Set the hash for the compound name for this type. */
8065 sym
->hash_value
= gfc_hash_value (sym
);
8067 /* Take over the ABSTRACT attribute. */
8068 sym
->attr
.abstract
= attr
.abstract
;
8070 gfc_new_block
= sym
;
8076 /* Cray Pointees can be declared as:
8077 pointer (ipt, a (n,m,...,*)) */
8080 gfc_mod_pointee_as (gfc_array_spec
*as
)
8082 as
->cray_pointee
= true; /* This will be useful to know later. */
8083 if (as
->type
== AS_ASSUMED_SIZE
)
8084 as
->cp_was_assumed
= true;
8085 else if (as
->type
== AS_ASSUMED_SHAPE
)
8087 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8094 /* Match the enum definition statement, here we are trying to match
8095 the first line of enum definition statement.
8096 Returns MATCH_YES if match is found. */
8099 gfc_match_enum (void)
8103 m
= gfc_match_eos ();
8107 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8114 /* Returns an initializer whose value is one higher than the value of the
8115 LAST_INITIALIZER argument. If the argument is NULL, the
8116 initializers value will be set to zero. The initializer's kind
8117 will be set to gfc_c_int_kind.
8119 If -fshort-enums is given, the appropriate kind will be selected
8120 later after all enumerators have been parsed. A warning is issued
8121 here if an initializer exceeds gfc_c_int_kind. */
8124 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8127 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8129 mpz_init (result
->value
.integer
);
8131 if (last_initializer
!= NULL
)
8133 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8134 result
->where
= last_initializer
->where
;
8136 if (gfc_check_integer_range (result
->value
.integer
,
8137 gfc_c_int_kind
) != ARITH_OK
)
8139 gfc_error ("Enumerator exceeds the C integer type at %C");
8145 /* Control comes here, if it's the very first enumerator and no
8146 initializer has been given. It will be initialized to zero. */
8147 mpz_set_si (result
->value
.integer
, 0);
8154 /* Match a variable name with an optional initializer. When this
8155 subroutine is called, a variable is expected to be parsed next.
8156 Depending on what is happening at the moment, updates either the
8157 symbol table or the current interface. */
8160 enumerator_decl (void)
8162 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8163 gfc_expr
*initializer
;
8164 gfc_array_spec
*as
= NULL
;
8172 old_locus
= gfc_current_locus
;
8174 /* When we get here, we've just matched a list of attributes and
8175 maybe a type and a double colon. The next thing we expect to see
8176 is the name of the symbol. */
8177 m
= gfc_match_name (name
);
8181 var_locus
= gfc_current_locus
;
8183 /* OK, we've successfully matched the declaration. Now put the
8184 symbol in the current namespace. If we fail to create the symbol,
8186 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8192 /* The double colon must be present in order to have initializers.
8193 Otherwise the statement is ambiguous with an assignment statement. */
8196 if (gfc_match_char ('=') == MATCH_YES
)
8198 m
= gfc_match_init_expr (&initializer
);
8201 gfc_error ("Expected an initialization expression at %C");
8210 /* If we do not have an initializer, the initialization value of the
8211 previous enumerator (stored in last_initializer) is incremented
8212 by 1 and is used to initialize the current enumerator. */
8213 if (initializer
== NULL
)
8214 initializer
= enum_initializer (last_initializer
, old_locus
);
8216 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8218 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8224 /* Store this current initializer, for the next enumerator variable
8225 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8226 use last_initializer below. */
8227 last_initializer
= initializer
;
8228 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8230 /* Maintain enumerator history. */
8231 gfc_find_symbol (name
, NULL
, 0, &sym
);
8232 create_enum_history (sym
, last_initializer
);
8234 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8237 /* Free stuff up and return. */
8238 gfc_free_expr (initializer
);
8244 /* Match the enumerator definition statement. */
8247 gfc_match_enumerator_def (void)
8252 gfc_clear_ts (¤t_ts
);
8254 m
= gfc_match (" enumerator");
8258 m
= gfc_match (" :: ");
8259 if (m
== MATCH_ERROR
)
8262 colon_seen
= (m
== MATCH_YES
);
8264 if (gfc_current_state () != COMP_ENUM
)
8266 gfc_error ("ENUM definition statement expected before %C");
8267 gfc_free_enum_history ();
8271 (¤t_ts
)->type
= BT_INTEGER
;
8272 (¤t_ts
)->kind
= gfc_c_int_kind
;
8274 gfc_clear_attr (¤t_attr
);
8275 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8284 m
= enumerator_decl ();
8285 if (m
== MATCH_ERROR
)
8287 gfc_free_enum_history ();
8293 if (gfc_match_eos () == MATCH_YES
)
8295 if (gfc_match_char (',') != MATCH_YES
)
8299 if (gfc_current_state () == COMP_ENUM
)
8301 gfc_free_enum_history ();
8302 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8307 gfc_free_array_spec (current_as
);
8314 /* Match binding attributes. */
8317 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8319 bool found_passing
= false;
8320 bool seen_ptr
= false;
8321 match m
= MATCH_YES
;
8323 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8324 this case the defaults are in there. */
8325 ba
->access
= ACCESS_UNKNOWN
;
8326 ba
->pass_arg
= NULL
;
8327 ba
->pass_arg_num
= 0;
8329 ba
->non_overridable
= 0;
8333 /* If we find a comma, we believe there are binding attributes. */
8334 m
= gfc_match_char (',');
8340 /* Access specifier. */
8342 m
= gfc_match (" public");
8343 if (m
== MATCH_ERROR
)
8347 if (ba
->access
!= ACCESS_UNKNOWN
)
8349 gfc_error ("Duplicate access-specifier at %C");
8353 ba
->access
= ACCESS_PUBLIC
;
8357 m
= gfc_match (" private");
8358 if (m
== MATCH_ERROR
)
8362 if (ba
->access
!= ACCESS_UNKNOWN
)
8364 gfc_error ("Duplicate access-specifier at %C");
8368 ba
->access
= ACCESS_PRIVATE
;
8372 /* If inside GENERIC, the following is not allowed. */
8377 m
= gfc_match (" nopass");
8378 if (m
== MATCH_ERROR
)
8384 gfc_error ("Binding attributes already specify passing,"
8385 " illegal NOPASS at %C");
8389 found_passing
= true;
8394 /* PASS possibly including argument. */
8395 m
= gfc_match (" pass");
8396 if (m
== MATCH_ERROR
)
8400 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8404 gfc_error ("Binding attributes already specify passing,"
8405 " illegal PASS at %C");
8409 m
= gfc_match (" ( %n )", arg
);
8410 if (m
== MATCH_ERROR
)
8413 ba
->pass_arg
= gfc_get_string (arg
);
8414 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8416 found_passing
= true;
8424 m
= gfc_match (" pointer");
8425 if (m
== MATCH_ERROR
)
8431 gfc_error ("Duplicate POINTER attribute at %C");
8441 /* NON_OVERRIDABLE flag. */
8442 m
= gfc_match (" non_overridable");
8443 if (m
== MATCH_ERROR
)
8447 if (ba
->non_overridable
)
8449 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8453 ba
->non_overridable
= 1;
8457 /* DEFERRED flag. */
8458 m
= gfc_match (" deferred");
8459 if (m
== MATCH_ERROR
)
8465 gfc_error ("Duplicate DEFERRED at %C");
8476 /* Nothing matching found. */
8478 gfc_error ("Expected access-specifier at %C");
8480 gfc_error ("Expected binding attribute at %C");
8483 while (gfc_match_char (',') == MATCH_YES
);
8485 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8486 if (ba
->non_overridable
&& ba
->deferred
)
8488 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8495 if (ba
->access
== ACCESS_UNKNOWN
)
8496 ba
->access
= gfc_typebound_default_access
;
8498 if (ppc
&& !seen_ptr
)
8500 gfc_error ("POINTER attribute is required for procedure pointer component"
8512 /* Match a PROCEDURE specific binding inside a derived type. */
8515 match_procedure_in_type (void)
8517 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8518 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8519 char* target
= NULL
, *ifc
= NULL
;
8520 gfc_typebound_proc tb
;
8529 /* Check current state. */
8530 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8531 block
= gfc_state_stack
->previous
->sym
;
8534 /* Try to match PROCEDURE(interface). */
8535 if (gfc_match (" (") == MATCH_YES
)
8537 m
= gfc_match_name (target_buf
);
8538 if (m
== MATCH_ERROR
)
8542 gfc_error ("Interface-name expected after %<(%> at %C");
8546 if (gfc_match (" )") != MATCH_YES
)
8548 gfc_error ("%<)%> expected at %C");
8555 /* Construct the data structure. */
8556 memset (&tb
, 0, sizeof (tb
));
8557 tb
.where
= gfc_current_locus
;
8559 /* Match binding attributes. */
8560 m
= match_binding_attributes (&tb
, false, false);
8561 if (m
== MATCH_ERROR
)
8563 seen_attrs
= (m
== MATCH_YES
);
8565 /* Check that attribute DEFERRED is given if an interface is specified. */
8566 if (tb
.deferred
&& !ifc
)
8568 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8571 if (ifc
&& !tb
.deferred
)
8573 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8577 /* Match the colons. */
8578 m
= gfc_match (" ::");
8579 if (m
== MATCH_ERROR
)
8581 seen_colons
= (m
== MATCH_YES
);
8582 if (seen_attrs
&& !seen_colons
)
8584 gfc_error ("Expected %<::%> after binding-attributes at %C");
8588 /* Match the binding names. */
8591 m
= gfc_match_name (name
);
8592 if (m
== MATCH_ERROR
)
8596 gfc_error ("Expected binding name at %C");
8600 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8603 /* Try to match the '=> target', if it's there. */
8605 m
= gfc_match (" =>");
8606 if (m
== MATCH_ERROR
)
8612 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8618 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8623 m
= gfc_match_name (target_buf
);
8624 if (m
== MATCH_ERROR
)
8628 gfc_error ("Expected binding target after %<=>%> at %C");
8631 target
= target_buf
;
8634 /* If no target was found, it has the same name as the binding. */
8638 /* Get the namespace to insert the symbols into. */
8639 ns
= block
->f2k_derived
;
8642 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8643 if (tb
.deferred
&& !block
->attr
.abstract
)
8645 gfc_error ("Type %qs containing DEFERRED binding at %C "
8646 "is not ABSTRACT", block
->name
);
8650 /* See if we already have a binding with this name in the symtree which
8651 would be an error. If a GENERIC already targeted this binding, it may
8652 be already there but then typebound is still NULL. */
8653 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8654 if (stree
&& stree
->n
.tb
)
8656 gfc_error ("There is already a procedure with binding name %qs for "
8657 "the derived type %qs at %C", name
, block
->name
);
8661 /* Insert it and set attributes. */
8665 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8668 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8670 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8673 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8675 if (gfc_match_eos () == MATCH_YES
)
8677 if (gfc_match_char (',') != MATCH_YES
)
8682 gfc_error ("Syntax error in PROCEDURE statement at %C");
8687 /* Match a GENERIC procedure binding inside a derived type. */
8690 gfc_match_generic (void)
8692 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8693 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8695 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8696 gfc_typebound_proc
* tb
;
8698 interface_type op_type
;
8699 gfc_intrinsic_op op
;
8702 /* Check current state. */
8703 if (gfc_current_state () == COMP_DERIVED
)
8705 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8708 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8710 block
= gfc_state_stack
->previous
->sym
;
8711 ns
= block
->f2k_derived
;
8712 gcc_assert (block
&& ns
);
8714 memset (&tbattr
, 0, sizeof (tbattr
));
8715 tbattr
.where
= gfc_current_locus
;
8717 /* See if we get an access-specifier. */
8718 m
= match_binding_attributes (&tbattr
, true, false);
8719 if (m
== MATCH_ERROR
)
8722 /* Now the colons, those are required. */
8723 if (gfc_match (" ::") != MATCH_YES
)
8725 gfc_error ("Expected %<::%> at %C");
8729 /* Match the binding name; depending on type (operator / generic) format
8730 it for future error messages into bind_name. */
8732 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8733 if (m
== MATCH_ERROR
)
8737 gfc_error ("Expected generic name or operator descriptor at %C");
8743 case INTERFACE_GENERIC
:
8744 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8747 case INTERFACE_USER_OP
:
8748 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8751 case INTERFACE_INTRINSIC_OP
:
8752 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8753 gfc_op2string (op
));
8756 case INTERFACE_NAMELESS
:
8757 gfc_error ("Malformed GENERIC statement at %C");
8765 /* Match the required =>. */
8766 if (gfc_match (" =>") != MATCH_YES
)
8768 gfc_error ("Expected %<=>%> at %C");
8772 /* Try to find existing GENERIC binding with this name / for this operator;
8773 if there is something, check that it is another GENERIC and then extend
8774 it rather than building a new node. Otherwise, create it and put it
8775 at the right position. */
8779 case INTERFACE_USER_OP
:
8780 case INTERFACE_GENERIC
:
8782 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8785 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8797 case INTERFACE_INTRINSIC_OP
:
8807 if (!tb
->is_generic
)
8809 gcc_assert (op_type
== INTERFACE_GENERIC
);
8810 gfc_error ("There's already a non-generic procedure with binding name"
8811 " %qs for the derived type %qs at %C",
8812 bind_name
, block
->name
);
8816 if (tb
->access
!= tbattr
.access
)
8818 gfc_error ("Binding at %C must have the same access as already"
8819 " defined binding %qs", bind_name
);
8825 tb
= gfc_get_typebound_proc (NULL
);
8826 tb
->where
= gfc_current_locus
;
8827 tb
->access
= tbattr
.access
;
8829 tb
->u
.generic
= NULL
;
8833 case INTERFACE_GENERIC
:
8834 case INTERFACE_USER_OP
:
8836 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8839 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8847 case INTERFACE_INTRINSIC_OP
:
8856 /* Now, match all following names as specific targets. */
8859 gfc_symtree
* target_st
;
8860 gfc_tbp_generic
* target
;
8862 m
= gfc_match_name (name
);
8863 if (m
== MATCH_ERROR
)
8867 gfc_error ("Expected specific binding name at %C");
8871 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8873 /* See if this is a duplicate specification. */
8874 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8875 if (target_st
== target
->specific_st
)
8877 gfc_error ("%qs already defined as specific binding for the"
8878 " generic %qs at %C", name
, bind_name
);
8882 target
= gfc_get_tbp_generic ();
8883 target
->specific_st
= target_st
;
8884 target
->specific
= NULL
;
8885 target
->next
= tb
->u
.generic
;
8886 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8887 || (op_type
== INTERFACE_INTRINSIC_OP
));
8888 tb
->u
.generic
= target
;
8890 while (gfc_match (" ,") == MATCH_YES
);
8892 /* Here should be the end. */
8893 if (gfc_match_eos () != MATCH_YES
)
8895 gfc_error ("Junk after GENERIC binding at %C");
8906 /* Match a FINAL declaration inside a derived type. */
8909 gfc_match_final_decl (void)
8911 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8914 gfc_namespace
* module_ns
;
8918 if (gfc_current_form
== FORM_FREE
)
8920 char c
= gfc_peek_ascii_char ();
8921 if (!gfc_is_whitespace (c
) && c
!= ':')
8925 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8927 if (gfc_current_form
== FORM_FIXED
)
8930 gfc_error ("FINAL declaration at %C must be inside a derived type "
8931 "CONTAINS section");
8935 block
= gfc_state_stack
->previous
->sym
;
8938 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8939 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8941 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8942 " specification part of a MODULE");
8946 module_ns
= gfc_current_ns
;
8947 gcc_assert (module_ns
);
8948 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8950 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8951 if (gfc_match (" ::") == MATCH_ERROR
)
8954 /* Match the sequence of procedure names. */
8961 if (first
&& gfc_match_eos () == MATCH_YES
)
8963 gfc_error ("Empty FINAL at %C");
8967 m
= gfc_match_name (name
);
8970 gfc_error ("Expected module procedure name at %C");
8973 else if (m
!= MATCH_YES
)
8976 if (gfc_match_eos () == MATCH_YES
)
8978 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8980 gfc_error ("Expected %<,%> at %C");
8984 if (gfc_get_symbol (name
, module_ns
, &sym
))
8986 gfc_error ("Unknown procedure name %qs at %C", name
);
8990 /* Mark the symbol as module procedure. */
8991 if (sym
->attr
.proc
!= PROC_MODULE
8992 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8995 /* Check if we already have this symbol in the list, this is an error. */
8996 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8997 if (f
->proc_sym
== sym
)
8999 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9004 /* Add this symbol to the list of finalizers. */
9005 gcc_assert (block
->f2k_derived
);
9007 f
= XCNEW (gfc_finalizer
);
9009 f
->proc_tree
= NULL
;
9010 f
->where
= gfc_current_locus
;
9011 f
->next
= block
->f2k_derived
->finalizers
;
9012 block
->f2k_derived
->finalizers
= f
;
9022 const ext_attr_t ext_attr_list
[] = {
9023 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9024 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9025 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9026 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9027 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9028 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9029 { NULL
, EXT_ATTR_LAST
, NULL
}
9032 /* Match a !GCC$ ATTRIBUTES statement of the form:
9033 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9034 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9036 TODO: We should support all GCC attributes using the same syntax for
9037 the attribute list, i.e. the list in C
9038 __attributes(( attribute-list ))
9040 !GCC$ ATTRIBUTES attribute-list ::
9041 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9044 As there is absolutely no risk of confusion, we should never return
9047 gfc_match_gcc_attributes (void)
9049 symbol_attribute attr
;
9050 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9055 gfc_clear_attr (&attr
);
9060 if (gfc_match_name (name
) != MATCH_YES
)
9063 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9064 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9067 if (id
== EXT_ATTR_LAST
)
9069 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9073 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9076 gfc_gobble_whitespace ();
9077 ch
= gfc_next_ascii_char ();
9080 /* This is the successful exit condition for the loop. */
9081 if (gfc_next_ascii_char () == ':')
9091 if (gfc_match_eos () == MATCH_YES
)
9096 m
= gfc_match_name (name
);
9100 if (find_special (name
, &sym
, true))
9103 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9105 if (gfc_match_eos () == MATCH_YES
)
9108 if (gfc_match_char (',') != MATCH_YES
)
9115 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");