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 "
709 m
= gfc_match_expr (expr
);
712 && !gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
715 if (m
== MATCH_YES
&& (*expr
)->expr_type
== EXPR_FUNCTION
)
717 if ((*expr
)->value
.function
.actual
718 && (*expr
)->value
.function
.actual
->expr
->symtree
)
721 e
= (*expr
)->value
.function
.actual
->expr
;
722 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
723 && e
->expr_type
== EXPR_VARIABLE
)
725 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
727 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
728 && e
->symtree
->n
.sym
->ts
.u
.cl
729 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->ts
.type
== BT_UNKNOWN
)
737 gfc_error ("Conflict in attributes of function argument at %C");
742 /* A character length is a '*' followed by a literal integer or a
743 char_len_param_value in parenthesis. */
746 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
752 m
= gfc_match_char ('*');
756 m
= gfc_match_small_literal_int (&length
, NULL
);
757 if (m
== MATCH_ERROR
)
762 if (obsolescent_check
763 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
765 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
769 if (gfc_match_char ('(') == MATCH_NO
)
772 m
= char_len_param_value (expr
, deferred
);
773 if (m
!= MATCH_YES
&& gfc_matching_function
)
779 if (m
== MATCH_ERROR
)
784 if (gfc_match_char (')') == MATCH_NO
)
786 gfc_free_expr (*expr
);
794 gfc_error ("Syntax error in character length specification at %C");
799 /* Special subroutine for finding a symbol. Check if the name is found
800 in the current name space. If not, and we're compiling a function or
801 subroutine and the parent compilation unit is an interface, then check
802 to see if the name we've been given is the name of the interface
803 (located in another namespace). */
806 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
812 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
815 *result
= st
? st
->n
.sym
: NULL
;
819 if (gfc_current_state () != COMP_SUBROUTINE
820 && gfc_current_state () != COMP_FUNCTION
)
823 s
= gfc_state_stack
->previous
;
827 if (s
->state
!= COMP_INTERFACE
)
830 goto end
; /* Nameless interface. */
832 if (strcmp (name
, s
->sym
->name
) == 0)
843 /* Special subroutine for getting a symbol node associated with a
844 procedure name, used in SUBROUTINE and FUNCTION statements. The
845 symbol is created in the parent using with symtree node in the
846 child unit pointing to the symbol. If the current namespace has no
847 parent, then the symbol is just created in the current unit. */
850 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
856 /* Module functions have to be left in their own namespace because
857 they have potentially (almost certainly!) already been referenced.
858 In this sense, they are rather like external functions. This is
859 fixed up in resolve.c(resolve_entries), where the symbol name-
860 space is set to point to the master function, so that the fake
861 result mechanism can work. */
862 if (module_fcn_entry
)
864 /* Present if entry is declared to be a module procedure. */
865 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
868 rc
= gfc_get_symbol (name
, NULL
, result
);
869 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
870 && (*result
)->ts
.type
== BT_UNKNOWN
871 && sym
->attr
.flavor
== FL_UNKNOWN
)
872 /* Pick up the typespec for the entry, if declared in the function
873 body. Note that this symbol is FL_UNKNOWN because it will
874 only have appeared in a type declaration. The local symtree
875 is set to point to the module symbol and a unique symtree
876 to the local version. This latter ensures a correct clearing
879 /* If the ENTRY proceeds its specification, we need to ensure
880 that this does not raise a "has no IMPLICIT type" error. */
881 if (sym
->ts
.type
== BT_UNKNOWN
)
882 sym
->attr
.untyped
= 1;
884 (*result
)->ts
= sym
->ts
;
886 /* Put the symbol in the procedure namespace so that, should
887 the ENTRY precede its specification, the specification
889 (*result
)->ns
= gfc_current_ns
;
891 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
893 st
= gfc_get_unique_symtree (gfc_current_ns
);
898 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
904 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
907 if (sym
->attr
.module_procedure
908 && sym
->attr
.if_source
== IFSRC_IFBODY
)
910 /* Create a partially populated interface symbol to carry the
911 characteristics of the procedure and the result. */
912 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
913 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
915 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
916 if (sym
->attr
.dimension
)
917 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
919 /* Ideally, at this point, a copy would be made of the formal
920 arguments and their namespace. However, this does not appear
921 to be necessary, albeit at the expense of not being able to
922 use gfc_compare_interfaces directly. */
924 if (sym
->result
&& sym
->result
!= sym
)
926 sym
->ts
.interface
->result
= sym
->result
;
929 else if (sym
->result
)
931 sym
->ts
.interface
->result
= sym
->ts
.interface
;
934 else if (sym
&& !sym
->gfc_new
935 && gfc_current_state () != COMP_INTERFACE
)
937 /* Trap another encompassed procedure with the same name. All
938 these conditions are necessary to avoid picking up an entry
939 whose name clashes with that of the encompassing procedure;
940 this is handled using gsymbols to register unique,globally
942 if (sym
->attr
.flavor
!= 0
943 && sym
->attr
.proc
!= 0
944 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
945 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
946 gfc_error_now ("Procedure %qs at %C is already defined at %L",
947 name
, &sym
->declared_at
);
949 /* Trap a procedure with a name the same as interface in the
950 encompassing scope. */
951 if (sym
->attr
.generic
!= 0
952 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
953 && !sym
->attr
.mod_proc
)
954 gfc_error_now ("Name %qs at %C is already defined"
955 " as a generic interface at %L",
956 name
, &sym
->declared_at
);
958 /* Trap declarations of attributes in encompassing scope. The
959 signature for this is that ts.kind is set. Legitimate
960 references only set ts.type. */
961 if (sym
->ts
.kind
!= 0
962 && !sym
->attr
.implicit_type
963 && sym
->attr
.proc
== 0
964 && gfc_current_ns
->parent
!= NULL
965 && sym
->attr
.access
== 0
966 && !module_fcn_entry
)
967 gfc_error_now ("Procedure %qs at %C has an explicit interface "
968 "and must not have attributes declared at %L",
969 name
, &sym
->declared_at
);
972 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
975 /* Module function entries will already have a symtree in
976 the current namespace but will need one at module level. */
977 if (module_fcn_entry
)
979 /* Present if entry is declared to be a module procedure. */
980 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
982 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
985 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
990 /* See if the procedure should be a module procedure. */
992 if (((sym
->ns
->proc_name
!= NULL
993 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
994 && sym
->attr
.proc
!= PROC_MODULE
)
995 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
996 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1003 /* Verify that the given symbol representing a parameter is C
1004 interoperable, by checking to see if it was marked as such after
1005 its declaration. If the given symbol is not interoperable, a
1006 warning is reported, thus removing the need to return the status to
1007 the calling function. The standard does not require the user use
1008 one of the iso_c_binding named constants to declare an
1009 interoperable parameter, but we can't be sure if the param is C
1010 interop or not if the user doesn't. For example, integer(4) may be
1011 legal Fortran, but doesn't have meaning in C. It may interop with
1012 a number of the C types, which causes a problem because the
1013 compiler can't know which one. This code is almost certainly not
1014 portable, and the user will get what they deserve if the C type
1015 across platforms isn't always interoperable with integer(4). If
1016 the user had used something like integer(c_int) or integer(c_long),
1017 the compiler could have automatically handled the varying sizes
1018 across platforms. */
1021 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1023 int is_c_interop
= 0;
1026 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1027 Don't repeat the checks here. */
1028 if (sym
->attr
.implicit_type
)
1031 /* For subroutines or functions that are passed to a BIND(C) procedure,
1032 they're interoperable if they're BIND(C) and their params are all
1034 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1036 if (sym
->attr
.is_bind_c
== 0)
1038 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1039 "attribute to be C interoperable", sym
->name
,
1040 &(sym
->declared_at
));
1045 if (sym
->attr
.is_c_interop
== 1)
1046 /* We've already checked this procedure; don't check it again. */
1049 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1054 /* See if we've stored a reference to a procedure that owns sym. */
1055 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1057 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1059 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1061 if (is_c_interop
!= 1)
1063 /* Make personalized messages to give better feedback. */
1064 if (sym
->ts
.type
== BT_DERIVED
)
1065 gfc_error ("Variable %qs at %L is a dummy argument to the "
1066 "BIND(C) procedure %qs but is not C interoperable "
1067 "because derived type %qs is not C interoperable",
1068 sym
->name
, &(sym
->declared_at
),
1069 sym
->ns
->proc_name
->name
,
1070 sym
->ts
.u
.derived
->name
);
1071 else if (sym
->ts
.type
== BT_CLASS
)
1072 gfc_error ("Variable %qs at %L is a dummy argument to the "
1073 "BIND(C) procedure %qs but is not C interoperable "
1074 "because it is polymorphic",
1075 sym
->name
, &(sym
->declared_at
),
1076 sym
->ns
->proc_name
->name
);
1077 else if (warn_c_binding_type
)
1078 gfc_warning (OPT_Wc_binding_type
,
1079 "Variable %qs at %L is a dummy argument of the "
1080 "BIND(C) procedure %qs but may not be C "
1082 sym
->name
, &(sym
->declared_at
),
1083 sym
->ns
->proc_name
->name
);
1086 /* Character strings are only C interoperable if they have a
1088 if (sym
->ts
.type
== BT_CHARACTER
)
1090 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1091 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1092 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1094 gfc_error ("Character argument %qs at %L "
1095 "must be length 1 because "
1096 "procedure %qs is BIND(C)",
1097 sym
->name
, &sym
->declared_at
,
1098 sym
->ns
->proc_name
->name
);
1103 /* We have to make sure that any param to a bind(c) routine does
1104 not have the allocatable, pointer, or optional attributes,
1105 according to J3/04-007, section 5.1. */
1106 if (sym
->attr
.allocatable
== 1
1107 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1108 "ALLOCATABLE attribute in procedure %qs "
1109 "with BIND(C)", sym
->name
,
1110 &(sym
->declared_at
),
1111 sym
->ns
->proc_name
->name
))
1114 if (sym
->attr
.pointer
== 1
1115 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1116 "POINTER attribute in procedure %qs "
1117 "with BIND(C)", sym
->name
,
1118 &(sym
->declared_at
),
1119 sym
->ns
->proc_name
->name
))
1122 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1124 gfc_error ("Scalar variable %qs at %L with POINTER or "
1125 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1126 " supported", sym
->name
, &(sym
->declared_at
),
1127 sym
->ns
->proc_name
->name
);
1131 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1133 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1134 "and the VALUE attribute because procedure %qs "
1135 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1136 sym
->ns
->proc_name
->name
);
1139 else if (sym
->attr
.optional
== 1
1140 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1141 "at %L with OPTIONAL attribute in "
1142 "procedure %qs which is BIND(C)",
1143 sym
->name
, &(sym
->declared_at
),
1144 sym
->ns
->proc_name
->name
))
1147 /* Make sure that if it has the dimension attribute, that it is
1148 either assumed size or explicit shape. Deferred shape is already
1149 covered by the pointer/allocatable attribute. */
1150 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1151 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1152 "at %L as dummy argument to the BIND(C) "
1153 "procedure '%s' at %L", sym
->name
,
1154 &(sym
->declared_at
),
1155 sym
->ns
->proc_name
->name
,
1156 &(sym
->ns
->proc_name
->declared_at
)))
1166 /* Function called by variable_decl() that adds a name to the symbol table. */
1169 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1170 gfc_array_spec
**as
, locus
*var_locus
)
1172 symbol_attribute attr
;
1175 if (gfc_get_symbol (name
, NULL
, &sym
))
1178 /* Start updating the symbol table. Add basic type attribute if present. */
1179 if (current_ts
.type
!= BT_UNKNOWN
1180 && (sym
->attr
.implicit_type
== 0
1181 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1182 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1185 if (sym
->ts
.type
== BT_CHARACTER
)
1188 sym
->ts
.deferred
= cl_deferred
;
1191 /* Add dimension attribute if present. */
1192 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1196 /* Add attribute to symbol. The copy is so that we can reset the
1197 dimension attribute. */
1198 attr
= current_attr
;
1200 attr
.codimension
= 0;
1202 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1205 /* Finish any work that may need to be done for the binding label,
1206 if it's a bind(c). The bind(c) attr is found before the symbol
1207 is made, and before the symbol name (for data decls), so the
1208 current_ts is holding the binding label, or nothing if the
1209 name= attr wasn't given. Therefore, test here if we're dealing
1210 with a bind(c) and make sure the binding label is set correctly. */
1211 if (sym
->attr
.is_bind_c
== 1)
1213 if (!sym
->binding_label
)
1215 /* Set the binding label and verify that if a NAME= was specified
1216 then only one identifier was in the entity-decl-list. */
1217 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1218 num_idents_on_line
))
1223 /* See if we know we're in a common block, and if it's a bind(c)
1224 common then we need to make sure we're an interoperable type. */
1225 if (sym
->attr
.in_common
== 1)
1227 /* Test the common block object. */
1228 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1229 && sym
->ts
.is_c_interop
!= 1)
1231 gfc_error_now ("Variable %qs in common block %qs at %C "
1232 "must be declared with a C interoperable "
1233 "kind since common block %qs is BIND(C)",
1234 sym
->name
, sym
->common_block
->name
,
1235 sym
->common_block
->name
);
1240 sym
->attr
.implied_index
= 0;
1242 if (sym
->ts
.type
== BT_CLASS
)
1243 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1249 /* Set character constant to the given length. The constant will be padded or
1250 truncated. If we're inside an array constructor without a typespec, we
1251 additionally check that all elements have the same length; check_len -1
1252 means no checking. */
1255 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1260 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1261 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1263 slen
= expr
->value
.character
.length
;
1266 s
= gfc_get_wide_string (len
+ 1);
1267 memcpy (s
, expr
->value
.character
.string
,
1268 MIN (len
, slen
) * sizeof (gfc_char_t
));
1270 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1272 if (warn_character_truncation
&& slen
> len
)
1273 gfc_warning_now (OPT_Wcharacter_truncation
,
1274 "CHARACTER expression at %L is being truncated "
1275 "(%d/%d)", &expr
->where
, slen
, len
);
1277 /* Apply the standard by 'hand' otherwise it gets cleared for
1279 if (check_len
!= -1 && slen
!= check_len
1280 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1281 gfc_error_now ("The CHARACTER elements of the array constructor "
1282 "at %L must have the same length (%d/%d)",
1283 &expr
->where
, slen
, check_len
);
1286 free (expr
->value
.character
.string
);
1287 expr
->value
.character
.string
= s
;
1288 expr
->value
.character
.length
= len
;
1293 /* Function to create and update the enumerator history
1294 using the information passed as arguments.
1295 Pointer "max_enum" is also updated, to point to
1296 enum history node containing largest initializer.
1298 SYM points to the symbol node of enumerator.
1299 INIT points to its enumerator value. */
1302 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1304 enumerator_history
*new_enum_history
;
1305 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1307 new_enum_history
= XCNEW (enumerator_history
);
1309 new_enum_history
->sym
= sym
;
1310 new_enum_history
->initializer
= init
;
1311 new_enum_history
->next
= NULL
;
1313 if (enum_history
== NULL
)
1315 enum_history
= new_enum_history
;
1316 max_enum
= enum_history
;
1320 new_enum_history
->next
= enum_history
;
1321 enum_history
= new_enum_history
;
1323 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1324 new_enum_history
->initializer
->value
.integer
) < 0)
1325 max_enum
= new_enum_history
;
1330 /* Function to free enum kind history. */
1333 gfc_free_enum_history (void)
1335 enumerator_history
*current
= enum_history
;
1336 enumerator_history
*next
;
1338 while (current
!= NULL
)
1340 next
= current
->next
;
1345 enum_history
= NULL
;
1349 /* Function called by variable_decl() that adds an initialization
1350 expression to a symbol. */
1353 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1355 symbol_attribute attr
;
1360 if (find_special (name
, &sym
, false))
1365 /* If this symbol is confirming an implicit parameter type,
1366 then an initialization expression is not allowed. */
1367 if (attr
.flavor
== FL_PARAMETER
1368 && sym
->value
!= NULL
1371 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1378 /* An initializer is required for PARAMETER declarations. */
1379 if (attr
.flavor
== FL_PARAMETER
)
1381 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1387 /* If a variable appears in a DATA block, it cannot have an
1391 gfc_error ("Variable %qs at %C with an initializer already "
1392 "appears in a DATA statement", sym
->name
);
1396 /* Check if the assignment can happen. This has to be put off
1397 until later for derived type variables and procedure pointers. */
1398 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1399 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1400 && !sym
->attr
.proc_pointer
1401 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1404 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1405 && init
->ts
.type
== BT_CHARACTER
)
1407 /* Update symbol character length according initializer. */
1408 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1411 if (sym
->ts
.u
.cl
->length
== NULL
)
1414 /* If there are multiple CHARACTER variables declared on the
1415 same line, we don't want them to share the same length. */
1416 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1418 if (sym
->attr
.flavor
== FL_PARAMETER
)
1420 if (init
->expr_type
== EXPR_CONSTANT
)
1422 clen
= init
->value
.character
.length
;
1423 sym
->ts
.u
.cl
->length
1424 = gfc_get_int_expr (gfc_default_integer_kind
,
1427 else if (init
->expr_type
== EXPR_ARRAY
)
1429 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1430 sym
->ts
.u
.cl
->length
1431 = gfc_get_int_expr (gfc_default_integer_kind
,
1434 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1435 sym
->ts
.u
.cl
->length
=
1436 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1439 /* Update initializer character length according symbol. */
1440 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1444 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1447 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1449 if (init
->expr_type
== EXPR_CONSTANT
)
1450 gfc_set_constant_character_len (len
, init
, -1);
1451 else if (init
->expr_type
== EXPR_ARRAY
)
1455 /* Build a new charlen to prevent simplification from
1456 deleting the length before it is resolved. */
1457 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1458 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1460 for (c
= gfc_constructor_first (init
->value
.constructor
);
1461 c
; c
= gfc_constructor_next (c
))
1462 gfc_set_constant_character_len (len
, c
->expr
, -1);
1467 /* If sym is implied-shape, set its upper bounds from init. */
1468 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1469 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1473 if (init
->rank
== 0)
1475 gfc_error ("Can't initialize implied-shape array at %L"
1476 " with scalar", &sym
->declared_at
);
1479 gcc_assert (sym
->as
->rank
== init
->rank
);
1481 /* Shape should be present, we get an initialization expression. */
1482 gcc_assert (init
->shape
);
1484 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1490 lower
= sym
->as
->lower
[dim
];
1491 if (lower
->expr_type
!= EXPR_CONSTANT
)
1493 gfc_error ("Non-constant lower bound in implied-shape"
1494 " declaration at %L", &lower
->where
);
1498 /* All dimensions must be without upper bound. */
1499 gcc_assert (!sym
->as
->upper
[dim
]);
1502 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1503 mpz_add (e
->value
.integer
,
1504 lower
->value
.integer
, init
->shape
[dim
]);
1505 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1506 sym
->as
->upper
[dim
] = e
;
1509 sym
->as
->type
= AS_EXPLICIT
;
1512 /* Need to check if the expression we initialized this
1513 to was one of the iso_c_binding named constants. If so,
1514 and we're a parameter (constant), let it be iso_c.
1516 integer(c_int), parameter :: my_int = c_int
1517 integer(my_int) :: my_int_2
1518 If we mark my_int as iso_c (since we can see it's value
1519 is equal to one of the named constants), then my_int_2
1520 will be considered C interoperable. */
1521 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1523 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1524 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1525 /* attr bits needed for module files. */
1526 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1527 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1528 if (init
->ts
.is_iso_c
)
1529 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1532 /* Add initializer. Make sure we keep the ranks sane. */
1533 if (sym
->attr
.dimension
&& init
->rank
== 0)
1538 if (sym
->attr
.flavor
== FL_PARAMETER
1539 && init
->expr_type
== EXPR_CONSTANT
1540 && spec_size (sym
->as
, &size
)
1541 && mpz_cmp_si (size
, 0) > 0)
1543 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1545 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1546 gfc_constructor_append_expr (&array
->value
.constructor
,
1549 : gfc_copy_expr (init
),
1552 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1553 for (n
= 0; n
< sym
->as
->rank
; n
++)
1554 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1559 init
->rank
= sym
->as
->rank
;
1563 if (sym
->attr
.save
== SAVE_NONE
)
1564 sym
->attr
.save
= SAVE_IMPLICIT
;
1572 /* Function called by variable_decl() that adds a name to a structure
1576 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1577 gfc_array_spec
**as
)
1582 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1583 constructing, it must have the pointer attribute. */
1584 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1585 && current_ts
.u
.derived
== gfc_current_block ()
1586 && current_attr
.pointer
== 0)
1588 gfc_error ("Component at %C must have the POINTER attribute");
1592 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1594 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1596 gfc_error ("Array component of structure at %C must have explicit "
1597 "or deferred shape");
1602 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1606 if (c
->ts
.type
== BT_CHARACTER
)
1608 c
->attr
= current_attr
;
1610 c
->initializer
= *init
;
1617 c
->attr
.codimension
= 1;
1619 c
->attr
.dimension
= 1;
1623 /* Should this ever get more complicated, combine with similar section
1624 in add_init_expr_to_sym into a separate function. */
1625 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1627 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1631 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1632 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1633 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1635 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1637 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1638 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1639 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1640 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1642 gfc_constructor
*ctor
;
1643 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1648 bool has_ts
= (c
->initializer
->ts
.u
.cl
1649 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1651 /* Remember the length of the first element for checking
1652 that all elements *in the constructor* have the same
1653 length. This need not be the length of the LHS! */
1654 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1655 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1656 first_len
= ctor
->expr
->value
.character
.length
;
1658 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1659 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1661 gfc_set_constant_character_len (len
, ctor
->expr
,
1662 has_ts
? -1 : first_len
);
1663 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1669 /* Check array components. */
1670 if (!c
->attr
.dimension
)
1673 if (c
->attr
.pointer
)
1675 if (c
->as
->type
!= AS_DEFERRED
)
1677 gfc_error ("Pointer array component of structure at %C must have a "
1682 else if (c
->attr
.allocatable
)
1684 if (c
->as
->type
!= AS_DEFERRED
)
1686 gfc_error ("Allocatable component of structure at %C must have a "
1693 if (c
->as
->type
!= AS_EXPLICIT
)
1695 gfc_error ("Array component of structure at %C must have an "
1702 if (c
->ts
.type
== BT_CLASS
)
1704 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1714 /* Match a 'NULL()', and possibly take care of some side effects. */
1717 gfc_match_null (gfc_expr
**result
)
1720 match m
, m2
= MATCH_NO
;
1722 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1728 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1730 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1733 old_loc
= gfc_current_locus
;
1734 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1737 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1741 gfc_current_locus
= old_loc
;
1746 /* The NULL symbol now has to be/become an intrinsic function. */
1747 if (gfc_get_symbol ("null", NULL
, &sym
))
1749 gfc_error ("NULL() initialization at %C is ambiguous");
1753 gfc_intrinsic_symbol (sym
);
1755 if (sym
->attr
.proc
!= PROC_INTRINSIC
1756 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1757 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1758 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1761 *result
= gfc_get_null_expr (&gfc_current_locus
);
1763 /* Invalid per F2008, C512. */
1764 if (m2
== MATCH_YES
)
1766 gfc_error ("NULL() initialization at %C may not have MOLD");
1774 /* Match the initialization expr for a data pointer or procedure pointer. */
1777 match_pointer_init (gfc_expr
**init
, int procptr
)
1781 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1783 gfc_error ("Initialization of pointer at %C is not allowed in "
1784 "a PURE procedure");
1787 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1789 /* Match NULL() initialization. */
1790 m
= gfc_match_null (init
);
1794 /* Match non-NULL initialization. */
1795 gfc_matching_ptr_assignment
= !procptr
;
1796 gfc_matching_procptr_assignment
= procptr
;
1797 m
= gfc_match_rvalue (init
);
1798 gfc_matching_ptr_assignment
= 0;
1799 gfc_matching_procptr_assignment
= 0;
1800 if (m
== MATCH_ERROR
)
1802 else if (m
== MATCH_NO
)
1804 gfc_error ("Error in pointer initialization at %C");
1808 if (!procptr
&& !gfc_resolve_expr (*init
))
1811 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1812 "initialization at %C"))
1820 check_function_name (char *name
)
1822 /* In functions that have a RESULT variable defined, the function name always
1823 refers to function calls. Therefore, the name is not allowed to appear in
1824 specification statements. When checking this, be careful about
1825 'hidden' procedure pointer results ('ppr@'). */
1827 if (gfc_current_state () == COMP_FUNCTION
)
1829 gfc_symbol
*block
= gfc_current_block ();
1830 if (block
&& block
->result
&& block
->result
!= block
1831 && strcmp (block
->result
->name
, "ppr@") != 0
1832 && strcmp (block
->name
, name
) == 0)
1834 gfc_error ("Function name %qs not allowed at %C", name
);
1843 /* Match a variable name with an optional initializer. When this
1844 subroutine is called, a variable is expected to be parsed next.
1845 Depending on what is happening at the moment, updates either the
1846 symbol table or the current interface. */
1849 variable_decl (int elem
)
1851 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1852 gfc_expr
*initializer
, *char_len
;
1854 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1866 /* When we get here, we've just matched a list of attributes and
1867 maybe a type and a double colon. The next thing we expect to see
1868 is the name of the symbol. */
1869 m
= gfc_match_name (name
);
1873 var_locus
= gfc_current_locus
;
1875 /* Now we could see the optional array spec. or character length. */
1876 m
= gfc_match_array_spec (&as
, true, true);
1877 if (m
== MATCH_ERROR
)
1881 as
= gfc_copy_array_spec (current_as
);
1883 && !merge_array_spec (current_as
, as
, true))
1889 if (flag_cray_pointer
)
1890 cp_as
= gfc_copy_array_spec (as
);
1892 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1893 determine (and check) whether it can be implied-shape. If it
1894 was parsed as assumed-size, change it because PARAMETERs can not
1898 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1901 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1906 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1907 && current_attr
.flavor
== FL_PARAMETER
)
1908 as
->type
= AS_IMPLIED_SHAPE
;
1910 if (as
->type
== AS_IMPLIED_SHAPE
1911 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1921 cl_deferred
= false;
1923 if (current_ts
.type
== BT_CHARACTER
)
1925 switch (match_char_length (&char_len
, &cl_deferred
, false))
1928 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1930 cl
->length
= char_len
;
1933 /* Non-constant lengths need to be copied after the first
1934 element. Also copy assumed lengths. */
1937 && (current_ts
.u
.cl
->length
== NULL
1938 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1940 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1941 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1944 cl
= current_ts
.u
.cl
;
1946 cl_deferred
= current_ts
.deferred
;
1955 /* The dummy arguments and result of the abreviated form of MODULE
1956 PROCEDUREs, used in SUBMODULES should not be redefined. */
1957 if (gfc_current_ns
->proc_name
1958 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
1960 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1961 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
1964 gfc_error ("'%s' at %C is a redefinition of the declaration "
1965 "in the corresponding interface for MODULE "
1966 "PROCEDURE '%s'", sym
->name
,
1967 gfc_current_ns
->proc_name
->name
);
1972 /* If this symbol has already shown up in a Cray Pointer declaration,
1973 and this is not a component declaration,
1974 then we want to set the type & bail out. */
1975 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
1977 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1978 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1980 sym
->ts
.type
= current_ts
.type
;
1981 sym
->ts
.kind
= current_ts
.kind
;
1983 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1984 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1985 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1988 /* Check to see if we have an array specification. */
1991 if (sym
->as
!= NULL
)
1993 gfc_error ("Duplicate array spec for Cray pointee at %C");
1994 gfc_free_array_spec (cp_as
);
2000 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2001 gfc_internal_error ("Couldn't set pointee array spec.");
2003 /* Fix the array spec. */
2004 m
= gfc_mod_pointee_as (sym
->as
);
2005 if (m
== MATCH_ERROR
)
2013 gfc_free_array_spec (cp_as
);
2017 /* Procedure pointer as function result. */
2018 if (gfc_current_state () == COMP_FUNCTION
2019 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2020 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2021 strcpy (name
, "ppr@");
2023 if (gfc_current_state () == COMP_FUNCTION
2024 && strcmp (name
, gfc_current_block ()->name
) == 0
2025 && gfc_current_block ()->result
2026 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2027 strcpy (name
, "ppr@");
2029 /* OK, we've successfully matched the declaration. Now put the
2030 symbol in the current namespace, because it might be used in the
2031 optional initialization expression for this symbol, e.g. this is
2034 integer, parameter :: i = huge(i)
2036 This is only true for parameters or variables of a basic type.
2037 For components of derived types, it is not true, so we don't
2038 create a symbol for those yet. If we fail to create the symbol,
2040 if (gfc_current_state () != COMP_DERIVED
2041 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2047 if (!check_function_name (name
))
2053 /* We allow old-style initializations of the form
2054 integer i /2/, j(4) /3*3, 1/
2055 (if no colon has been seen). These are different from data
2056 statements in that initializers are only allowed to apply to the
2057 variable immediately preceding, i.e.
2059 is not allowed. Therefore we have to do some work manually, that
2060 could otherwise be left to the matchers for DATA statements. */
2062 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2064 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2065 "initialization at %C"))
2067 else if (gfc_current_state () == COMP_DERIVED
)
2069 gfc_error ("Invalid old style initialization for derived type "
2075 return match_old_style_init (name
);
2078 /* The double colon must be present in order to have initializers.
2079 Otherwise the statement is ambiguous with an assignment statement. */
2082 if (gfc_match (" =>") == MATCH_YES
)
2084 if (!current_attr
.pointer
)
2086 gfc_error ("Initialization at %C isn't for a pointer variable");
2091 m
= match_pointer_init (&initializer
, 0);
2095 else if (gfc_match_char ('=') == MATCH_YES
)
2097 if (current_attr
.pointer
)
2099 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2105 m
= gfc_match_init_expr (&initializer
);
2108 gfc_error ("Expected an initialization expression at %C");
2112 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2113 && gfc_state_stack
->state
!= COMP_DERIVED
)
2115 gfc_error ("Initialization of variable at %C is not allowed in "
2116 "a PURE procedure");
2120 if (current_attr
.flavor
!= FL_PARAMETER
2121 && gfc_state_stack
->state
!= COMP_DERIVED
)
2122 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2129 if (initializer
!= NULL
&& current_attr
.allocatable
2130 && gfc_current_state () == COMP_DERIVED
)
2132 gfc_error ("Initialization of allocatable component at %C is not "
2138 /* Add the initializer. Note that it is fine if initializer is
2139 NULL here, because we sometimes also need to check if a
2140 declaration *must* have an initialization expression. */
2141 if (gfc_current_state () != COMP_DERIVED
)
2142 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2145 if (current_ts
.type
== BT_DERIVED
2146 && !current_attr
.pointer
&& !initializer
)
2147 initializer
= gfc_default_initializer (¤t_ts
);
2148 t
= build_struct (name
, cl
, &initializer
, &as
);
2151 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2154 /* Free stuff up and return. */
2155 gfc_free_expr (initializer
);
2156 gfc_free_array_spec (as
);
2162 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2163 This assumes that the byte size is equal to the kind number for
2164 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2167 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2172 if (gfc_match_char ('*') != MATCH_YES
)
2175 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2179 original_kind
= ts
->kind
;
2181 /* Massage the kind numbers for complex types. */
2182 if (ts
->type
== BT_COMPLEX
)
2186 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2187 gfc_basic_typename (ts
->type
), original_kind
);
2194 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2197 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2201 if (flag_real4_kind
== 8)
2203 if (flag_real4_kind
== 10)
2205 if (flag_real4_kind
== 16)
2211 if (flag_real8_kind
== 4)
2213 if (flag_real8_kind
== 10)
2215 if (flag_real8_kind
== 16)
2220 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2222 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2223 gfc_basic_typename (ts
->type
), original_kind
);
2227 if (!gfc_notify_std (GFC_STD_GNU
,
2228 "Nonstandard type declaration %s*%d at %C",
2229 gfc_basic_typename(ts
->type
), original_kind
))
2236 /* Match a kind specification. Since kinds are generally optional, we
2237 usually return MATCH_NO if something goes wrong. If a "kind="
2238 string is found, then we know we have an error. */
2241 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2253 where
= loc
= gfc_current_locus
;
2258 if (gfc_match_char ('(') == MATCH_NO
)
2261 /* Also gobbles optional text. */
2262 if (gfc_match (" kind = ") == MATCH_YES
)
2265 loc
= gfc_current_locus
;
2268 n
= gfc_match_init_expr (&e
);
2272 if (gfc_matching_function
)
2274 /* The function kind expression might include use associated or
2275 imported parameters and try again after the specification
2277 if (gfc_match_char (')') != MATCH_YES
)
2279 gfc_error ("Missing right parenthesis at %C");
2285 gfc_undo_symbols ();
2290 /* ....or else, the match is real. */
2292 gfc_error ("Expected initialization expression at %C");
2300 gfc_error ("Expected scalar initialization expression at %C");
2305 msg
= gfc_extract_int (e
, &ts
->kind
);
2314 /* Before throwing away the expression, let's see if we had a
2315 C interoperable kind (and store the fact). */
2316 if (e
->ts
.is_c_interop
== 1)
2318 /* Mark this as C interoperable if being declared with one
2319 of the named constants from iso_c_binding. */
2320 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2321 ts
->f90_type
= e
->ts
.f90_type
;
2327 /* Ignore errors to this point, if we've gotten here. This means
2328 we ignore the m=MATCH_ERROR from above. */
2329 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2331 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2332 gfc_basic_typename (ts
->type
));
2333 gfc_current_locus
= where
;
2337 /* Warn if, e.g., c_int is used for a REAL variable, but not
2338 if, e.g., c_double is used for COMPLEX as the standard
2339 explicitly says that the kind type parameter for complex and real
2340 variable is the same, i.e. c_float == c_float_complex. */
2341 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2342 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2343 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2344 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2345 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2346 gfc_basic_typename (ts
->type
));
2348 gfc_gobble_whitespace ();
2349 if ((c
= gfc_next_ascii_char ()) != ')'
2350 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2352 if (ts
->type
== BT_CHARACTER
)
2353 gfc_error ("Missing right parenthesis or comma at %C");
2355 gfc_error ("Missing right parenthesis at %C");
2359 /* All tests passed. */
2362 if(m
== MATCH_ERROR
)
2363 gfc_current_locus
= where
;
2365 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2368 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2372 if (flag_real4_kind
== 8)
2374 if (flag_real4_kind
== 10)
2376 if (flag_real4_kind
== 16)
2382 if (flag_real8_kind
== 4)
2384 if (flag_real8_kind
== 10)
2386 if (flag_real8_kind
== 16)
2391 /* Return what we know from the test(s). */
2396 gfc_current_locus
= where
;
2402 match_char_kind (int * kind
, int * is_iso_c
)
2411 where
= gfc_current_locus
;
2413 n
= gfc_match_init_expr (&e
);
2415 if (n
!= MATCH_YES
&& gfc_matching_function
)
2417 /* The expression might include use-associated or imported
2418 parameters and try again after the specification
2421 gfc_undo_symbols ();
2426 gfc_error ("Expected initialization expression at %C");
2432 gfc_error ("Expected scalar initialization expression at %C");
2437 msg
= gfc_extract_int (e
, kind
);
2438 *is_iso_c
= e
->ts
.is_iso_c
;
2448 /* Ignore errors to this point, if we've gotten here. This means
2449 we ignore the m=MATCH_ERROR from above. */
2450 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2452 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2456 /* All tests passed. */
2459 if (m
== MATCH_ERROR
)
2460 gfc_current_locus
= where
;
2462 /* Return what we know from the test(s). */
2467 gfc_current_locus
= where
;
2472 /* Match the various kind/length specifications in a CHARACTER
2473 declaration. We don't return MATCH_NO. */
2476 gfc_match_char_spec (gfc_typespec
*ts
)
2478 int kind
, seen_length
, is_iso_c
;
2490 /* Try the old-style specification first. */
2491 old_char_selector
= 0;
2493 m
= match_char_length (&len
, &deferred
, true);
2497 old_char_selector
= 1;
2502 m
= gfc_match_char ('(');
2505 m
= MATCH_YES
; /* Character without length is a single char. */
2509 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2510 if (gfc_match (" kind =") == MATCH_YES
)
2512 m
= match_char_kind (&kind
, &is_iso_c
);
2514 if (m
== MATCH_ERROR
)
2519 if (gfc_match (" , len =") == MATCH_NO
)
2522 m
= char_len_param_value (&len
, &deferred
);
2525 if (m
== MATCH_ERROR
)
2532 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2533 if (gfc_match (" len =") == MATCH_YES
)
2535 m
= char_len_param_value (&len
, &deferred
);
2538 if (m
== MATCH_ERROR
)
2542 if (gfc_match_char (')') == MATCH_YES
)
2545 if (gfc_match (" , kind =") != MATCH_YES
)
2548 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2554 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2555 m
= char_len_param_value (&len
, &deferred
);
2558 if (m
== MATCH_ERROR
)
2562 m
= gfc_match_char (')');
2566 if (gfc_match_char (',') != MATCH_YES
)
2569 gfc_match (" kind ="); /* Gobble optional text. */
2571 m
= match_char_kind (&kind
, &is_iso_c
);
2572 if (m
== MATCH_ERROR
)
2578 /* Require a right-paren at this point. */
2579 m
= gfc_match_char (')');
2584 gfc_error ("Syntax error in CHARACTER declaration at %C");
2586 gfc_free_expr (len
);
2590 /* Deal with character functions after USE and IMPORT statements. */
2591 if (gfc_matching_function
)
2593 gfc_free_expr (len
);
2594 gfc_undo_symbols ();
2600 gfc_free_expr (len
);
2604 /* Do some final massaging of the length values. */
2605 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2607 if (seen_length
== 0)
2608 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2613 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2614 ts
->deferred
= deferred
;
2616 /* We have to know if it was a C interoperable kind so we can
2617 do accurate type checking of bind(c) procs, etc. */
2619 /* Mark this as C interoperable if being declared with one
2620 of the named constants from iso_c_binding. */
2621 ts
->is_c_interop
= is_iso_c
;
2622 else if (len
!= NULL
)
2623 /* Here, we might have parsed something such as: character(c_char)
2624 In this case, the parsing code above grabs the c_char when
2625 looking for the length (line 1690, roughly). it's the last
2626 testcase for parsing the kind params of a character variable.
2627 However, it's not actually the length. this seems like it
2629 To see if the user used a C interop kind, test the expr
2630 of the so called length, and see if it's C interoperable. */
2631 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2637 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2638 structure to the matched specification. This is necessary for FUNCTION and
2639 IMPLICIT statements.
2641 If implicit_flag is nonzero, then we don't check for the optional
2642 kind specification. Not doing so is needed for matching an IMPLICIT
2643 statement correctly. */
2646 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2648 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2649 gfc_symbol
*sym
, *dt_sym
;
2652 bool seen_deferred_kind
, matched_type
;
2653 const char *dt_name
;
2655 /* A belt and braces check that the typespec is correctly being treated
2656 as a deferred characteristic association. */
2657 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2658 && (gfc_current_block ()->result
->ts
.kind
== -1)
2659 && (ts
->kind
== -1);
2661 if (seen_deferred_kind
)
2664 /* Clear the current binding label, in case one is given. */
2665 curr_binding_label
= NULL
;
2667 if (gfc_match (" byte") == MATCH_YES
)
2669 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2672 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2674 gfc_error ("BYTE type used at %C "
2675 "is not available on the target machine");
2679 ts
->type
= BT_INTEGER
;
2685 m
= gfc_match (" type (");
2686 matched_type
= (m
== MATCH_YES
);
2689 gfc_gobble_whitespace ();
2690 if (gfc_peek_ascii_char () == '*')
2692 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2694 if (gfc_current_state () == COMP_DERIVED
)
2696 gfc_error ("Assumed type at %C is not allowed for components");
2699 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2702 ts
->type
= BT_ASSUMED
;
2706 m
= gfc_match ("%n", name
);
2707 matched_type
= (m
== MATCH_YES
);
2710 if ((matched_type
&& strcmp ("integer", name
) == 0)
2711 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2713 ts
->type
= BT_INTEGER
;
2714 ts
->kind
= gfc_default_integer_kind
;
2718 if ((matched_type
&& strcmp ("character", name
) == 0)
2719 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2722 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2723 "intrinsic-type-spec at %C"))
2726 ts
->type
= BT_CHARACTER
;
2727 if (implicit_flag
== 0)
2728 m
= gfc_match_char_spec (ts
);
2732 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2738 if ((matched_type
&& strcmp ("real", name
) == 0)
2739 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2742 ts
->kind
= gfc_default_real_kind
;
2747 && (strcmp ("doubleprecision", name
) == 0
2748 || (strcmp ("double", name
) == 0
2749 && gfc_match (" precision") == MATCH_YES
)))
2750 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2753 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2754 "intrinsic-type-spec at %C"))
2756 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2760 ts
->kind
= gfc_default_double_kind
;
2764 if ((matched_type
&& strcmp ("complex", name
) == 0)
2765 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2767 ts
->type
= BT_COMPLEX
;
2768 ts
->kind
= gfc_default_complex_kind
;
2773 && (strcmp ("doublecomplex", name
) == 0
2774 || (strcmp ("double", name
) == 0
2775 && gfc_match (" complex") == MATCH_YES
)))
2776 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2778 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2782 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2783 "intrinsic-type-spec at %C"))
2786 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2789 ts
->type
= BT_COMPLEX
;
2790 ts
->kind
= gfc_default_double_kind
;
2794 if ((matched_type
&& strcmp ("logical", name
) == 0)
2795 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2797 ts
->type
= BT_LOGICAL
;
2798 ts
->kind
= gfc_default_logical_kind
;
2803 m
= gfc_match_char (')');
2806 ts
->type
= BT_DERIVED
;
2809 /* Match CLASS declarations. */
2810 m
= gfc_match (" class ( * )");
2811 if (m
== MATCH_ERROR
)
2813 else if (m
== MATCH_YES
)
2817 ts
->type
= BT_CLASS
;
2818 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2821 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2822 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2824 gfc_set_sym_referenced (upe
);
2826 upe
->ts
.type
= BT_VOID
;
2827 upe
->attr
.unlimited_polymorphic
= 1;
2828 /* This is essential to force the construction of
2829 unlimited polymorphic component class containers. */
2830 upe
->attr
.zero_comp
= 1;
2831 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2832 &gfc_current_locus
))
2837 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2839 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2843 ts
->u
.derived
= upe
;
2847 m
= gfc_match (" class ( %n )", name
);
2850 ts
->type
= BT_CLASS
;
2852 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2856 /* Defer association of the derived type until the end of the
2857 specification block. However, if the derived type can be
2858 found, add it to the typespec. */
2859 if (gfc_matching_function
)
2861 ts
->u
.derived
= NULL
;
2862 if (gfc_current_state () != COMP_INTERFACE
2863 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2865 sym
= gfc_find_dt_in_generic (sym
);
2866 ts
->u
.derived
= sym
;
2871 /* Search for the name but allow the components to be defined later. If
2872 type = -1, this typespec has been seen in a function declaration but
2873 the type could not be accessed at that point. The actual derived type is
2874 stored in a symtree with the first letter of the name capitalized; the
2875 symtree with the all lower-case name contains the associated
2876 generic function. */
2877 dt_name
= gfc_get_string ("%c%s",
2878 (char) TOUPPER ((unsigned char) name
[0]),
2879 (const char*)&name
[1]);
2884 gfc_get_ha_symbol (name
, &sym
);
2885 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2887 gfc_error ("Type name %qs at %C is ambiguous", name
);
2890 if (sym
->generic
&& !dt_sym
)
2891 dt_sym
= gfc_find_dt_in_generic (sym
);
2893 else if (ts
->kind
== -1)
2895 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2896 || gfc_current_ns
->has_import_set
;
2897 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2898 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2900 gfc_error ("Type name %qs at %C is ambiguous", name
);
2903 if (sym
&& sym
->generic
&& !dt_sym
)
2904 dt_sym
= gfc_find_dt_in_generic (sym
);
2911 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2912 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2913 || sym
->attr
.subroutine
)
2915 gfc_error ("Type name %qs at %C conflicts with previously declared "
2916 "entity at %L, which has the same name", name
,
2921 gfc_save_symbol_data (sym
);
2922 gfc_set_sym_referenced (sym
);
2923 if (!sym
->attr
.generic
2924 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2927 if (!sym
->attr
.function
2928 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2933 gfc_interface
*intr
, *head
;
2935 /* Use upper case to save the actual derived-type symbol. */
2936 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2937 dt_sym
->name
= gfc_get_string (sym
->name
);
2938 head
= sym
->generic
;
2939 intr
= gfc_get_interface ();
2941 intr
->where
= gfc_current_locus
;
2943 sym
->generic
= intr
;
2944 sym
->attr
.if_source
= IFSRC_DECL
;
2947 gfc_save_symbol_data (dt_sym
);
2949 gfc_set_sym_referenced (dt_sym
);
2951 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2952 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2955 ts
->u
.derived
= dt_sym
;
2961 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2962 "intrinsic-type-spec at %C"))
2965 /* For all types except double, derived and character, look for an
2966 optional kind specifier. MATCH_NO is actually OK at this point. */
2967 if (implicit_flag
== 1)
2969 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2975 if (gfc_current_form
== FORM_FREE
)
2977 c
= gfc_peek_ascii_char ();
2978 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2979 && c
!= ':' && c
!= ',')
2981 if (matched_type
&& c
== ')')
2983 gfc_next_ascii_char ();
2990 m
= gfc_match_kind_spec (ts
, false);
2991 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2992 m
= gfc_match_old_kind_spec (ts
);
2994 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2997 /* Defer association of the KIND expression of function results
2998 until after USE and IMPORT statements. */
2999 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3000 || gfc_matching_function
)
3004 m
= MATCH_YES
; /* No kind specifier found. */
3010 /* Match an IMPLICIT NONE statement. Actually, this statement is
3011 already matched in parse.c, or we would not end up here in the
3012 first place. So the only thing we need to check, is if there is
3013 trailing garbage. If not, the match is successful. */
3016 gfc_match_implicit_none (void)
3020 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3022 bool external
= false;
3023 locus cur_loc
= gfc_current_locus
;
3025 if (gfc_current_ns
->seen_implicit_none
3026 || gfc_current_ns
->has_implicit_none_export
)
3028 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3032 gfc_gobble_whitespace ();
3033 c
= gfc_peek_ascii_char ();
3036 (void) gfc_next_ascii_char ();
3037 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3040 gfc_gobble_whitespace ();
3041 if (gfc_peek_ascii_char () == ')')
3043 (void) gfc_next_ascii_char ();
3049 m
= gfc_match (" %n", name
);
3053 if (strcmp (name
, "type") == 0)
3055 else if (strcmp (name
, "external") == 0)
3060 gfc_gobble_whitespace ();
3061 c
= gfc_next_ascii_char ();
3072 if (gfc_match_eos () != MATCH_YES
)
3075 gfc_set_implicit_none (type
, external
, &cur_loc
);
3081 /* Match the letter range(s) of an IMPLICIT statement. */
3084 match_implicit_range (void)
3090 cur_loc
= gfc_current_locus
;
3092 gfc_gobble_whitespace ();
3093 c
= gfc_next_ascii_char ();
3096 gfc_error ("Missing character range in IMPLICIT at %C");
3103 gfc_gobble_whitespace ();
3104 c1
= gfc_next_ascii_char ();
3108 gfc_gobble_whitespace ();
3109 c
= gfc_next_ascii_char ();
3114 inner
= 0; /* Fall through. */
3121 gfc_gobble_whitespace ();
3122 c2
= gfc_next_ascii_char ();
3126 gfc_gobble_whitespace ();
3127 c
= gfc_next_ascii_char ();
3129 if ((c
!= ',') && (c
!= ')'))
3142 gfc_error ("Letters must be in alphabetic order in "
3143 "IMPLICIT statement at %C");
3147 /* See if we can add the newly matched range to the pending
3148 implicits from this IMPLICIT statement. We do not check for
3149 conflicts with whatever earlier IMPLICIT statements may have
3150 set. This is done when we've successfully finished matching
3152 if (!gfc_add_new_implicit_range (c1
, c2
))
3159 gfc_syntax_error (ST_IMPLICIT
);
3161 gfc_current_locus
= cur_loc
;
3166 /* Match an IMPLICIT statement, storing the types for
3167 gfc_set_implicit() if the statement is accepted by the parser.
3168 There is a strange looking, but legal syntactic construction
3169 possible. It looks like:
3171 IMPLICIT INTEGER (a-b) (c-d)
3173 This is legal if "a-b" is a constant expression that happens to
3174 equal one of the legal kinds for integers. The real problem
3175 happens with an implicit specification that looks like:
3177 IMPLICIT INTEGER (a-b)
3179 In this case, a typespec matcher that is "greedy" (as most of the
3180 matchers are) gobbles the character range as a kindspec, leaving
3181 nothing left. We therefore have to go a bit more slowly in the
3182 matching process by inhibiting the kindspec checking during
3183 typespec matching and checking for a kind later. */
3186 gfc_match_implicit (void)
3193 if (gfc_current_ns
->seen_implicit_none
)
3195 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3202 /* We don't allow empty implicit statements. */
3203 if (gfc_match_eos () == MATCH_YES
)
3205 gfc_error ("Empty IMPLICIT statement at %C");
3211 /* First cleanup. */
3212 gfc_clear_new_implicit ();
3214 /* A basic type is mandatory here. */
3215 m
= gfc_match_decl_type_spec (&ts
, 1);
3216 if (m
== MATCH_ERROR
)
3221 cur_loc
= gfc_current_locus
;
3222 m
= match_implicit_range ();
3226 /* We may have <TYPE> (<RANGE>). */
3227 gfc_gobble_whitespace ();
3228 c
= gfc_peek_ascii_char ();
3229 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3231 /* Check for CHARACTER with no length parameter. */
3232 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3234 ts
.kind
= gfc_default_character_kind
;
3235 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3236 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3240 /* Record the Successful match. */
3241 if (!gfc_merge_new_implicit (&ts
))
3244 c
= gfc_next_ascii_char ();
3245 else if (gfc_match_eos () == MATCH_ERROR
)
3250 gfc_current_locus
= cur_loc
;
3253 /* Discard the (incorrectly) matched range. */
3254 gfc_clear_new_implicit ();
3256 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3257 if (ts
.type
== BT_CHARACTER
)
3258 m
= gfc_match_char_spec (&ts
);
3261 m
= gfc_match_kind_spec (&ts
, false);
3264 m
= gfc_match_old_kind_spec (&ts
);
3265 if (m
== MATCH_ERROR
)
3271 if (m
== MATCH_ERROR
)
3274 m
= match_implicit_range ();
3275 if (m
== MATCH_ERROR
)
3280 gfc_gobble_whitespace ();
3281 c
= gfc_next_ascii_char ();
3282 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3285 if (!gfc_merge_new_implicit (&ts
))
3293 gfc_syntax_error (ST_IMPLICIT
);
3301 gfc_match_import (void)
3303 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3308 if (gfc_current_ns
->proc_name
== NULL
3309 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3311 gfc_error ("IMPORT statement at %C only permitted in "
3312 "an INTERFACE body");
3316 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3318 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3319 "in a module procedure interface body");
3323 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3326 if (gfc_match_eos () == MATCH_YES
)
3328 /* All host variables should be imported. */
3329 gfc_current_ns
->has_import_set
= 1;
3333 if (gfc_match (" ::") == MATCH_YES
)
3335 if (gfc_match_eos () == MATCH_YES
)
3337 gfc_error ("Expecting list of named entities at %C");
3345 m
= gfc_match (" %n", name
);
3349 if (gfc_current_ns
->parent
!= NULL
3350 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3352 gfc_error ("Type name %qs at %C is ambiguous", name
);
3355 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3356 && gfc_find_symbol (name
,
3357 gfc_current_ns
->proc_name
->ns
->parent
,
3360 gfc_error ("Type name %qs at %C is ambiguous", name
);
3366 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3367 "at %C - does not exist.", name
);
3371 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3373 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3378 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3381 sym
->attr
.imported
= 1;
3383 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3385 /* The actual derived type is stored in a symtree with the first
3386 letter of the name capitalized; the symtree with the all
3387 lower-case name contains the associated generic function. */
3388 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3389 gfc_get_string ("%c%s",
3390 (char) TOUPPER ((unsigned char) name
[0]),
3394 sym
->attr
.imported
= 1;
3407 if (gfc_match_eos () == MATCH_YES
)
3409 if (gfc_match_char (',') != MATCH_YES
)
3416 gfc_error ("Syntax error in IMPORT statement at %C");
3421 /* A minimal implementation of gfc_match without whitespace, escape
3422 characters or variable arguments. Returns true if the next
3423 characters match the TARGET template exactly. */
3426 match_string_p (const char *target
)
3430 for (p
= target
; *p
; p
++)
3431 if ((char) gfc_next_ascii_char () != *p
)
3436 /* Matches an attribute specification including array specs. If
3437 successful, leaves the variables current_attr and current_as
3438 holding the specification. Also sets the colon_seen variable for
3439 later use by matchers associated with initializations.
3441 This subroutine is a little tricky in the sense that we don't know
3442 if we really have an attr-spec until we hit the double colon.
3443 Until that time, we can only return MATCH_NO. This forces us to
3444 check for duplicate specification at this level. */
3447 match_attr_spec (void)
3449 /* Modifiers that can exist in a type statement. */
3451 { GFC_DECL_BEGIN
= 0,
3452 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3453 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3454 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3455 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3456 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3457 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3460 /* GFC_DECL_END is the sentinel, index starts at 0. */
3461 #define NUM_DECL GFC_DECL_END
3463 locus start
, seen_at
[NUM_DECL
];
3470 gfc_clear_attr (¤t_attr
);
3471 start
= gfc_current_locus
;
3476 /* See if we get all of the keywords up to the final double colon. */
3477 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3485 gfc_gobble_whitespace ();
3487 ch
= gfc_next_ascii_char ();
3490 /* This is the successful exit condition for the loop. */
3491 if (gfc_next_ascii_char () == ':')
3496 gfc_gobble_whitespace ();
3497 switch (gfc_peek_ascii_char ())
3500 gfc_next_ascii_char ();
3501 switch (gfc_next_ascii_char ())
3504 if (match_string_p ("locatable"))
3506 /* Matched "allocatable". */
3507 d
= DECL_ALLOCATABLE
;
3512 if (match_string_p ("ynchronous"))
3514 /* Matched "asynchronous". */
3515 d
= DECL_ASYNCHRONOUS
;
3522 /* Try and match the bind(c). */
3523 m
= gfc_match_bind_c (NULL
, true);
3526 else if (m
== MATCH_ERROR
)
3531 gfc_next_ascii_char ();
3532 if ('o' != gfc_next_ascii_char ())
3534 switch (gfc_next_ascii_char ())
3537 if (match_string_p ("imension"))
3539 d
= DECL_CODIMENSION
;
3543 if (match_string_p ("tiguous"))
3545 d
= DECL_CONTIGUOUS
;
3552 if (match_string_p ("dimension"))
3557 if (match_string_p ("external"))
3562 if (match_string_p ("int"))
3564 ch
= gfc_next_ascii_char ();
3567 if (match_string_p ("nt"))
3569 /* Matched "intent". */
3570 /* TODO: Call match_intent_spec from here. */
3571 if (gfc_match (" ( in out )") == MATCH_YES
)
3573 else if (gfc_match (" ( in )") == MATCH_YES
)
3575 else if (gfc_match (" ( out )") == MATCH_YES
)
3581 if (match_string_p ("insic"))
3583 /* Matched "intrinsic". */
3591 if (match_string_p ("optional"))
3596 gfc_next_ascii_char ();
3597 switch (gfc_next_ascii_char ())
3600 if (match_string_p ("rameter"))
3602 /* Matched "parameter". */
3608 if (match_string_p ("inter"))
3610 /* Matched "pointer". */
3616 ch
= gfc_next_ascii_char ();
3619 if (match_string_p ("vate"))
3621 /* Matched "private". */
3627 if (match_string_p ("tected"))
3629 /* Matched "protected". */
3636 if (match_string_p ("blic"))
3638 /* Matched "public". */
3646 if (match_string_p ("save"))
3651 if (match_string_p ("target"))
3656 gfc_next_ascii_char ();
3657 ch
= gfc_next_ascii_char ();
3660 if (match_string_p ("lue"))
3662 /* Matched "value". */
3668 if (match_string_p ("latile"))
3670 /* Matched "volatile". */
3678 /* No double colon and no recognizable decl_type, so assume that
3679 we've been looking at something else the whole time. */
3686 /* Check to make sure any parens are paired up correctly. */
3687 if (gfc_match_parens () == MATCH_ERROR
)
3694 seen_at
[d
] = gfc_current_locus
;
3696 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3698 gfc_array_spec
*as
= NULL
;
3700 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3701 d
== DECL_CODIMENSION
);
3703 if (current_as
== NULL
)
3705 else if (m
== MATCH_YES
)
3707 if (!merge_array_spec (as
, current_as
, false))
3714 if (d
== DECL_CODIMENSION
)
3715 gfc_error ("Missing codimension specification at %C");
3717 gfc_error ("Missing dimension specification at %C");
3721 if (m
== MATCH_ERROR
)
3726 /* Since we've seen a double colon, we have to be looking at an
3727 attr-spec. This means that we can now issue errors. */
3728 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3733 case DECL_ALLOCATABLE
:
3734 attr
= "ALLOCATABLE";
3736 case DECL_ASYNCHRONOUS
:
3737 attr
= "ASYNCHRONOUS";
3739 case DECL_CODIMENSION
:
3740 attr
= "CODIMENSION";
3742 case DECL_CONTIGUOUS
:
3743 attr
= "CONTIGUOUS";
3745 case DECL_DIMENSION
:
3752 attr
= "INTENT (IN)";
3755 attr
= "INTENT (OUT)";
3758 attr
= "INTENT (IN OUT)";
3760 case DECL_INTRINSIC
:
3766 case DECL_PARAMETER
:
3772 case DECL_PROTECTED
:
3787 case DECL_IS_BIND_C
:
3797 attr
= NULL
; /* This shouldn't happen. */
3800 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3805 /* Now that we've dealt with duplicate attributes, add the attributes
3806 to the current attribute. */
3807 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3812 if (gfc_current_state () == COMP_DERIVED
3813 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3814 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3815 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3817 if (d
== DECL_ALLOCATABLE
)
3819 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3820 "attribute at %C in a TYPE definition"))
3828 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3835 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3836 && gfc_current_state () != COMP_MODULE
)
3838 if (d
== DECL_PRIVATE
)
3842 if (gfc_current_state () == COMP_DERIVED
3843 && gfc_state_stack
->previous
3844 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3846 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3847 "at %L in a TYPE definition", attr
,
3856 gfc_error ("%s attribute at %L is not allowed outside of the "
3857 "specification part of a module", attr
, &seen_at
[d
]);
3865 case DECL_ALLOCATABLE
:
3866 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3869 case DECL_ASYNCHRONOUS
:
3870 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3873 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3876 case DECL_CODIMENSION
:
3877 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3880 case DECL_CONTIGUOUS
:
3881 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3884 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3887 case DECL_DIMENSION
:
3888 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3892 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3896 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3900 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3904 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3907 case DECL_INTRINSIC
:
3908 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3912 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3915 case DECL_PARAMETER
:
3916 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3920 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3923 case DECL_PROTECTED
:
3924 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3926 gfc_error ("PROTECTED at %C only allowed in specification "
3927 "part of a module");
3932 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3935 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3939 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3944 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3949 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3953 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3956 case DECL_IS_BIND_C
:
3957 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3961 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3964 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3968 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3971 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3975 gfc_internal_error ("match_attr_spec(): Bad attribute");
3985 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3986 if ((gfc_current_state () == COMP_MODULE
3987 || gfc_current_state () == COMP_SUBMODULE
)
3988 && !current_attr
.save
3989 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3990 current_attr
.save
= SAVE_IMPLICIT
;
3996 gfc_current_locus
= start
;
3997 gfc_free_array_spec (current_as
);
4003 /* Set the binding label, dest_label, either with the binding label
4004 stored in the given gfc_typespec, ts, or if none was provided, it
4005 will be the symbol name in all lower case, as required by the draft
4006 (J3/04-007, section 15.4.1). If a binding label was given and
4007 there is more than one argument (num_idents), it is an error. */
4010 set_binding_label (const char **dest_label
, const char *sym_name
,
4013 if (num_idents
> 1 && has_name_equals
)
4015 gfc_error ("Multiple identifiers provided with "
4016 "single NAME= specifier at %C");
4020 if (curr_binding_label
)
4021 /* Binding label given; store in temp holder till have sym. */
4022 *dest_label
= curr_binding_label
;
4025 /* No binding label given, and the NAME= specifier did not exist,
4026 which means there was no NAME="". */
4027 if (sym_name
!= NULL
&& has_name_equals
== 0)
4028 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4035 /* Set the status of the given common block as being BIND(C) or not,
4036 depending on the given parameter, is_bind_c. */
4039 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4041 com_block
->is_bind_c
= is_bind_c
;
4046 /* Verify that the given gfc_typespec is for a C interoperable type. */
4049 gfc_verify_c_interop (gfc_typespec
*ts
)
4051 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4052 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4054 else if (ts
->type
== BT_CLASS
)
4056 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4063 /* Verify that the variables of a given common block, which has been
4064 defined with the attribute specifier bind(c), to be of a C
4065 interoperable type. Errors will be reported here, if
4069 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4071 gfc_symbol
*curr_sym
= NULL
;
4074 curr_sym
= com_block
->head
;
4076 /* Make sure we have at least one symbol. */
4077 if (curr_sym
== NULL
)
4080 /* Here we know we have a symbol, so we'll execute this loop
4084 /* The second to last param, 1, says this is in a common block. */
4085 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4086 curr_sym
= curr_sym
->common_next
;
4087 } while (curr_sym
!= NULL
);
4093 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4094 an appropriate error message is reported. */
4097 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4098 int is_in_common
, gfc_common_head
*com_block
)
4100 bool bind_c_function
= false;
4103 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4104 bind_c_function
= true;
4106 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4108 tmp_sym
= tmp_sym
->result
;
4109 /* Make sure it wasn't an implicitly typed result. */
4110 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4112 gfc_warning (OPT_Wc_binding_type
,
4113 "Implicitly declared BIND(C) function %qs at "
4114 "%L may not be C interoperable", tmp_sym
->name
,
4115 &tmp_sym
->declared_at
);
4116 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4117 /* Mark it as C interoperable to prevent duplicate warnings. */
4118 tmp_sym
->ts
.is_c_interop
= 1;
4119 tmp_sym
->attr
.is_c_interop
= 1;
4123 /* Here, we know we have the bind(c) attribute, so if we have
4124 enough type info, then verify that it's a C interop kind.
4125 The info could be in the symbol already, or possibly still in
4126 the given ts (current_ts), so look in both. */
4127 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4129 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4131 /* See if we're dealing with a sym in a common block or not. */
4132 if (is_in_common
== 1 && warn_c_binding_type
)
4134 gfc_warning (OPT_Wc_binding_type
,
4135 "Variable %qs in common block %qs at %L "
4136 "may not be a C interoperable "
4137 "kind though common block %qs is BIND(C)",
4138 tmp_sym
->name
, com_block
->name
,
4139 &(tmp_sym
->declared_at
), com_block
->name
);
4143 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4144 gfc_error ("Type declaration %qs at %L is not C "
4145 "interoperable but it is BIND(C)",
4146 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4147 else if (warn_c_binding_type
)
4148 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4149 "may not be a C interoperable "
4150 "kind but it is BIND(C)",
4151 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4155 /* Variables declared w/in a common block can't be bind(c)
4156 since there's no way for C to see these variables, so there's
4157 semantically no reason for the attribute. */
4158 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4160 gfc_error ("Variable %qs in common block %qs at "
4161 "%L cannot be declared with BIND(C) "
4162 "since it is not a global",
4163 tmp_sym
->name
, com_block
->name
,
4164 &(tmp_sym
->declared_at
));
4168 /* Scalar variables that are bind(c) can not have the pointer
4169 or allocatable attributes. */
4170 if (tmp_sym
->attr
.is_bind_c
== 1)
4172 if (tmp_sym
->attr
.pointer
== 1)
4174 gfc_error ("Variable %qs at %L cannot have both the "
4175 "POINTER and BIND(C) attributes",
4176 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4180 if (tmp_sym
->attr
.allocatable
== 1)
4182 gfc_error ("Variable %qs at %L cannot have both the "
4183 "ALLOCATABLE and BIND(C) attributes",
4184 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4190 /* If it is a BIND(C) function, make sure the return value is a
4191 scalar value. The previous tests in this function made sure
4192 the type is interoperable. */
4193 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4194 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4195 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4197 /* BIND(C) functions can not return a character string. */
4198 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4199 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4200 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4201 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4202 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4203 "be a character string", tmp_sym
->name
,
4204 &(tmp_sym
->declared_at
));
4207 /* See if the symbol has been marked as private. If it has, make sure
4208 there is no binding label and warn the user if there is one. */
4209 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4210 && tmp_sym
->binding_label
)
4211 /* Use gfc_warning_now because we won't say that the symbol fails
4212 just because of this. */
4213 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4214 "given the binding label %qs", tmp_sym
->name
,
4215 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4221 /* Set the appropriate fields for a symbol that's been declared as
4222 BIND(C) (the is_bind_c flag and the binding label), and verify that
4223 the type is C interoperable. Errors are reported by the functions
4224 used to set/test these fields. */
4227 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4231 /* TODO: Do we need to make sure the vars aren't marked private? */
4233 /* Set the is_bind_c bit in symbol_attribute. */
4234 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4236 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4243 /* Set the fields marking the given common block as BIND(C), including
4244 a binding label, and report any errors encountered. */
4247 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4251 /* destLabel, common name, typespec (which may have binding label). */
4252 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4256 /* Set the given common block (com_block) to being bind(c) (1). */
4257 set_com_block_bind_c (com_block
, 1);
4263 /* Retrieve the list of one or more identifiers that the given bind(c)
4264 attribute applies to. */
4267 get_bind_c_idents (void)
4269 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4271 gfc_symbol
*tmp_sym
= NULL
;
4273 gfc_common_head
*com_block
= NULL
;
4275 if (gfc_match_name (name
) == MATCH_YES
)
4277 found_id
= MATCH_YES
;
4278 gfc_get_ha_symbol (name
, &tmp_sym
);
4280 else if (match_common_name (name
) == MATCH_YES
)
4282 found_id
= MATCH_YES
;
4283 com_block
= gfc_get_common (name
, 0);
4287 gfc_error ("Need either entity or common block name for "
4288 "attribute specification statement at %C");
4292 /* Save the current identifier and look for more. */
4295 /* Increment the number of identifiers found for this spec stmt. */
4298 /* Make sure we have a sym or com block, and verify that it can
4299 be bind(c). Set the appropriate field(s) and look for more
4301 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4303 if (tmp_sym
!= NULL
)
4305 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4310 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4314 /* Look to see if we have another identifier. */
4316 if (gfc_match_eos () == MATCH_YES
)
4317 found_id
= MATCH_NO
;
4318 else if (gfc_match_char (',') != MATCH_YES
)
4319 found_id
= MATCH_NO
;
4320 else if (gfc_match_name (name
) == MATCH_YES
)
4322 found_id
= MATCH_YES
;
4323 gfc_get_ha_symbol (name
, &tmp_sym
);
4325 else if (match_common_name (name
) == MATCH_YES
)
4327 found_id
= MATCH_YES
;
4328 com_block
= gfc_get_common (name
, 0);
4332 gfc_error ("Missing entity or common block name for "
4333 "attribute specification statement at %C");
4339 gfc_internal_error ("Missing symbol");
4341 } while (found_id
== MATCH_YES
);
4343 /* if we get here we were successful */
4348 /* Try and match a BIND(C) attribute specification statement. */
4351 gfc_match_bind_c_stmt (void)
4353 match found_match
= MATCH_NO
;
4358 /* This may not be necessary. */
4360 /* Clear the temporary binding label holder. */
4361 curr_binding_label
= NULL
;
4363 /* Look for the bind(c). */
4364 found_match
= gfc_match_bind_c (NULL
, true);
4366 if (found_match
== MATCH_YES
)
4368 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4371 /* Look for the :: now, but it is not required. */
4374 /* Get the identifier(s) that needs to be updated. This may need to
4375 change to hand the flag(s) for the attr specified so all identifiers
4376 found can have all appropriate parts updated (assuming that the same
4377 spec stmt can have multiple attrs, such as both bind(c) and
4379 if (!get_bind_c_idents ())
4380 /* Error message should have printed already. */
4388 /* Match a data declaration statement. */
4391 gfc_match_data_decl (void)
4397 num_idents_on_line
= 0;
4399 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4403 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4404 && gfc_current_state () != COMP_DERIVED
)
4406 sym
= gfc_use_derived (current_ts
.u
.derived
);
4414 current_ts
.u
.derived
= sym
;
4417 m
= match_attr_spec ();
4418 if (m
== MATCH_ERROR
)
4424 if (current_ts
.type
== BT_CLASS
4425 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4428 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4429 && current_ts
.u
.derived
->components
== NULL
4430 && !current_ts
.u
.derived
->attr
.zero_comp
)
4433 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4436 gfc_find_symbol (current_ts
.u
.derived
->name
,
4437 current_ts
.u
.derived
->ns
, 1, &sym
);
4439 /* Any symbol that we find had better be a type definition
4440 which has its components defined. */
4441 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4442 && (current_ts
.u
.derived
->components
!= NULL
4443 || current_ts
.u
.derived
->attr
.zero_comp
))
4446 gfc_error ("Derived type at %C has not been previously defined "
4447 "and so cannot appear in a derived type definition");
4453 /* If we have an old-style character declaration, and no new-style
4454 attribute specifications, then there a comma is optional between
4455 the type specification and the variable list. */
4456 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4457 gfc_match_char (',');
4459 /* Give the types/attributes to symbols that follow. Give the element
4460 a number so that repeat character length expressions can be copied. */
4464 num_idents_on_line
++;
4465 m
= variable_decl (elem
++);
4466 if (m
== MATCH_ERROR
)
4471 if (gfc_match_eos () == MATCH_YES
)
4473 if (gfc_match_char (',') != MATCH_YES
)
4477 if (!gfc_error_flag_test ())
4478 gfc_error ("Syntax error in data declaration at %C");
4481 gfc_free_data_all (gfc_current_ns
);
4484 gfc_free_array_spec (current_as
);
4490 /* Match a prefix associated with a function or subroutine
4491 declaration. If the typespec pointer is nonnull, then a typespec
4492 can be matched. Note that if nothing matches, MATCH_YES is
4493 returned (the null string was matched). */
4496 gfc_match_prefix (gfc_typespec
*ts
)
4502 gfc_clear_attr (¤t_attr
);
4504 seen_impure
= false;
4506 gcc_assert (!gfc_matching_prefix
);
4507 gfc_matching_prefix
= true;
4511 found_prefix
= false;
4513 if (!seen_type
&& ts
!= NULL
4514 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4515 && gfc_match_space () == MATCH_YES
)
4519 found_prefix
= true;
4522 if (gfc_match ("elemental% ") == MATCH_YES
)
4524 if (!gfc_add_elemental (¤t_attr
, NULL
))
4527 found_prefix
= true;
4530 if (gfc_match ("pure% ") == MATCH_YES
)
4532 if (!gfc_add_pure (¤t_attr
, NULL
))
4535 found_prefix
= true;
4538 if (gfc_match ("recursive% ") == MATCH_YES
)
4540 if (!gfc_add_recursive (¤t_attr
, NULL
))
4543 found_prefix
= true;
4546 /* IMPURE is a somewhat special case, as it needs not set an actual
4547 attribute but rather only prevents ELEMENTAL routines from being
4548 automatically PURE. */
4549 if (gfc_match ("impure% ") == MATCH_YES
)
4551 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4555 found_prefix
= true;
4558 while (found_prefix
);
4560 /* IMPURE and PURE must not both appear, of course. */
4561 if (seen_impure
&& current_attr
.pure
)
4563 gfc_error ("PURE and IMPURE must not appear both at %C");
4567 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4568 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4570 if (!gfc_add_pure (¤t_attr
, NULL
))
4574 /* At this point, the next item is not a prefix. */
4575 gcc_assert (gfc_matching_prefix
);
4577 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4578 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4579 corresponding attribute seems natural and distinguishes these
4580 procedures from procedure types of PROC_MODULE, which these are
4582 if ((gfc_current_state () == COMP_INTERFACE
4583 || gfc_current_state () == COMP_CONTAINS
)
4584 && gfc_match ("module% ") == MATCH_YES
)
4586 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4589 current_attr
.module_procedure
= 1;
4592 gfc_matching_prefix
= false;
4596 gcc_assert (gfc_matching_prefix
);
4597 gfc_matching_prefix
= false;
4602 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4605 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4607 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4610 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4613 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4620 /* Match a formal argument list. */
4623 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4625 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4629 gfc_formal_arglist
*formal
= NULL
;
4633 /* Keep the interface formal argument list and null it so that the
4634 matching for the new declaration can be done. The numbers and
4635 names of the arguments are checked here. The interface formal
4636 arguments are retained in formal_arglist and the characteristics
4637 are compared in resolve.c(resolve_fl_procedure). See the remark
4638 in get_proc_name about the eventual need to copy the formal_arglist
4639 and populate the formal namespace of the interface symbol. */
4640 if (progname
->attr
.module_procedure
4641 && progname
->attr
.host_assoc
)
4643 formal
= progname
->formal
;
4644 progname
->formal
= NULL
;
4647 if (gfc_match_char ('(') != MATCH_YES
)
4654 if (gfc_match_char (')') == MATCH_YES
)
4659 if (gfc_match_char ('*') == MATCH_YES
)
4662 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4671 m
= gfc_match_name (name
);
4675 if (gfc_get_symbol (name
, NULL
, &sym
))
4679 p
= gfc_get_formal_arglist ();
4691 /* We don't add the VARIABLE flavor because the name could be a
4692 dummy procedure. We don't apply these attributes to formal
4693 arguments of statement functions. */
4694 if (sym
!= NULL
&& !st_flag
4695 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4696 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4702 /* The name of a program unit can be in a different namespace,
4703 so check for it explicitly. After the statement is accepted,
4704 the name is checked for especially in gfc_get_symbol(). */
4705 if (gfc_new_block
!= NULL
&& sym
!= NULL
4706 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4708 gfc_error ("Name %qs at %C is the name of the procedure",
4714 if (gfc_match_char (')') == MATCH_YES
)
4717 m
= gfc_match_char (',');
4720 gfc_error ("Unexpected junk in formal argument list at %C");
4726 /* Check for duplicate symbols in the formal argument list. */
4729 for (p
= head
; p
->next
; p
= p
->next
)
4734 for (q
= p
->next
; q
; q
= q
->next
)
4735 if (p
->sym
== q
->sym
)
4737 gfc_error ("Duplicate symbol %qs in formal argument list "
4738 "at %C", p
->sym
->name
);
4746 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4754 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4756 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4757 || (p
->next
== NULL
&& q
->next
!= NULL
))
4758 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4759 "formal arguments at %C");
4760 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4761 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4764 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4765 "argument names (%s/%s) at %C",
4766 p
->sym
->name
, q
->sym
->name
);
4773 gfc_free_formal_arglist (head
);
4778 /* Match a RESULT specification following a function declaration or
4779 ENTRY statement. Also matches the end-of-statement. */
4782 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4784 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4788 if (gfc_match (" result (") != MATCH_YES
)
4791 m
= gfc_match_name (name
);
4795 /* Get the right paren, and that's it because there could be the
4796 bind(c) attribute after the result clause. */
4797 if (gfc_match_char (')') != MATCH_YES
)
4799 /* TODO: should report the missing right paren here. */
4803 if (strcmp (function
->name
, name
) == 0)
4805 gfc_error ("RESULT variable at %C must be different than function name");
4809 if (gfc_get_symbol (name
, NULL
, &r
))
4812 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4821 /* Match a function suffix, which could be a combination of a result
4822 clause and BIND(C), either one, or neither. The draft does not
4823 require them to come in a specific order. */
4826 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4828 match is_bind_c
; /* Found bind(c). */
4829 match is_result
; /* Found result clause. */
4830 match found_match
; /* Status of whether we've found a good match. */
4831 char peek_char
; /* Character we're going to peek at. */
4832 bool allow_binding_name
;
4834 /* Initialize to having found nothing. */
4835 found_match
= MATCH_NO
;
4836 is_bind_c
= MATCH_NO
;
4837 is_result
= MATCH_NO
;
4839 /* Get the next char to narrow between result and bind(c). */
4840 gfc_gobble_whitespace ();
4841 peek_char
= gfc_peek_ascii_char ();
4843 /* C binding names are not allowed for internal procedures. */
4844 if (gfc_current_state () == COMP_CONTAINS
4845 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4846 allow_binding_name
= false;
4848 allow_binding_name
= true;
4853 /* Look for result clause. */
4854 is_result
= match_result (sym
, result
);
4855 if (is_result
== MATCH_YES
)
4857 /* Now see if there is a bind(c) after it. */
4858 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4859 /* We've found the result clause and possibly bind(c). */
4860 found_match
= MATCH_YES
;
4863 /* This should only be MATCH_ERROR. */
4864 found_match
= is_result
;
4867 /* Look for bind(c) first. */
4868 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4869 if (is_bind_c
== MATCH_YES
)
4871 /* Now see if a result clause followed it. */
4872 is_result
= match_result (sym
, result
);
4873 found_match
= MATCH_YES
;
4877 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4878 found_match
= MATCH_ERROR
;
4882 gfc_error ("Unexpected junk after function declaration at %C");
4883 found_match
= MATCH_ERROR
;
4887 if (is_bind_c
== MATCH_YES
)
4889 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4890 if (gfc_current_state () == COMP_CONTAINS
4891 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4892 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4893 "at %L may not be specified for an internal "
4894 "procedure", &gfc_current_locus
))
4897 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4905 /* Procedure pointer return value without RESULT statement:
4906 Add "hidden" result variable named "ppr@". */
4909 add_hidden_procptr_result (gfc_symbol
*sym
)
4913 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4916 /* First usage case: PROCEDURE and EXTERNAL statements. */
4917 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4918 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4919 && sym
->attr
.external
;
4920 /* Second usage case: INTERFACE statements. */
4921 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4922 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4923 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4929 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4933 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4934 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4935 st2
->n
.sym
= stree
->n
.sym
;
4937 sym
->result
= stree
->n
.sym
;
4939 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4940 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4941 sym
->result
->attr
.external
= sym
->attr
.external
;
4942 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4943 sym
->result
->ts
= sym
->ts
;
4944 sym
->attr
.proc_pointer
= 0;
4945 sym
->attr
.pointer
= 0;
4946 sym
->attr
.external
= 0;
4947 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4949 sym
->result
->attr
.pointer
= 0;
4950 sym
->result
->attr
.proc_pointer
= 1;
4953 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4955 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4956 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4957 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4958 && sym
== gfc_current_ns
->proc_name
4959 && sym
== sym
->result
->ns
->proc_name
4960 && strcmp ("ppr@", sym
->result
->name
) == 0)
4962 sym
->result
->attr
.proc_pointer
= 1;
4963 sym
->attr
.pointer
= 0;
4971 /* Match the interface for a PROCEDURE declaration,
4972 including brackets (R1212). */
4975 match_procedure_interface (gfc_symbol
**proc_if
)
4979 locus old_loc
, entry_loc
;
4980 gfc_namespace
*old_ns
= gfc_current_ns
;
4981 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4983 old_loc
= entry_loc
= gfc_current_locus
;
4984 gfc_clear_ts (¤t_ts
);
4986 if (gfc_match (" (") != MATCH_YES
)
4988 gfc_current_locus
= entry_loc
;
4992 /* Get the type spec. for the procedure interface. */
4993 old_loc
= gfc_current_locus
;
4994 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4995 gfc_gobble_whitespace ();
4996 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4999 if (m
== MATCH_ERROR
)
5002 /* Procedure interface is itself a procedure. */
5003 gfc_current_locus
= old_loc
;
5004 m
= gfc_match_name (name
);
5006 /* First look to see if it is already accessible in the current
5007 namespace because it is use associated or contained. */
5009 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5012 /* If it is still not found, then try the parent namespace, if it
5013 exists and create the symbol there if it is still not found. */
5014 if (gfc_current_ns
->parent
)
5015 gfc_current_ns
= gfc_current_ns
->parent
;
5016 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5019 gfc_current_ns
= old_ns
;
5020 *proc_if
= st
->n
.sym
;
5025 /* Resolve interface if possible. That way, attr.procedure is only set
5026 if it is declared by a later procedure-declaration-stmt, which is
5027 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5028 while ((*proc_if
)->ts
.interface
)
5029 *proc_if
= (*proc_if
)->ts
.interface
;
5031 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5032 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5033 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5034 (*proc_if
)->name
, NULL
))
5039 if (gfc_match (" )") != MATCH_YES
)
5041 gfc_current_locus
= entry_loc
;
5049 /* Match a PROCEDURE declaration (R1211). */
5052 match_procedure_decl (void)
5055 gfc_symbol
*sym
, *proc_if
= NULL
;
5057 gfc_expr
*initializer
= NULL
;
5059 /* Parse interface (with brackets). */
5060 m
= match_procedure_interface (&proc_if
);
5064 /* Parse attributes (with colons). */
5065 m
= match_attr_spec();
5066 if (m
== MATCH_ERROR
)
5069 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5071 current_attr
.is_bind_c
= 1;
5072 has_name_equals
= 0;
5073 curr_binding_label
= NULL
;
5076 /* Get procedure symbols. */
5079 m
= gfc_match_symbol (&sym
, 0);
5082 else if (m
== MATCH_ERROR
)
5085 /* Add current_attr to the symbol attributes. */
5086 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5089 if (sym
->attr
.is_bind_c
)
5091 /* Check for C1218. */
5092 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5094 gfc_error ("BIND(C) attribute at %C requires "
5095 "an interface with BIND(C)");
5098 /* Check for C1217. */
5099 if (has_name_equals
&& sym
->attr
.pointer
)
5101 gfc_error ("BIND(C) procedure with NAME may not have "
5102 "POINTER attribute at %C");
5105 if (has_name_equals
&& sym
->attr
.dummy
)
5107 gfc_error ("Dummy procedure at %C may not have "
5108 "BIND(C) attribute with NAME");
5111 /* Set binding label for BIND(C). */
5112 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5116 if (!gfc_add_external (&sym
->attr
, NULL
))
5119 if (add_hidden_procptr_result (sym
))
5122 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5125 /* Set interface. */
5126 if (proc_if
!= NULL
)
5128 if (sym
->ts
.type
!= BT_UNKNOWN
)
5130 gfc_error ("Procedure %qs at %L already has basic type of %s",
5131 sym
->name
, &gfc_current_locus
,
5132 gfc_basic_typename (sym
->ts
.type
));
5135 sym
->ts
.interface
= proc_if
;
5136 sym
->attr
.untyped
= 1;
5137 sym
->attr
.if_source
= IFSRC_IFBODY
;
5139 else if (current_ts
.type
!= BT_UNKNOWN
)
5141 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5143 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5144 sym
->ts
.interface
->ts
= current_ts
;
5145 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5146 sym
->ts
.interface
->attr
.function
= 1;
5147 sym
->attr
.function
= 1;
5148 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5151 if (gfc_match (" =>") == MATCH_YES
)
5153 if (!current_attr
.pointer
)
5155 gfc_error ("Initialization at %C isn't for a pointer variable");
5160 m
= match_pointer_init (&initializer
, 1);
5164 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5169 if (gfc_match_eos () == MATCH_YES
)
5171 if (gfc_match_char (',') != MATCH_YES
)
5176 gfc_error ("Syntax error in PROCEDURE statement at %C");
5180 /* Free stuff up and return. */
5181 gfc_free_expr (initializer
);
5187 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5190 /* Match a procedure pointer component declaration (R445). */
5193 match_ppc_decl (void)
5196 gfc_symbol
*proc_if
= NULL
;
5200 gfc_expr
*initializer
= NULL
;
5201 gfc_typebound_proc
* tb
;
5202 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5204 /* Parse interface (with brackets). */
5205 m
= match_procedure_interface (&proc_if
);
5209 /* Parse attributes. */
5210 tb
= XCNEW (gfc_typebound_proc
);
5211 tb
->where
= gfc_current_locus
;
5212 m
= match_binding_attributes (tb
, false, true);
5213 if (m
== MATCH_ERROR
)
5216 gfc_clear_attr (¤t_attr
);
5217 current_attr
.procedure
= 1;
5218 current_attr
.proc_pointer
= 1;
5219 current_attr
.access
= tb
->access
;
5220 current_attr
.flavor
= FL_PROCEDURE
;
5222 /* Match the colons (required). */
5223 if (gfc_match (" ::") != MATCH_YES
)
5225 gfc_error ("Expected %<::%> after binding-attributes at %C");
5229 /* Check for C450. */
5230 if (!tb
->nopass
&& proc_if
== NULL
)
5232 gfc_error("NOPASS or explicit interface required at %C");
5236 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5239 /* Match PPC names. */
5243 m
= gfc_match_name (name
);
5246 else if (m
== MATCH_ERROR
)
5249 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5252 /* Add current_attr to the symbol attributes. */
5253 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5256 if (!gfc_add_external (&c
->attr
, NULL
))
5259 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5266 c
->tb
= XCNEW (gfc_typebound_proc
);
5267 c
->tb
->where
= gfc_current_locus
;
5271 /* Set interface. */
5272 if (proc_if
!= NULL
)
5274 c
->ts
.interface
= proc_if
;
5275 c
->attr
.untyped
= 1;
5276 c
->attr
.if_source
= IFSRC_IFBODY
;
5278 else if (ts
.type
!= BT_UNKNOWN
)
5281 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5282 c
->ts
.interface
->result
= c
->ts
.interface
;
5283 c
->ts
.interface
->ts
= ts
;
5284 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5285 c
->ts
.interface
->attr
.function
= 1;
5286 c
->attr
.function
= 1;
5287 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5290 if (gfc_match (" =>") == MATCH_YES
)
5292 m
= match_pointer_init (&initializer
, 1);
5295 gfc_free_expr (initializer
);
5298 c
->initializer
= initializer
;
5301 if (gfc_match_eos () == MATCH_YES
)
5303 if (gfc_match_char (',') != MATCH_YES
)
5308 gfc_error ("Syntax error in procedure pointer component at %C");
5313 /* Match a PROCEDURE declaration inside an interface (R1206). */
5316 match_procedure_in_interface (void)
5320 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5323 if (current_interface
.type
== INTERFACE_NAMELESS
5324 || current_interface
.type
== INTERFACE_ABSTRACT
)
5326 gfc_error ("PROCEDURE at %C must be in a generic interface");
5330 /* Check if the F2008 optional double colon appears. */
5331 gfc_gobble_whitespace ();
5332 old_locus
= gfc_current_locus
;
5333 if (gfc_match ("::") == MATCH_YES
)
5335 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5336 "MODULE PROCEDURE statement at %L", &old_locus
))
5340 gfc_current_locus
= old_locus
;
5344 m
= gfc_match_name (name
);
5347 else if (m
== MATCH_ERROR
)
5349 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5352 if (!gfc_add_interface (sym
))
5355 if (gfc_match_eos () == MATCH_YES
)
5357 if (gfc_match_char (',') != MATCH_YES
)
5364 gfc_error ("Syntax error in PROCEDURE statement at %C");
5369 /* General matcher for PROCEDURE declarations. */
5371 static match
match_procedure_in_type (void);
5374 gfc_match_procedure (void)
5378 switch (gfc_current_state ())
5383 case COMP_SUBMODULE
:
5384 case COMP_SUBROUTINE
:
5387 m
= match_procedure_decl ();
5389 case COMP_INTERFACE
:
5390 m
= match_procedure_in_interface ();
5393 m
= match_ppc_decl ();
5395 case COMP_DERIVED_CONTAINS
:
5396 m
= match_procedure_in_type ();
5405 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5412 /* Warn if a matched procedure has the same name as an intrinsic; this is
5413 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5414 parser-state-stack to find out whether we're in a module. */
5417 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5421 in_module
= (gfc_state_stack
->previous
5422 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5423 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5425 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5429 /* Match a function declaration. */
5432 gfc_match_function_decl (void)
5434 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5435 gfc_symbol
*sym
, *result
;
5439 match found_match
; /* Status returned by match func. */
5441 if (gfc_current_state () != COMP_NONE
5442 && gfc_current_state () != COMP_INTERFACE
5443 && gfc_current_state () != COMP_CONTAINS
)
5446 gfc_clear_ts (¤t_ts
);
5448 old_loc
= gfc_current_locus
;
5450 m
= gfc_match_prefix (¤t_ts
);
5453 gfc_current_locus
= old_loc
;
5457 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5459 gfc_current_locus
= old_loc
;
5463 if (get_proc_name (name
, &sym
, false))
5466 if (add_hidden_procptr_result (sym
))
5469 if (current_attr
.module_procedure
)
5470 sym
->attr
.module_procedure
= 1;
5472 gfc_new_block
= sym
;
5474 m
= gfc_match_formal_arglist (sym
, 0, 0);
5477 gfc_error ("Expected formal argument list in function "
5478 "definition at %C");
5482 else if (m
== MATCH_ERROR
)
5487 /* According to the draft, the bind(c) and result clause can
5488 come in either order after the formal_arg_list (i.e., either
5489 can be first, both can exist together or by themselves or neither
5490 one). Therefore, the match_result can't match the end of the
5491 string, and check for the bind(c) or result clause in either order. */
5492 found_match
= gfc_match_eos ();
5494 /* Make sure that it isn't already declared as BIND(C). If it is, it
5495 must have been marked BIND(C) with a BIND(C) attribute and that is
5496 not allowed for procedures. */
5497 if (sym
->attr
.is_bind_c
== 1)
5499 sym
->attr
.is_bind_c
= 0;
5500 if (sym
->old_symbol
!= NULL
)
5501 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5502 "variables or common blocks",
5503 &(sym
->old_symbol
->declared_at
));
5505 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5506 "variables or common blocks", &gfc_current_locus
);
5509 if (found_match
!= MATCH_YES
)
5511 /* If we haven't found the end-of-statement, look for a suffix. */
5512 suffix_match
= gfc_match_suffix (sym
, &result
);
5513 if (suffix_match
== MATCH_YES
)
5514 /* Need to get the eos now. */
5515 found_match
= gfc_match_eos ();
5517 found_match
= suffix_match
;
5520 if(found_match
!= MATCH_YES
)
5524 /* Make changes to the symbol. */
5527 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5530 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5531 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5534 /* Delay matching the function characteristics until after the
5535 specification block by signalling kind=-1. */
5536 sym
->declared_at
= old_loc
;
5537 if (current_ts
.type
!= BT_UNKNOWN
)
5538 current_ts
.kind
= -1;
5540 current_ts
.kind
= 0;
5544 if (current_ts
.type
!= BT_UNKNOWN
5545 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5551 if (current_ts
.type
!= BT_UNKNOWN
5552 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5554 sym
->result
= result
;
5557 /* Warn if this procedure has the same name as an intrinsic. */
5558 do_warn_intrinsic_shadow (sym
, true);
5564 gfc_current_locus
= old_loc
;
5569 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5570 pass the name of the entry, rather than the gfc_current_block name, and
5571 to return false upon finding an existing global entry. */
5574 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5578 enum gfc_symbol_type type
;
5580 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5582 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5583 name is a global identifier. */
5584 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5586 s
= gfc_get_gsymbol (name
);
5588 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5590 gfc_global_used (s
, where
);
5599 s
->ns
= gfc_current_ns
;
5603 /* Don't add the symbol multiple times. */
5605 && (!gfc_notification_std (GFC_STD_F2008
)
5606 || strcmp (name
, binding_label
) != 0))
5608 s
= gfc_get_gsymbol (binding_label
);
5610 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5612 gfc_global_used (s
, where
);
5619 s
->binding_label
= binding_label
;
5622 s
->ns
= gfc_current_ns
;
5630 /* Match an ENTRY statement. */
5633 gfc_match_entry (void)
5638 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5639 gfc_compile_state state
;
5643 bool module_procedure
;
5647 m
= gfc_match_name (name
);
5651 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5654 state
= gfc_current_state ();
5655 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5660 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5663 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5665 case COMP_SUBMODULE
:
5666 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5668 case COMP_BLOCK_DATA
:
5669 gfc_error ("ENTRY statement at %C cannot appear within "
5672 case COMP_INTERFACE
:
5673 gfc_error ("ENTRY statement at %C cannot appear within "
5677 gfc_error ("ENTRY statement at %C cannot appear within "
5678 "a DERIVED TYPE block");
5681 gfc_error ("ENTRY statement at %C cannot appear within "
5682 "an IF-THEN block");
5685 case COMP_DO_CONCURRENT
:
5686 gfc_error ("ENTRY statement at %C cannot appear within "
5690 gfc_error ("ENTRY statement at %C cannot appear within "
5694 gfc_error ("ENTRY statement at %C cannot appear within "
5698 gfc_error ("ENTRY statement at %C cannot appear within "
5702 gfc_error ("ENTRY statement at %C cannot appear within "
5703 "a contained subprogram");
5706 gfc_error ("Unexpected ENTRY statement at %C");
5711 module_procedure
= gfc_current_ns
->parent
!= NULL
5712 && gfc_current_ns
->parent
->proc_name
5713 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5716 if (gfc_current_ns
->parent
!= NULL
5717 && gfc_current_ns
->parent
->proc_name
5718 && !module_procedure
)
5720 gfc_error("ENTRY statement at %C cannot appear in a "
5721 "contained procedure");
5725 /* Module function entries need special care in get_proc_name
5726 because previous references within the function will have
5727 created symbols attached to the current namespace. */
5728 if (get_proc_name (name
, &entry
,
5729 gfc_current_ns
->parent
!= NULL
5730 && module_procedure
))
5733 proc
= gfc_current_block ();
5735 /* Make sure that it isn't already declared as BIND(C). If it is, it
5736 must have been marked BIND(C) with a BIND(C) attribute and that is
5737 not allowed for procedures. */
5738 if (entry
->attr
.is_bind_c
== 1)
5740 entry
->attr
.is_bind_c
= 0;
5741 if (entry
->old_symbol
!= NULL
)
5742 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5743 "variables or common blocks",
5744 &(entry
->old_symbol
->declared_at
));
5746 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5747 "variables or common blocks", &gfc_current_locus
);
5750 /* Check what next non-whitespace character is so we can tell if there
5751 is the required parens if we have a BIND(C). */
5752 old_loc
= gfc_current_locus
;
5753 gfc_gobble_whitespace ();
5754 peek_char
= gfc_peek_ascii_char ();
5756 if (state
== COMP_SUBROUTINE
)
5758 m
= gfc_match_formal_arglist (entry
, 0, 1);
5762 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5763 never be an internal procedure. */
5764 is_bind_c
= gfc_match_bind_c (entry
, true);
5765 if (is_bind_c
== MATCH_ERROR
)
5767 if (is_bind_c
== MATCH_YES
)
5769 if (peek_char
!= '(')
5771 gfc_error ("Missing required parentheses before BIND(C) at %C");
5774 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5775 &(entry
->declared_at
), 1))
5779 if (!gfc_current_ns
->parent
5780 && !add_global_entry (name
, entry
->binding_label
, true,
5784 /* An entry in a subroutine. */
5785 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5786 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5791 /* An entry in a function.
5792 We need to take special care because writing
5797 ENTRY f() RESULT (r)
5799 ENTRY f RESULT (r). */
5800 if (gfc_match_eos () == MATCH_YES
)
5802 gfc_current_locus
= old_loc
;
5803 /* Match the empty argument list, and add the interface to
5805 m
= gfc_match_formal_arglist (entry
, 0, 1);
5808 m
= gfc_match_formal_arglist (entry
, 0, 0);
5815 if (gfc_match_eos () == MATCH_YES
)
5817 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5818 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5821 entry
->result
= entry
;
5825 m
= gfc_match_suffix (entry
, &result
);
5827 gfc_syntax_error (ST_ENTRY
);
5833 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5834 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5835 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5837 entry
->result
= result
;
5841 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5842 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5844 entry
->result
= entry
;
5848 if (!gfc_current_ns
->parent
5849 && !add_global_entry (name
, entry
->binding_label
, false,
5854 if (gfc_match_eos () != MATCH_YES
)
5856 gfc_syntax_error (ST_ENTRY
);
5860 entry
->attr
.recursive
= proc
->attr
.recursive
;
5861 entry
->attr
.elemental
= proc
->attr
.elemental
;
5862 entry
->attr
.pure
= proc
->attr
.pure
;
5864 el
= gfc_get_entry_list ();
5866 el
->next
= gfc_current_ns
->entries
;
5867 gfc_current_ns
->entries
= el
;
5869 el
->id
= el
->next
->id
+ 1;
5873 new_st
.op
= EXEC_ENTRY
;
5874 new_st
.ext
.entry
= el
;
5880 /* Match a subroutine statement, including optional prefixes. */
5883 gfc_match_subroutine (void)
5885 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5890 bool allow_binding_name
;
5892 if (gfc_current_state () != COMP_NONE
5893 && gfc_current_state () != COMP_INTERFACE
5894 && gfc_current_state () != COMP_CONTAINS
)
5897 m
= gfc_match_prefix (NULL
);
5901 m
= gfc_match ("subroutine% %n", name
);
5905 if (get_proc_name (name
, &sym
, false))
5908 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5909 the symbol existed before. */
5910 sym
->declared_at
= gfc_current_locus
;
5912 if (current_attr
.module_procedure
)
5913 sym
->attr
.module_procedure
= 1;
5915 if (add_hidden_procptr_result (sym
))
5918 gfc_new_block
= sym
;
5920 /* Check what next non-whitespace character is so we can tell if there
5921 is the required parens if we have a BIND(C). */
5922 gfc_gobble_whitespace ();
5923 peek_char
= gfc_peek_ascii_char ();
5925 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5928 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5931 /* Make sure that it isn't already declared as BIND(C). If it is, it
5932 must have been marked BIND(C) with a BIND(C) attribute and that is
5933 not allowed for procedures. */
5934 if (sym
->attr
.is_bind_c
== 1)
5936 sym
->attr
.is_bind_c
= 0;
5937 if (sym
->old_symbol
!= NULL
)
5938 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5939 "variables or common blocks",
5940 &(sym
->old_symbol
->declared_at
));
5942 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5943 "variables or common blocks", &gfc_current_locus
);
5946 /* C binding names are not allowed for internal procedures. */
5947 if (gfc_current_state () == COMP_CONTAINS
5948 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5949 allow_binding_name
= false;
5951 allow_binding_name
= true;
5953 /* Here, we are just checking if it has the bind(c) attribute, and if
5954 so, then we need to make sure it's all correct. If it doesn't,
5955 we still need to continue matching the rest of the subroutine line. */
5956 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5957 if (is_bind_c
== MATCH_ERROR
)
5959 /* There was an attempt at the bind(c), but it was wrong. An
5960 error message should have been printed w/in the gfc_match_bind_c
5961 so here we'll just return the MATCH_ERROR. */
5965 if (is_bind_c
== MATCH_YES
)
5967 /* The following is allowed in the Fortran 2008 draft. */
5968 if (gfc_current_state () == COMP_CONTAINS
5969 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5970 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5971 "at %L may not be specified for an internal "
5972 "procedure", &gfc_current_locus
))
5975 if (peek_char
!= '(')
5977 gfc_error ("Missing required parentheses before BIND(C) at %C");
5980 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5981 &(sym
->declared_at
), 1))
5985 if (gfc_match_eos () != MATCH_YES
)
5987 gfc_syntax_error (ST_SUBROUTINE
);
5991 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5994 /* Warn if it has the same name as an intrinsic. */
5995 do_warn_intrinsic_shadow (sym
, false);
6001 /* Check that the NAME identifier in a BIND attribute or statement
6002 is conform to C identifier rules. */
6005 check_bind_name_identifier (char **name
)
6007 char *n
= *name
, *p
;
6009 /* Remove leading spaces. */
6013 /* On an empty string, free memory and set name to NULL. */
6021 /* Remove trailing spaces. */
6022 p
= n
+ strlen(n
) - 1;
6026 /* Insert the identifier into the symbol table. */
6031 /* Now check that identifier is valid under C rules. */
6034 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6039 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6041 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6049 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6050 given, and set the binding label in either the given symbol (if not
6051 NULL), or in the current_ts. The symbol may be NULL because we may
6052 encounter the BIND(C) before the declaration itself. Return
6053 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6054 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6055 or MATCH_YES if the specifier was correct and the binding label and
6056 bind(c) fields were set correctly for the given symbol or the
6057 current_ts. If allow_binding_name is false, no binding name may be
6061 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6063 char *binding_label
= NULL
;
6066 /* Initialize the flag that specifies whether we encountered a NAME=
6067 specifier or not. */
6068 has_name_equals
= 0;
6070 /* This much we have to be able to match, in this order, if
6071 there is a bind(c) label. */
6072 if (gfc_match (" bind ( c ") != MATCH_YES
)
6075 /* Now see if there is a binding label, or if we've reached the
6076 end of the bind(c) attribute without one. */
6077 if (gfc_match_char (',') == MATCH_YES
)
6079 if (gfc_match (" name = ") != MATCH_YES
)
6081 gfc_error ("Syntax error in NAME= specifier for binding label "
6083 /* should give an error message here */
6087 has_name_equals
= 1;
6089 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6095 if (!gfc_simplify_expr(e
, 0))
6097 gfc_error ("NAME= specifier at %C should be a constant expression");
6102 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6103 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6105 gfc_error ("NAME= specifier at %C should be a scalar of "
6106 "default character kind");
6111 // Get a C string from the Fortran string constant
6112 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6113 e
->value
.character
.length
);
6116 // Check that it is valid (old gfc_match_name_C)
6117 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6121 /* Get the required right paren. */
6122 if (gfc_match_char (')') != MATCH_YES
)
6124 gfc_error ("Missing closing paren for binding label at %C");
6128 if (has_name_equals
&& !allow_binding_name
)
6130 gfc_error ("No binding name is allowed in BIND(C) at %C");
6134 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6136 gfc_error ("For dummy procedure %s, no binding name is "
6137 "allowed in BIND(C) at %C", sym
->name
);
6142 /* Save the binding label to the symbol. If sym is null, we're
6143 probably matching the typespec attributes of a declaration and
6144 haven't gotten the name yet, and therefore, no symbol yet. */
6148 sym
->binding_label
= binding_label
;
6150 curr_binding_label
= binding_label
;
6152 else if (allow_binding_name
)
6154 /* No binding label, but if symbol isn't null, we
6155 can set the label for it here.
6156 If name="" or allow_binding_name is false, no C binding name is
6158 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6159 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6162 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6163 && current_interface
.type
== INTERFACE_ABSTRACT
)
6165 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6173 /* Return nonzero if we're currently compiling a contained procedure. */
6176 contained_procedure (void)
6178 gfc_state_data
*s
= gfc_state_stack
;
6180 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6181 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6187 /* Set the kind of each enumerator. The kind is selected such that it is
6188 interoperable with the corresponding C enumeration type, making
6189 sure that -fshort-enums is honored. */
6194 enumerator_history
*current_history
= NULL
;
6198 if (max_enum
== NULL
|| enum_history
== NULL
)
6201 if (!flag_short_enums
)
6207 kind
= gfc_integer_kinds
[i
++].kind
;
6209 while (kind
< gfc_c_int_kind
6210 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6213 current_history
= enum_history
;
6214 while (current_history
!= NULL
)
6216 current_history
->sym
->ts
.kind
= kind
;
6217 current_history
= current_history
->next
;
6222 /* Match any of the various end-block statements. Returns the type of
6223 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6224 and END BLOCK statements cannot be replaced by a single END statement. */
6227 gfc_match_end (gfc_statement
*st
)
6229 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6230 gfc_compile_state state
;
6232 const char *block_name
;
6236 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6237 gfc_namespace
**nsp
;
6238 bool abreviated_modproc_decl
;
6240 old_loc
= gfc_current_locus
;
6241 if (gfc_match ("end") != MATCH_YES
)
6244 state
= gfc_current_state ();
6245 block_name
= gfc_current_block () == NULL
6246 ? NULL
: gfc_current_block ()->name
;
6250 case COMP_ASSOCIATE
:
6252 if (!strncmp (block_name
, "block@", strlen("block@")))
6257 case COMP_DERIVED_CONTAINS
:
6258 state
= gfc_state_stack
->previous
->state
;
6259 block_name
= gfc_state_stack
->previous
->sym
== NULL
6260 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6267 abreviated_modproc_decl
6268 = gfc_current_block ()
6269 && gfc_current_block ()->abr_modproc_decl
;
6275 *st
= ST_END_PROGRAM
;
6276 target
= " program";
6280 case COMP_SUBROUTINE
:
6281 *st
= ST_END_SUBROUTINE
;
6282 if (!abreviated_modproc_decl
)
6283 target
= " subroutine";
6285 target
= " procedure";
6286 eos_ok
= !contained_procedure ();
6290 *st
= ST_END_FUNCTION
;
6291 if (!abreviated_modproc_decl
)
6292 target
= " function";
6294 target
= " procedure";
6295 eos_ok
= !contained_procedure ();
6298 case COMP_BLOCK_DATA
:
6299 *st
= ST_END_BLOCK_DATA
;
6300 target
= " block data";
6305 *st
= ST_END_MODULE
;
6310 case COMP_SUBMODULE
:
6311 *st
= ST_END_SUBMODULE
;
6312 target
= " submodule";
6316 case COMP_INTERFACE
:
6317 *st
= ST_END_INTERFACE
;
6318 target
= " interface";
6323 case COMP_DERIVED_CONTAINS
:
6329 case COMP_ASSOCIATE
:
6330 *st
= ST_END_ASSOCIATE
;
6331 target
= " associate";
6348 case COMP_DO_CONCURRENT
:
6355 *st
= ST_END_CRITICAL
;
6356 target
= " critical";
6361 case COMP_SELECT_TYPE
:
6362 *st
= ST_END_SELECT
;
6368 *st
= ST_END_FORALL
;
6383 last_initializer
= NULL
;
6385 gfc_free_enum_history ();
6389 gfc_error ("Unexpected END statement at %C");
6393 old_loc
= gfc_current_locus
;
6394 if (gfc_match_eos () == MATCH_YES
)
6396 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6398 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6399 "instead of %s statement at %L",
6400 abreviated_modproc_decl
? "END PROCEDURE"
6401 : gfc_ascii_statement(*st
), &old_loc
))
6406 /* We would have required END [something]. */
6407 gfc_error ("%s statement expected at %L",
6408 gfc_ascii_statement (*st
), &old_loc
);
6415 /* Verify that we've got the sort of end-block that we're expecting. */
6416 if (gfc_match (target
) != MATCH_YES
)
6418 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6419 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6423 old_loc
= gfc_current_locus
;
6424 /* If we're at the end, make sure a block name wasn't required. */
6425 if (gfc_match_eos () == MATCH_YES
)
6428 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6429 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6430 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6436 gfc_error ("Expected block name of %qs in %s statement at %L",
6437 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6442 /* END INTERFACE has a special handler for its several possible endings. */
6443 if (*st
== ST_END_INTERFACE
)
6444 return gfc_match_end_interface ();
6446 /* We haven't hit the end of statement, so what is left must be an
6448 m
= gfc_match_space ();
6450 m
= gfc_match_name (name
);
6453 gfc_error ("Expected terminating name at %C");
6457 if (block_name
== NULL
)
6460 /* We have to pick out the declared submodule name from the composite
6461 required by F2008:11.2.3 para 2, which ends in the declared name. */
6462 if (state
== COMP_SUBMODULE
)
6463 block_name
= strchr (block_name
, '.') + 1;
6465 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6467 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6468 gfc_ascii_statement (*st
));
6471 /* Procedure pointer as function result. */
6472 else if (strcmp (block_name
, "ppr@") == 0
6473 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6475 gfc_error ("Expected label %qs for %s statement at %C",
6476 gfc_current_block ()->ns
->proc_name
->name
,
6477 gfc_ascii_statement (*st
));
6481 if (gfc_match_eos () == MATCH_YES
)
6485 gfc_syntax_error (*st
);
6488 gfc_current_locus
= old_loc
;
6490 /* If we are missing an END BLOCK, we created a half-ready namespace.
6491 Remove it from the parent namespace's sibling list. */
6493 while (state
== COMP_BLOCK
)
6495 parent_ns
= gfc_current_ns
->parent
;
6497 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6503 if (ns
== gfc_current_ns
)
6505 if (prev_ns
== NULL
)
6508 prev_ns
->sibling
= ns
->sibling
;
6514 gfc_free_namespace (gfc_current_ns
);
6515 gfc_current_ns
= parent_ns
;
6516 gfc_state_stack
= gfc_state_stack
->previous
;
6517 state
= gfc_current_state ();
6525 /***************** Attribute declaration statements ****************/
6527 /* Set the attribute of a single variable. */
6532 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6535 /* Workaround -Wmaybe-uninitialized false positive during
6536 profiledbootstrap by initializing them. */
6537 gfc_symbol
*sym
= NULL
;
6543 m
= gfc_match_name (name
);
6547 if (find_special (name
, &sym
, false))
6550 if (!check_function_name (name
))
6556 var_locus
= gfc_current_locus
;
6558 /* Deal with possible array specification for certain attributes. */
6559 if (current_attr
.dimension
6560 || current_attr
.codimension
6561 || current_attr
.allocatable
6562 || current_attr
.pointer
6563 || current_attr
.target
)
6565 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6566 !current_attr
.dimension
6567 && !current_attr
.pointer
6568 && !current_attr
.target
);
6569 if (m
== MATCH_ERROR
)
6572 if (current_attr
.dimension
&& m
== MATCH_NO
)
6574 gfc_error ("Missing array specification at %L in DIMENSION "
6575 "statement", &var_locus
);
6580 if (current_attr
.dimension
&& sym
->value
)
6582 gfc_error ("Dimensions specified for %s at %L after its "
6583 "initialisation", sym
->name
, &var_locus
);
6588 if (current_attr
.codimension
&& m
== MATCH_NO
)
6590 gfc_error ("Missing array specification at %L in CODIMENSION "
6591 "statement", &var_locus
);
6596 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6597 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6599 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6605 /* Update symbol table. DIMENSION attribute is set in
6606 gfc_set_array_spec(). For CLASS variables, this must be applied
6607 to the first component, or '_data' field. */
6608 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6610 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6618 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6619 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6626 if (sym
->ts
.type
== BT_CLASS
6627 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6633 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6639 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6641 /* Fix the array spec. */
6642 m
= gfc_mod_pointee_as (sym
->as
);
6643 if (m
== MATCH_ERROR
)
6647 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6653 if ((current_attr
.external
|| current_attr
.intrinsic
)
6654 && sym
->attr
.flavor
!= FL_PROCEDURE
6655 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6661 add_hidden_procptr_result (sym
);
6666 gfc_free_array_spec (as
);
6671 /* Generic attribute declaration subroutine. Used for attributes that
6672 just have a list of names. */
6679 /* Gobble the optional double colon, by simply ignoring the result
6689 if (gfc_match_eos () == MATCH_YES
)
6695 if (gfc_match_char (',') != MATCH_YES
)
6697 gfc_error ("Unexpected character in variable list at %C");
6707 /* This routine matches Cray Pointer declarations of the form:
6708 pointer ( <pointer>, <pointee> )
6710 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6711 The pointer, if already declared, should be an integer. Otherwise, we
6712 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6713 be either a scalar, or an array declaration. No space is allocated for
6714 the pointee. For the statement
6715 pointer (ipt, ar(10))
6716 any subsequent uses of ar will be translated (in C-notation) as
6717 ar(i) => ((<type> *) ipt)(i)
6718 After gimplification, pointee variable will disappear in the code. */
6721 cray_pointer_decl (void)
6724 gfc_array_spec
*as
= NULL
;
6725 gfc_symbol
*cptr
; /* Pointer symbol. */
6726 gfc_symbol
*cpte
; /* Pointee symbol. */
6732 if (gfc_match_char ('(') != MATCH_YES
)
6734 gfc_error ("Expected %<(%> at %C");
6738 /* Match pointer. */
6739 var_locus
= gfc_current_locus
;
6740 gfc_clear_attr (¤t_attr
);
6741 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6742 current_ts
.type
= BT_INTEGER
;
6743 current_ts
.kind
= gfc_index_integer_kind
;
6745 m
= gfc_match_symbol (&cptr
, 0);
6748 gfc_error ("Expected variable name at %C");
6752 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6755 gfc_set_sym_referenced (cptr
);
6757 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6759 cptr
->ts
.type
= BT_INTEGER
;
6760 cptr
->ts
.kind
= gfc_index_integer_kind
;
6762 else if (cptr
->ts
.type
!= BT_INTEGER
)
6764 gfc_error ("Cray pointer at %C must be an integer");
6767 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6768 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6769 " memory addresses require %d bytes",
6770 cptr
->ts
.kind
, gfc_index_integer_kind
);
6772 if (gfc_match_char (',') != MATCH_YES
)
6774 gfc_error ("Expected \",\" at %C");
6778 /* Match Pointee. */
6779 var_locus
= gfc_current_locus
;
6780 gfc_clear_attr (¤t_attr
);
6781 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6782 current_ts
.type
= BT_UNKNOWN
;
6783 current_ts
.kind
= 0;
6785 m
= gfc_match_symbol (&cpte
, 0);
6788 gfc_error ("Expected variable name at %C");
6792 /* Check for an optional array spec. */
6793 m
= gfc_match_array_spec (&as
, true, false);
6794 if (m
== MATCH_ERROR
)
6796 gfc_free_array_spec (as
);
6799 else if (m
== MATCH_NO
)
6801 gfc_free_array_spec (as
);
6805 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6808 gfc_set_sym_referenced (cpte
);
6810 if (cpte
->as
== NULL
)
6812 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6813 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6815 else if (as
!= NULL
)
6817 gfc_error ("Duplicate array spec for Cray pointee at %C");
6818 gfc_free_array_spec (as
);
6824 if (cpte
->as
!= NULL
)
6826 /* Fix array spec. */
6827 m
= gfc_mod_pointee_as (cpte
->as
);
6828 if (m
== MATCH_ERROR
)
6832 /* Point the Pointee at the Pointer. */
6833 cpte
->cp_pointer
= cptr
;
6835 if (gfc_match_char (')') != MATCH_YES
)
6837 gfc_error ("Expected \")\" at %C");
6840 m
= gfc_match_char (',');
6842 done
= true; /* Stop searching for more declarations. */
6846 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6847 || gfc_match_eos () != MATCH_YES
)
6849 gfc_error ("Expected %<,%> or end of statement at %C");
6857 gfc_match_external (void)
6860 gfc_clear_attr (¤t_attr
);
6861 current_attr
.external
= 1;
6863 return attr_decl ();
6868 gfc_match_intent (void)
6872 /* This is not allowed within a BLOCK construct! */
6873 if (gfc_current_state () == COMP_BLOCK
)
6875 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6879 intent
= match_intent_spec ();
6880 if (intent
== INTENT_UNKNOWN
)
6883 gfc_clear_attr (¤t_attr
);
6884 current_attr
.intent
= intent
;
6886 return attr_decl ();
6891 gfc_match_intrinsic (void)
6894 gfc_clear_attr (¤t_attr
);
6895 current_attr
.intrinsic
= 1;
6897 return attr_decl ();
6902 gfc_match_optional (void)
6904 /* This is not allowed within a BLOCK construct! */
6905 if (gfc_current_state () == COMP_BLOCK
)
6907 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6911 gfc_clear_attr (¤t_attr
);
6912 current_attr
.optional
= 1;
6914 return attr_decl ();
6919 gfc_match_pointer (void)
6921 gfc_gobble_whitespace ();
6922 if (gfc_peek_ascii_char () == '(')
6924 if (!flag_cray_pointer
)
6926 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6930 return cray_pointer_decl ();
6934 gfc_clear_attr (¤t_attr
);
6935 current_attr
.pointer
= 1;
6937 return attr_decl ();
6943 gfc_match_allocatable (void)
6945 gfc_clear_attr (¤t_attr
);
6946 current_attr
.allocatable
= 1;
6948 return attr_decl ();
6953 gfc_match_codimension (void)
6955 gfc_clear_attr (¤t_attr
);
6956 current_attr
.codimension
= 1;
6958 return attr_decl ();
6963 gfc_match_contiguous (void)
6965 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6968 gfc_clear_attr (¤t_attr
);
6969 current_attr
.contiguous
= 1;
6971 return attr_decl ();
6976 gfc_match_dimension (void)
6978 gfc_clear_attr (¤t_attr
);
6979 current_attr
.dimension
= 1;
6981 return attr_decl ();
6986 gfc_match_target (void)
6988 gfc_clear_attr (¤t_attr
);
6989 current_attr
.target
= 1;
6991 return attr_decl ();
6995 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6999 access_attr_decl (gfc_statement st
)
7001 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7002 interface_type type
;
7004 gfc_symbol
*sym
, *dt_sym
;
7005 gfc_intrinsic_op op
;
7008 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7013 m
= gfc_match_generic_spec (&type
, name
, &op
);
7016 if (m
== MATCH_ERROR
)
7021 case INTERFACE_NAMELESS
:
7022 case INTERFACE_ABSTRACT
:
7025 case INTERFACE_GENERIC
:
7026 if (gfc_get_symbol (name
, NULL
, &sym
))
7029 if (!gfc_add_access (&sym
->attr
,
7031 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7035 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7036 && !gfc_add_access (&dt_sym
->attr
,
7038 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7044 case INTERFACE_INTRINSIC_OP
:
7045 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7047 gfc_intrinsic_op other_op
;
7049 gfc_current_ns
->operator_access
[op
] =
7050 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7052 /* Handle the case if there is another op with the same
7053 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7054 other_op
= gfc_equivalent_op (op
);
7056 if (other_op
!= INTRINSIC_NONE
)
7057 gfc_current_ns
->operator_access
[other_op
] =
7058 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7063 gfc_error ("Access specification of the %s operator at %C has "
7064 "already been specified", gfc_op2string (op
));
7070 case INTERFACE_USER_OP
:
7071 uop
= gfc_get_uop (name
);
7073 if (uop
->access
== ACCESS_UNKNOWN
)
7075 uop
->access
= (st
== ST_PUBLIC
)
7076 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7080 gfc_error ("Access specification of the .%s. operator at %C "
7081 "has already been specified", sym
->name
);
7088 if (gfc_match_char (',') == MATCH_NO
)
7092 if (gfc_match_eos () != MATCH_YES
)
7097 gfc_syntax_error (st
);
7105 gfc_match_protected (void)
7110 if (!gfc_current_ns
->proc_name
7111 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7113 gfc_error ("PROTECTED at %C only allowed in specification "
7114 "part of a module");
7119 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7122 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7127 if (gfc_match_eos () == MATCH_YES
)
7132 m
= gfc_match_symbol (&sym
, 0);
7136 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7148 if (gfc_match_eos () == MATCH_YES
)
7150 if (gfc_match_char (',') != MATCH_YES
)
7157 gfc_error ("Syntax error in PROTECTED statement at %C");
7162 /* The PRIVATE statement is a bit weird in that it can be an attribute
7163 declaration, but also works as a standalone statement inside of a
7164 type declaration or a module. */
7167 gfc_match_private (gfc_statement
*st
)
7170 if (gfc_match ("private") != MATCH_YES
)
7173 if (gfc_current_state () != COMP_MODULE
7174 && !(gfc_current_state () == COMP_DERIVED
7175 && gfc_state_stack
->previous
7176 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7177 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7178 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7179 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7181 gfc_error ("PRIVATE statement at %C is only allowed in the "
7182 "specification part of a module");
7186 if (gfc_current_state () == COMP_DERIVED
)
7188 if (gfc_match_eos () == MATCH_YES
)
7194 gfc_syntax_error (ST_PRIVATE
);
7198 if (gfc_match_eos () == MATCH_YES
)
7205 return access_attr_decl (ST_PRIVATE
);
7210 gfc_match_public (gfc_statement
*st
)
7213 if (gfc_match ("public") != MATCH_YES
)
7216 if (gfc_current_state () != COMP_MODULE
)
7218 gfc_error ("PUBLIC statement at %C is only allowed in the "
7219 "specification part of a module");
7223 if (gfc_match_eos () == MATCH_YES
)
7230 return access_attr_decl (ST_PUBLIC
);
7234 /* Workhorse for gfc_match_parameter. */
7244 m
= gfc_match_symbol (&sym
, 0);
7246 gfc_error ("Expected variable name at %C in PARAMETER statement");
7251 if (gfc_match_char ('=') == MATCH_NO
)
7253 gfc_error ("Expected = sign in PARAMETER statement at %C");
7257 m
= gfc_match_init_expr (&init
);
7259 gfc_error ("Expected expression at %C in PARAMETER statement");
7263 if (sym
->ts
.type
== BT_UNKNOWN
7264 && !gfc_set_default_type (sym
, 1, NULL
))
7270 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7271 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7279 gfc_error ("Initializing already initialized variable at %C");
7284 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7285 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7288 gfc_free_expr (init
);
7293 /* Match a parameter statement, with the weird syntax that these have. */
7296 gfc_match_parameter (void)
7300 if (gfc_match_char ('(') == MATCH_NO
)
7309 if (gfc_match (" )%t") == MATCH_YES
)
7312 if (gfc_match_char (',') != MATCH_YES
)
7314 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7324 /* Save statements have a special syntax. */
7327 gfc_match_save (void)
7329 char n
[GFC_MAX_SYMBOL_LEN
+1];
7334 if (gfc_match_eos () == MATCH_YES
)
7336 if (gfc_current_ns
->seen_save
)
7338 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7339 "follows previous SAVE statement"))
7343 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7347 if (gfc_current_ns
->save_all
)
7349 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7350 "blanket SAVE statement"))
7358 m
= gfc_match_symbol (&sym
, 0);
7362 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7363 &gfc_current_locus
))
7374 m
= gfc_match (" / %n /", &n
);
7375 if (m
== MATCH_ERROR
)
7380 c
= gfc_get_common (n
, 0);
7383 gfc_current_ns
->seen_save
= 1;
7386 if (gfc_match_eos () == MATCH_YES
)
7388 if (gfc_match_char (',') != MATCH_YES
)
7395 gfc_error ("Syntax error in SAVE statement at %C");
7401 gfc_match_value (void)
7406 /* This is not allowed within a BLOCK construct! */
7407 if (gfc_current_state () == COMP_BLOCK
)
7409 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7413 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7416 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7421 if (gfc_match_eos () == MATCH_YES
)
7426 m
= gfc_match_symbol (&sym
, 0);
7430 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7442 if (gfc_match_eos () == MATCH_YES
)
7444 if (gfc_match_char (',') != MATCH_YES
)
7451 gfc_error ("Syntax error in VALUE statement at %C");
7457 gfc_match_volatile (void)
7462 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7465 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7470 if (gfc_match_eos () == MATCH_YES
)
7475 /* VOLATILE is special because it can be added to host-associated
7476 symbols locally. Except for coarrays. */
7477 m
= gfc_match_symbol (&sym
, 1);
7481 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7482 for variable in a BLOCK which is defined outside of the BLOCK. */
7483 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7485 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7486 "%C, which is use-/host-associated", sym
->name
);
7489 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7501 if (gfc_match_eos () == MATCH_YES
)
7503 if (gfc_match_char (',') != MATCH_YES
)
7510 gfc_error ("Syntax error in VOLATILE statement at %C");
7516 gfc_match_asynchronous (void)
7521 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7524 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7529 if (gfc_match_eos () == MATCH_YES
)
7534 /* ASYNCHRONOUS is special because it can be added to host-associated
7536 m
= gfc_match_symbol (&sym
, 1);
7540 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7552 if (gfc_match_eos () == MATCH_YES
)
7554 if (gfc_match_char (',') != MATCH_YES
)
7561 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7566 /* Match a module procedure statement in a submodule. */
7569 gfc_match_submod_proc (void)
7571 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7572 gfc_symbol
*sym
, *fsym
;
7574 gfc_formal_arglist
*formal
, *head
, *tail
;
7576 if (gfc_current_state () != COMP_CONTAINS
7577 || !(gfc_state_stack
->previous
7578 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7581 m
= gfc_match (" module% procedure% %n", name
);
7585 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7589 if (get_proc_name (name
, &sym
, false))
7592 /* Make sure that the result field is appropriately filled, even though
7593 the result symbol will be replaced later on. */
7594 if (sym
->ts
.interface
->attr
.function
)
7596 if (sym
->ts
.interface
->result
7597 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7598 sym
->result
= sym
->ts
.interface
->result
;
7603 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7604 the symbol existed before. */
7605 sym
->declared_at
= gfc_current_locus
;
7607 if (!sym
->attr
.module_procedure
)
7610 /* Signal match_end to expect "end procedure". */
7611 sym
->abr_modproc_decl
= 1;
7613 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7614 sym
->attr
.if_source
= IFSRC_DECL
;
7616 gfc_new_block
= sym
;
7618 /* Make a new formal arglist with the symbols in the procedure
7621 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7623 if (formal
== sym
->formal
)
7624 head
= tail
= gfc_get_formal_arglist ();
7627 tail
->next
= gfc_get_formal_arglist ();
7631 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7635 gfc_set_sym_referenced (fsym
);
7638 /* The dummy symbols get cleaned up, when the formal_namespace of the
7639 interface declaration is cleared. This allows us to add the
7640 explicit interface as is done for other type of procedure. */
7641 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7642 &gfc_current_locus
))
7645 if (gfc_match_eos () != MATCH_YES
)
7647 gfc_syntax_error (ST_MODULE_PROC
);
7654 gfc_free_formal_arglist (head
);
7659 /* Match a module procedure statement. Note that we have to modify
7660 symbols in the parent's namespace because the current one was there
7661 to receive symbols that are in an interface's formal argument list. */
7664 gfc_match_modproc (void)
7666 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7670 gfc_namespace
*module_ns
;
7671 gfc_interface
*old_interface_head
, *interface
;
7673 if (gfc_state_stack
->state
!= COMP_INTERFACE
7674 || gfc_state_stack
->previous
== NULL
7675 || current_interface
.type
== INTERFACE_NAMELESS
7676 || current_interface
.type
== INTERFACE_ABSTRACT
)
7678 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7683 module_ns
= gfc_current_ns
->parent
;
7684 for (; module_ns
; module_ns
= module_ns
->parent
)
7685 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7686 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7687 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7688 && !module_ns
->proc_name
->attr
.contained
))
7691 if (module_ns
== NULL
)
7694 /* Store the current state of the interface. We will need it if we
7695 end up with a syntax error and need to recover. */
7696 old_interface_head
= gfc_current_interface_head ();
7698 /* Check if the F2008 optional double colon appears. */
7699 gfc_gobble_whitespace ();
7700 old_locus
= gfc_current_locus
;
7701 if (gfc_match ("::") == MATCH_YES
)
7703 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7704 "MODULE PROCEDURE statement at %L", &old_locus
))
7708 gfc_current_locus
= old_locus
;
7713 old_locus
= gfc_current_locus
;
7715 m
= gfc_match_name (name
);
7721 /* Check for syntax error before starting to add symbols to the
7722 current namespace. */
7723 if (gfc_match_eos () == MATCH_YES
)
7726 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7729 /* Now we're sure the syntax is valid, we process this item
7731 if (gfc_get_symbol (name
, module_ns
, &sym
))
7734 if (sym
->attr
.intrinsic
)
7736 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7737 "PROCEDURE", &old_locus
);
7741 if (sym
->attr
.proc
!= PROC_MODULE
7742 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7745 if (!gfc_add_interface (sym
))
7748 sym
->attr
.mod_proc
= 1;
7749 sym
->declared_at
= old_locus
;
7758 /* Restore the previous state of the interface. */
7759 interface
= gfc_current_interface_head ();
7760 gfc_set_current_interface_head (old_interface_head
);
7762 /* Free the new interfaces. */
7763 while (interface
!= old_interface_head
)
7765 gfc_interface
*i
= interface
->next
;
7770 /* And issue a syntax error. */
7771 gfc_syntax_error (ST_MODULE_PROC
);
7776 /* Check a derived type that is being extended. */
7779 check_extended_derived_type (char *name
)
7781 gfc_symbol
*extended
;
7783 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7785 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7789 extended
= gfc_find_dt_in_generic (extended
);
7794 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7798 if (extended
->attr
.flavor
!= FL_DERIVED
)
7800 gfc_error ("%qs in EXTENDS expression at %C is not a "
7801 "derived type", name
);
7805 if (extended
->attr
.is_bind_c
)
7807 gfc_error ("%qs cannot be extended at %C because it "
7808 "is BIND(C)", extended
->name
);
7812 if (extended
->attr
.sequence
)
7814 gfc_error ("%qs cannot be extended at %C because it "
7815 "is a SEQUENCE type", extended
->name
);
7823 /* Match the optional attribute specifiers for a type declaration.
7824 Return MATCH_ERROR if an error is encountered in one of the handled
7825 attributes (public, private, bind(c)), MATCH_NO if what's found is
7826 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7827 checking on attribute conflicts needs to be done. */
7830 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7832 /* See if the derived type is marked as private. */
7833 if (gfc_match (" , private") == MATCH_YES
)
7835 if (gfc_current_state () != COMP_MODULE
)
7837 gfc_error ("Derived type at %C can only be PRIVATE in the "
7838 "specification part of a module");
7842 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7845 else if (gfc_match (" , public") == MATCH_YES
)
7847 if (gfc_current_state () != COMP_MODULE
)
7849 gfc_error ("Derived type at %C can only be PUBLIC in the "
7850 "specification part of a module");
7854 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7857 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7859 /* If the type is defined to be bind(c) it then needs to make
7860 sure that all fields are interoperable. This will
7861 need to be a semantic check on the finished derived type.
7862 See 15.2.3 (lines 9-12) of F2003 draft. */
7863 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7866 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7868 else if (gfc_match (" , abstract") == MATCH_YES
)
7870 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7873 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7876 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7878 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7884 /* If we get here, something matched. */
7889 /* Match the beginning of a derived type declaration. If a type name
7890 was the result of a function, then it is possible to have a symbol
7891 already to be known as a derived type yet have no components. */
7894 gfc_match_derived_decl (void)
7896 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7897 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7898 symbol_attribute attr
;
7899 gfc_symbol
*sym
, *gensym
;
7900 gfc_symbol
*extended
;
7902 match is_type_attr_spec
= MATCH_NO
;
7903 bool seen_attr
= false;
7904 gfc_interface
*intr
= NULL
, *head
;
7906 if (gfc_current_state () == COMP_DERIVED
)
7911 gfc_clear_attr (&attr
);
7916 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7917 if (is_type_attr_spec
== MATCH_ERROR
)
7919 if (is_type_attr_spec
== MATCH_YES
)
7921 } while (is_type_attr_spec
== MATCH_YES
);
7923 /* Deal with derived type extensions. The extension attribute has
7924 been added to 'attr' but now the parent type must be found and
7927 extended
= check_extended_derived_type (parent
);
7929 if (parent
[0] && !extended
)
7932 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7934 gfc_error ("Expected :: in TYPE definition at %C");
7938 m
= gfc_match (" %n%t", name
);
7942 /* Make sure the name is not the name of an intrinsic type. */
7943 if (gfc_is_intrinsic_typename (name
))
7945 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
7950 if (gfc_get_symbol (name
, NULL
, &gensym
))
7953 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7955 gfc_error ("Derived type name %qs at %C already has a basic type "
7956 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7960 if (!gensym
->attr
.generic
7961 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7964 if (!gensym
->attr
.function
7965 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7968 sym
= gfc_find_dt_in_generic (gensym
);
7970 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7972 gfc_error ("Derived type definition of %qs at %C has already been "
7973 "defined", sym
->name
);
7979 /* Use upper case to save the actual derived-type symbol. */
7980 gfc_get_symbol (gfc_get_string ("%c%s",
7981 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7982 &gensym
->name
[1]), NULL
, &sym
);
7983 sym
->name
= gfc_get_string (gensym
->name
);
7984 head
= gensym
->generic
;
7985 intr
= gfc_get_interface ();
7987 intr
->where
= gfc_current_locus
;
7988 intr
->sym
->declared_at
= gfc_current_locus
;
7990 gensym
->generic
= intr
;
7991 gensym
->attr
.if_source
= IFSRC_DECL
;
7994 /* The symbol may already have the derived attribute without the
7995 components. The ways this can happen is via a function
7996 definition, an INTRINSIC statement or a subtype in another
7997 derived type that is a pointer. The first part of the AND clause
7998 is true if the symbol is not the return value of a function. */
7999 if (sym
->attr
.flavor
!= FL_DERIVED
8000 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8003 if (attr
.access
!= ACCESS_UNKNOWN
8004 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8006 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8007 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8008 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8012 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8013 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8014 gensym
->attr
.access
= sym
->attr
.access
;
8016 /* See if the derived type was labeled as bind(c). */
8017 if (attr
.is_bind_c
!= 0)
8018 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8020 /* Construct the f2k_derived namespace if it is not yet there. */
8021 if (!sym
->f2k_derived
)
8022 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8024 if (extended
&& !sym
->components
)
8028 /* Add the extended derived type as the first component. */
8029 gfc_add_component (sym
, parent
, &p
);
8031 gfc_set_sym_referenced (extended
);
8033 p
->ts
.type
= BT_DERIVED
;
8034 p
->ts
.u
.derived
= extended
;
8035 p
->initializer
= gfc_default_initializer (&p
->ts
);
8037 /* Set extension level. */
8038 if (extended
->attr
.extension
== 255)
8040 /* Since the extension field is 8 bit wide, we can only have
8041 up to 255 extension levels. */
8042 gfc_error ("Maximum extension level reached with type %qs at %L",
8043 extended
->name
, &extended
->declared_at
);
8046 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8048 /* Provide the links between the extended type and its extension. */
8049 if (!extended
->f2k_derived
)
8050 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8053 if (!sym
->hash_value
)
8054 /* Set the hash for the compound name for this type. */
8055 sym
->hash_value
= gfc_hash_value (sym
);
8057 /* Take over the ABSTRACT attribute. */
8058 sym
->attr
.abstract
= attr
.abstract
;
8060 gfc_new_block
= sym
;
8066 /* Cray Pointees can be declared as:
8067 pointer (ipt, a (n,m,...,*)) */
8070 gfc_mod_pointee_as (gfc_array_spec
*as
)
8072 as
->cray_pointee
= true; /* This will be useful to know later. */
8073 if (as
->type
== AS_ASSUMED_SIZE
)
8074 as
->cp_was_assumed
= true;
8075 else if (as
->type
== AS_ASSUMED_SHAPE
)
8077 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8084 /* Match the enum definition statement, here we are trying to match
8085 the first line of enum definition statement.
8086 Returns MATCH_YES if match is found. */
8089 gfc_match_enum (void)
8093 m
= gfc_match_eos ();
8097 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8104 /* Returns an initializer whose value is one higher than the value of the
8105 LAST_INITIALIZER argument. If the argument is NULL, the
8106 initializers value will be set to zero. The initializer's kind
8107 will be set to gfc_c_int_kind.
8109 If -fshort-enums is given, the appropriate kind will be selected
8110 later after all enumerators have been parsed. A warning is issued
8111 here if an initializer exceeds gfc_c_int_kind. */
8114 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8117 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8119 mpz_init (result
->value
.integer
);
8121 if (last_initializer
!= NULL
)
8123 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8124 result
->where
= last_initializer
->where
;
8126 if (gfc_check_integer_range (result
->value
.integer
,
8127 gfc_c_int_kind
) != ARITH_OK
)
8129 gfc_error ("Enumerator exceeds the C integer type at %C");
8135 /* Control comes here, if it's the very first enumerator and no
8136 initializer has been given. It will be initialized to zero. */
8137 mpz_set_si (result
->value
.integer
, 0);
8144 /* Match a variable name with an optional initializer. When this
8145 subroutine is called, a variable is expected to be parsed next.
8146 Depending on what is happening at the moment, updates either the
8147 symbol table or the current interface. */
8150 enumerator_decl (void)
8152 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8153 gfc_expr
*initializer
;
8154 gfc_array_spec
*as
= NULL
;
8162 old_locus
= gfc_current_locus
;
8164 /* When we get here, we've just matched a list of attributes and
8165 maybe a type and a double colon. The next thing we expect to see
8166 is the name of the symbol. */
8167 m
= gfc_match_name (name
);
8171 var_locus
= gfc_current_locus
;
8173 /* OK, we've successfully matched the declaration. Now put the
8174 symbol in the current namespace. If we fail to create the symbol,
8176 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8182 /* The double colon must be present in order to have initializers.
8183 Otherwise the statement is ambiguous with an assignment statement. */
8186 if (gfc_match_char ('=') == MATCH_YES
)
8188 m
= gfc_match_init_expr (&initializer
);
8191 gfc_error ("Expected an initialization expression at %C");
8200 /* If we do not have an initializer, the initialization value of the
8201 previous enumerator (stored in last_initializer) is incremented
8202 by 1 and is used to initialize the current enumerator. */
8203 if (initializer
== NULL
)
8204 initializer
= enum_initializer (last_initializer
, old_locus
);
8206 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8208 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8214 /* Store this current initializer, for the next enumerator variable
8215 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8216 use last_initializer below. */
8217 last_initializer
= initializer
;
8218 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8220 /* Maintain enumerator history. */
8221 gfc_find_symbol (name
, NULL
, 0, &sym
);
8222 create_enum_history (sym
, last_initializer
);
8224 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8227 /* Free stuff up and return. */
8228 gfc_free_expr (initializer
);
8234 /* Match the enumerator definition statement. */
8237 gfc_match_enumerator_def (void)
8242 gfc_clear_ts (¤t_ts
);
8244 m
= gfc_match (" enumerator");
8248 m
= gfc_match (" :: ");
8249 if (m
== MATCH_ERROR
)
8252 colon_seen
= (m
== MATCH_YES
);
8254 if (gfc_current_state () != COMP_ENUM
)
8256 gfc_error ("ENUM definition statement expected before %C");
8257 gfc_free_enum_history ();
8261 (¤t_ts
)->type
= BT_INTEGER
;
8262 (¤t_ts
)->kind
= gfc_c_int_kind
;
8264 gfc_clear_attr (¤t_attr
);
8265 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8274 m
= enumerator_decl ();
8275 if (m
== MATCH_ERROR
)
8277 gfc_free_enum_history ();
8283 if (gfc_match_eos () == MATCH_YES
)
8285 if (gfc_match_char (',') != MATCH_YES
)
8289 if (gfc_current_state () == COMP_ENUM
)
8291 gfc_free_enum_history ();
8292 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8297 gfc_free_array_spec (current_as
);
8304 /* Match binding attributes. */
8307 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8309 bool found_passing
= false;
8310 bool seen_ptr
= false;
8311 match m
= MATCH_YES
;
8313 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8314 this case the defaults are in there. */
8315 ba
->access
= ACCESS_UNKNOWN
;
8316 ba
->pass_arg
= NULL
;
8317 ba
->pass_arg_num
= 0;
8319 ba
->non_overridable
= 0;
8323 /* If we find a comma, we believe there are binding attributes. */
8324 m
= gfc_match_char (',');
8330 /* Access specifier. */
8332 m
= gfc_match (" public");
8333 if (m
== MATCH_ERROR
)
8337 if (ba
->access
!= ACCESS_UNKNOWN
)
8339 gfc_error ("Duplicate access-specifier at %C");
8343 ba
->access
= ACCESS_PUBLIC
;
8347 m
= gfc_match (" private");
8348 if (m
== MATCH_ERROR
)
8352 if (ba
->access
!= ACCESS_UNKNOWN
)
8354 gfc_error ("Duplicate access-specifier at %C");
8358 ba
->access
= ACCESS_PRIVATE
;
8362 /* If inside GENERIC, the following is not allowed. */
8367 m
= gfc_match (" nopass");
8368 if (m
== MATCH_ERROR
)
8374 gfc_error ("Binding attributes already specify passing,"
8375 " illegal NOPASS at %C");
8379 found_passing
= true;
8384 /* PASS possibly including argument. */
8385 m
= gfc_match (" pass");
8386 if (m
== MATCH_ERROR
)
8390 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8394 gfc_error ("Binding attributes already specify passing,"
8395 " illegal PASS at %C");
8399 m
= gfc_match (" ( %n )", arg
);
8400 if (m
== MATCH_ERROR
)
8403 ba
->pass_arg
= gfc_get_string (arg
);
8404 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8406 found_passing
= true;
8414 m
= gfc_match (" pointer");
8415 if (m
== MATCH_ERROR
)
8421 gfc_error ("Duplicate POINTER attribute at %C");
8431 /* NON_OVERRIDABLE flag. */
8432 m
= gfc_match (" non_overridable");
8433 if (m
== MATCH_ERROR
)
8437 if (ba
->non_overridable
)
8439 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8443 ba
->non_overridable
= 1;
8447 /* DEFERRED flag. */
8448 m
= gfc_match (" deferred");
8449 if (m
== MATCH_ERROR
)
8455 gfc_error ("Duplicate DEFERRED at %C");
8466 /* Nothing matching found. */
8468 gfc_error ("Expected access-specifier at %C");
8470 gfc_error ("Expected binding attribute at %C");
8473 while (gfc_match_char (',') == MATCH_YES
);
8475 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8476 if (ba
->non_overridable
&& ba
->deferred
)
8478 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8485 if (ba
->access
== ACCESS_UNKNOWN
)
8486 ba
->access
= gfc_typebound_default_access
;
8488 if (ppc
&& !seen_ptr
)
8490 gfc_error ("POINTER attribute is required for procedure pointer component"
8502 /* Match a PROCEDURE specific binding inside a derived type. */
8505 match_procedure_in_type (void)
8507 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8508 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8509 char* target
= NULL
, *ifc
= NULL
;
8510 gfc_typebound_proc tb
;
8519 /* Check current state. */
8520 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8521 block
= gfc_state_stack
->previous
->sym
;
8524 /* Try to match PROCEDURE(interface). */
8525 if (gfc_match (" (") == MATCH_YES
)
8527 m
= gfc_match_name (target_buf
);
8528 if (m
== MATCH_ERROR
)
8532 gfc_error ("Interface-name expected after %<(%> at %C");
8536 if (gfc_match (" )") != MATCH_YES
)
8538 gfc_error ("%<)%> expected at %C");
8545 /* Construct the data structure. */
8546 memset (&tb
, 0, sizeof (tb
));
8547 tb
.where
= gfc_current_locus
;
8549 /* Match binding attributes. */
8550 m
= match_binding_attributes (&tb
, false, false);
8551 if (m
== MATCH_ERROR
)
8553 seen_attrs
= (m
== MATCH_YES
);
8555 /* Check that attribute DEFERRED is given if an interface is specified. */
8556 if (tb
.deferred
&& !ifc
)
8558 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8561 if (ifc
&& !tb
.deferred
)
8563 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8567 /* Match the colons. */
8568 m
= gfc_match (" ::");
8569 if (m
== MATCH_ERROR
)
8571 seen_colons
= (m
== MATCH_YES
);
8572 if (seen_attrs
&& !seen_colons
)
8574 gfc_error ("Expected %<::%> after binding-attributes at %C");
8578 /* Match the binding names. */
8581 m
= gfc_match_name (name
);
8582 if (m
== MATCH_ERROR
)
8586 gfc_error ("Expected binding name at %C");
8590 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8593 /* Try to match the '=> target', if it's there. */
8595 m
= gfc_match (" =>");
8596 if (m
== MATCH_ERROR
)
8602 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8608 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8613 m
= gfc_match_name (target_buf
);
8614 if (m
== MATCH_ERROR
)
8618 gfc_error ("Expected binding target after %<=>%> at %C");
8621 target
= target_buf
;
8624 /* If no target was found, it has the same name as the binding. */
8628 /* Get the namespace to insert the symbols into. */
8629 ns
= block
->f2k_derived
;
8632 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8633 if (tb
.deferred
&& !block
->attr
.abstract
)
8635 gfc_error ("Type %qs containing DEFERRED binding at %C "
8636 "is not ABSTRACT", block
->name
);
8640 /* See if we already have a binding with this name in the symtree which
8641 would be an error. If a GENERIC already targeted this binding, it may
8642 be already there but then typebound is still NULL. */
8643 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8644 if (stree
&& stree
->n
.tb
)
8646 gfc_error ("There is already a procedure with binding name %qs for "
8647 "the derived type %qs at %C", name
, block
->name
);
8651 /* Insert it and set attributes. */
8655 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8658 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8660 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8663 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8665 if (gfc_match_eos () == MATCH_YES
)
8667 if (gfc_match_char (',') != MATCH_YES
)
8672 gfc_error ("Syntax error in PROCEDURE statement at %C");
8677 /* Match a GENERIC procedure binding inside a derived type. */
8680 gfc_match_generic (void)
8682 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8683 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8685 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8686 gfc_typebound_proc
* tb
;
8688 interface_type op_type
;
8689 gfc_intrinsic_op op
;
8692 /* Check current state. */
8693 if (gfc_current_state () == COMP_DERIVED
)
8695 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8698 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8700 block
= gfc_state_stack
->previous
->sym
;
8701 ns
= block
->f2k_derived
;
8702 gcc_assert (block
&& ns
);
8704 memset (&tbattr
, 0, sizeof (tbattr
));
8705 tbattr
.where
= gfc_current_locus
;
8707 /* See if we get an access-specifier. */
8708 m
= match_binding_attributes (&tbattr
, true, false);
8709 if (m
== MATCH_ERROR
)
8712 /* Now the colons, those are required. */
8713 if (gfc_match (" ::") != MATCH_YES
)
8715 gfc_error ("Expected %<::%> at %C");
8719 /* Match the binding name; depending on type (operator / generic) format
8720 it for future error messages into bind_name. */
8722 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8723 if (m
== MATCH_ERROR
)
8727 gfc_error ("Expected generic name or operator descriptor at %C");
8733 case INTERFACE_GENERIC
:
8734 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8737 case INTERFACE_USER_OP
:
8738 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8741 case INTERFACE_INTRINSIC_OP
:
8742 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8743 gfc_op2string (op
));
8746 case INTERFACE_NAMELESS
:
8747 gfc_error ("Malformed GENERIC statement at %C");
8755 /* Match the required =>. */
8756 if (gfc_match (" =>") != MATCH_YES
)
8758 gfc_error ("Expected %<=>%> at %C");
8762 /* Try to find existing GENERIC binding with this name / for this operator;
8763 if there is something, check that it is another GENERIC and then extend
8764 it rather than building a new node. Otherwise, create it and put it
8765 at the right position. */
8769 case INTERFACE_USER_OP
:
8770 case INTERFACE_GENERIC
:
8772 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8775 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8787 case INTERFACE_INTRINSIC_OP
:
8797 if (!tb
->is_generic
)
8799 gcc_assert (op_type
== INTERFACE_GENERIC
);
8800 gfc_error ("There's already a non-generic procedure with binding name"
8801 " %qs for the derived type %qs at %C",
8802 bind_name
, block
->name
);
8806 if (tb
->access
!= tbattr
.access
)
8808 gfc_error ("Binding at %C must have the same access as already"
8809 " defined binding %qs", bind_name
);
8815 tb
= gfc_get_typebound_proc (NULL
);
8816 tb
->where
= gfc_current_locus
;
8817 tb
->access
= tbattr
.access
;
8819 tb
->u
.generic
= NULL
;
8823 case INTERFACE_GENERIC
:
8824 case INTERFACE_USER_OP
:
8826 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8829 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8837 case INTERFACE_INTRINSIC_OP
:
8846 /* Now, match all following names as specific targets. */
8849 gfc_symtree
* target_st
;
8850 gfc_tbp_generic
* target
;
8852 m
= gfc_match_name (name
);
8853 if (m
== MATCH_ERROR
)
8857 gfc_error ("Expected specific binding name at %C");
8861 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8863 /* See if this is a duplicate specification. */
8864 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8865 if (target_st
== target
->specific_st
)
8867 gfc_error ("%qs already defined as specific binding for the"
8868 " generic %qs at %C", name
, bind_name
);
8872 target
= gfc_get_tbp_generic ();
8873 target
->specific_st
= target_st
;
8874 target
->specific
= NULL
;
8875 target
->next
= tb
->u
.generic
;
8876 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8877 || (op_type
== INTERFACE_INTRINSIC_OP
));
8878 tb
->u
.generic
= target
;
8880 while (gfc_match (" ,") == MATCH_YES
);
8882 /* Here should be the end. */
8883 if (gfc_match_eos () != MATCH_YES
)
8885 gfc_error ("Junk after GENERIC binding at %C");
8896 /* Match a FINAL declaration inside a derived type. */
8899 gfc_match_final_decl (void)
8901 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8904 gfc_namespace
* module_ns
;
8908 if (gfc_current_form
== FORM_FREE
)
8910 char c
= gfc_peek_ascii_char ();
8911 if (!gfc_is_whitespace (c
) && c
!= ':')
8915 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8917 if (gfc_current_form
== FORM_FIXED
)
8920 gfc_error ("FINAL declaration at %C must be inside a derived type "
8921 "CONTAINS section");
8925 block
= gfc_state_stack
->previous
->sym
;
8928 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8929 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8931 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8932 " specification part of a MODULE");
8936 module_ns
= gfc_current_ns
;
8937 gcc_assert (module_ns
);
8938 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8940 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8941 if (gfc_match (" ::") == MATCH_ERROR
)
8944 /* Match the sequence of procedure names. */
8951 if (first
&& gfc_match_eos () == MATCH_YES
)
8953 gfc_error ("Empty FINAL at %C");
8957 m
= gfc_match_name (name
);
8960 gfc_error ("Expected module procedure name at %C");
8963 else if (m
!= MATCH_YES
)
8966 if (gfc_match_eos () == MATCH_YES
)
8968 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8970 gfc_error ("Expected %<,%> at %C");
8974 if (gfc_get_symbol (name
, module_ns
, &sym
))
8976 gfc_error ("Unknown procedure name %qs at %C", name
);
8980 /* Mark the symbol as module procedure. */
8981 if (sym
->attr
.proc
!= PROC_MODULE
8982 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8985 /* Check if we already have this symbol in the list, this is an error. */
8986 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8987 if (f
->proc_sym
== sym
)
8989 gfc_error ("%qs at %C is already defined as FINAL procedure!",
8994 /* Add this symbol to the list of finalizers. */
8995 gcc_assert (block
->f2k_derived
);
8997 f
= XCNEW (gfc_finalizer
);
8999 f
->proc_tree
= NULL
;
9000 f
->where
= gfc_current_locus
;
9001 f
->next
= block
->f2k_derived
->finalizers
;
9002 block
->f2k_derived
->finalizers
= f
;
9012 const ext_attr_t ext_attr_list
[] = {
9013 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9014 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9015 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9016 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9017 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9018 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9019 { NULL
, EXT_ATTR_LAST
, NULL
}
9022 /* Match a !GCC$ ATTRIBUTES statement of the form:
9023 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9024 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9026 TODO: We should support all GCC attributes using the same syntax for
9027 the attribute list, i.e. the list in C
9028 __attributes(( attribute-list ))
9030 !GCC$ ATTRIBUTES attribute-list ::
9031 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9034 As there is absolutely no risk of confusion, we should never return
9037 gfc_match_gcc_attributes (void)
9039 symbol_attribute attr
;
9040 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9045 gfc_clear_attr (&attr
);
9050 if (gfc_match_name (name
) != MATCH_YES
)
9053 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9054 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9057 if (id
== EXT_ATTR_LAST
)
9059 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9063 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9066 gfc_gobble_whitespace ();
9067 ch
= gfc_next_ascii_char ();
9070 /* This is the successful exit condition for the loop. */
9071 if (gfc_next_ascii_char () == ':')
9081 if (gfc_match_eos () == MATCH_YES
)
9086 m
= gfc_match_name (name
);
9090 if (find_special (name
, &sym
, true))
9093 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9095 if (gfc_match_eos () == MATCH_YES
)
9098 if (gfc_match_char (',') != MATCH_YES
)
9105 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");