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
);
905 if (sym
->attr
.module_procedure
906 && sym
->attr
.if_source
== IFSRC_IFBODY
)
908 /* Create a partially populated interface symbol to carry the
909 characteristics of the procedure and the result. */
910 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
911 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
913 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
914 if (sym
->attr
.dimension
)
915 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
917 /* Ideally, at this point, a copy would be made of the formal
918 arguments and their namespace. However, this does not appear
919 to be necessary, albeit at the expense of not being able to
920 use gfc_compare_interfaces directly. */
922 if (sym
->result
&& sym
->result
!= sym
)
924 sym
->ts
.interface
->result
= sym
->result
;
927 else if (sym
->result
)
929 sym
->ts
.interface
->result
= sym
->ts
.interface
;
932 else if (sym
&& !sym
->gfc_new
933 && gfc_current_state () != COMP_INTERFACE
)
935 /* Trap another encompassed procedure with the same name. All
936 these conditions are necessary to avoid picking up an entry
937 whose name clashes with that of the encompassing procedure;
938 this is handled using gsymbols to register unique,globally
940 if (sym
->attr
.flavor
!= 0
941 && sym
->attr
.proc
!= 0
942 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
943 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
944 gfc_error_now ("Procedure %qs at %C is already defined at %L",
945 name
, &sym
->declared_at
);
947 /* Trap a procedure with a name the same as interface in the
948 encompassing scope. */
949 if (sym
->attr
.generic
!= 0
950 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
951 && !sym
->attr
.mod_proc
)
952 gfc_error_now ("Name %qs at %C is already defined"
953 " as a generic interface at %L",
954 name
, &sym
->declared_at
);
956 /* Trap declarations of attributes in encompassing scope. The
957 signature for this is that ts.kind is set. Legitimate
958 references only set ts.type. */
959 if (sym
->ts
.kind
!= 0
960 && !sym
->attr
.implicit_type
961 && sym
->attr
.proc
== 0
962 && gfc_current_ns
->parent
!= NULL
963 && sym
->attr
.access
== 0
964 && !module_fcn_entry
)
965 gfc_error_now ("Procedure %qs at %C has an explicit interface "
966 "and must not have attributes declared at %L",
967 name
, &sym
->declared_at
);
970 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
973 /* Module function entries will already have a symtree in
974 the current namespace but will need one at module level. */
975 if (module_fcn_entry
)
977 /* Present if entry is declared to be a module procedure. */
978 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
980 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
983 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
988 /* See if the procedure should be a module procedure. */
990 if (((sym
->ns
->proc_name
!= NULL
991 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
992 && sym
->attr
.proc
!= PROC_MODULE
)
993 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
994 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1001 /* Verify that the given symbol representing a parameter is C
1002 interoperable, by checking to see if it was marked as such after
1003 its declaration. If the given symbol is not interoperable, a
1004 warning is reported, thus removing the need to return the status to
1005 the calling function. The standard does not require the user use
1006 one of the iso_c_binding named constants to declare an
1007 interoperable parameter, but we can't be sure if the param is C
1008 interop or not if the user doesn't. For example, integer(4) may be
1009 legal Fortran, but doesn't have meaning in C. It may interop with
1010 a number of the C types, which causes a problem because the
1011 compiler can't know which one. This code is almost certainly not
1012 portable, and the user will get what they deserve if the C type
1013 across platforms isn't always interoperable with integer(4). If
1014 the user had used something like integer(c_int) or integer(c_long),
1015 the compiler could have automatically handled the varying sizes
1016 across platforms. */
1019 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1021 int is_c_interop
= 0;
1024 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1025 Don't repeat the checks here. */
1026 if (sym
->attr
.implicit_type
)
1029 /* For subroutines or functions that are passed to a BIND(C) procedure,
1030 they're interoperable if they're BIND(C) and their params are all
1032 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1034 if (sym
->attr
.is_bind_c
== 0)
1036 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1037 "attribute to be C interoperable", sym
->name
,
1038 &(sym
->declared_at
));
1043 if (sym
->attr
.is_c_interop
== 1)
1044 /* We've already checked this procedure; don't check it again. */
1047 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1052 /* See if we've stored a reference to a procedure that owns sym. */
1053 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1055 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1057 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1059 if (is_c_interop
!= 1)
1061 /* Make personalized messages to give better feedback. */
1062 if (sym
->ts
.type
== BT_DERIVED
)
1063 gfc_error ("Variable %qs at %L is a dummy argument to the "
1064 "BIND(C) procedure %qs but is not C interoperable "
1065 "because derived type %qs is not C interoperable",
1066 sym
->name
, &(sym
->declared_at
),
1067 sym
->ns
->proc_name
->name
,
1068 sym
->ts
.u
.derived
->name
);
1069 else if (sym
->ts
.type
== BT_CLASS
)
1070 gfc_error ("Variable %qs at %L is a dummy argument to the "
1071 "BIND(C) procedure %qs but is not C interoperable "
1072 "because it is polymorphic",
1073 sym
->name
, &(sym
->declared_at
),
1074 sym
->ns
->proc_name
->name
);
1075 else if (warn_c_binding_type
)
1076 gfc_warning (OPT_Wc_binding_type
,
1077 "Variable %qs at %L is a dummy argument of the "
1078 "BIND(C) procedure %qs but may not be C "
1080 sym
->name
, &(sym
->declared_at
),
1081 sym
->ns
->proc_name
->name
);
1084 /* Character strings are only C interoperable if they have a
1086 if (sym
->ts
.type
== BT_CHARACTER
)
1088 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1089 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1090 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1092 gfc_error ("Character argument %qs at %L "
1093 "must be length 1 because "
1094 "procedure %qs is BIND(C)",
1095 sym
->name
, &sym
->declared_at
,
1096 sym
->ns
->proc_name
->name
);
1101 /* We have to make sure that any param to a bind(c) routine does
1102 not have the allocatable, pointer, or optional attributes,
1103 according to J3/04-007, section 5.1. */
1104 if (sym
->attr
.allocatable
== 1
1105 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1106 "ALLOCATABLE attribute in procedure %qs "
1107 "with BIND(C)", sym
->name
,
1108 &(sym
->declared_at
),
1109 sym
->ns
->proc_name
->name
))
1112 if (sym
->attr
.pointer
== 1
1113 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1114 "POINTER attribute in procedure %qs "
1115 "with BIND(C)", sym
->name
,
1116 &(sym
->declared_at
),
1117 sym
->ns
->proc_name
->name
))
1120 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1122 gfc_error ("Scalar variable %qs at %L with POINTER or "
1123 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1124 " supported", sym
->name
, &(sym
->declared_at
),
1125 sym
->ns
->proc_name
->name
);
1129 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1131 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1132 "and the VALUE attribute because procedure %qs "
1133 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1134 sym
->ns
->proc_name
->name
);
1137 else if (sym
->attr
.optional
== 1
1138 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1139 "at %L with OPTIONAL attribute in "
1140 "procedure %qs which is BIND(C)",
1141 sym
->name
, &(sym
->declared_at
),
1142 sym
->ns
->proc_name
->name
))
1145 /* Make sure that if it has the dimension attribute, that it is
1146 either assumed size or explicit shape. Deferred shape is already
1147 covered by the pointer/allocatable attribute. */
1148 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1149 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1150 "at %L as dummy argument to the BIND(C) "
1151 "procedure '%s' at %L", sym
->name
,
1152 &(sym
->declared_at
),
1153 sym
->ns
->proc_name
->name
,
1154 &(sym
->ns
->proc_name
->declared_at
)))
1164 /* Function called by variable_decl() that adds a name to the symbol table. */
1167 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1168 gfc_array_spec
**as
, locus
*var_locus
)
1170 symbol_attribute attr
;
1173 if (gfc_get_symbol (name
, NULL
, &sym
))
1176 /* Start updating the symbol table. Add basic type attribute if present. */
1177 if (current_ts
.type
!= BT_UNKNOWN
1178 && (sym
->attr
.implicit_type
== 0
1179 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1180 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1183 if (sym
->ts
.type
== BT_CHARACTER
)
1186 sym
->ts
.deferred
= cl_deferred
;
1189 /* Add dimension attribute if present. */
1190 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1194 /* Add attribute to symbol. The copy is so that we can reset the
1195 dimension attribute. */
1196 attr
= current_attr
;
1198 attr
.codimension
= 0;
1200 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1203 /* Finish any work that may need to be done for the binding label,
1204 if it's a bind(c). The bind(c) attr is found before the symbol
1205 is made, and before the symbol name (for data decls), so the
1206 current_ts is holding the binding label, or nothing if the
1207 name= attr wasn't given. Therefore, test here if we're dealing
1208 with a bind(c) and make sure the binding label is set correctly. */
1209 if (sym
->attr
.is_bind_c
== 1)
1211 if (!sym
->binding_label
)
1213 /* Set the binding label and verify that if a NAME= was specified
1214 then only one identifier was in the entity-decl-list. */
1215 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1216 num_idents_on_line
))
1221 /* See if we know we're in a common block, and if it's a bind(c)
1222 common then we need to make sure we're an interoperable type. */
1223 if (sym
->attr
.in_common
== 1)
1225 /* Test the common block object. */
1226 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1227 && sym
->ts
.is_c_interop
!= 1)
1229 gfc_error_now ("Variable %qs in common block %qs at %C "
1230 "must be declared with a C interoperable "
1231 "kind since common block %qs is BIND(C)",
1232 sym
->name
, sym
->common_block
->name
,
1233 sym
->common_block
->name
);
1238 sym
->attr
.implied_index
= 0;
1240 if (sym
->ts
.type
== BT_CLASS
)
1241 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1247 /* Set character constant to the given length. The constant will be padded or
1248 truncated. If we're inside an array constructor without a typespec, we
1249 additionally check that all elements have the same length; check_len -1
1250 means no checking. */
1253 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1258 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1259 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1261 slen
= expr
->value
.character
.length
;
1264 s
= gfc_get_wide_string (len
+ 1);
1265 memcpy (s
, expr
->value
.character
.string
,
1266 MIN (len
, slen
) * sizeof (gfc_char_t
));
1268 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1270 if (warn_character_truncation
&& slen
> len
)
1271 gfc_warning_now (OPT_Wcharacter_truncation
,
1272 "CHARACTER expression at %L is being truncated "
1273 "(%d/%d)", &expr
->where
, slen
, len
);
1275 /* Apply the standard by 'hand' otherwise it gets cleared for
1277 if (check_len
!= -1 && slen
!= check_len
1278 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1279 gfc_error_now ("The CHARACTER elements of the array constructor "
1280 "at %L must have the same length (%d/%d)",
1281 &expr
->where
, slen
, check_len
);
1284 free (expr
->value
.character
.string
);
1285 expr
->value
.character
.string
= s
;
1286 expr
->value
.character
.length
= len
;
1291 /* Function to create and update the enumerator history
1292 using the information passed as arguments.
1293 Pointer "max_enum" is also updated, to point to
1294 enum history node containing largest initializer.
1296 SYM points to the symbol node of enumerator.
1297 INIT points to its enumerator value. */
1300 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1302 enumerator_history
*new_enum_history
;
1303 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1305 new_enum_history
= XCNEW (enumerator_history
);
1307 new_enum_history
->sym
= sym
;
1308 new_enum_history
->initializer
= init
;
1309 new_enum_history
->next
= NULL
;
1311 if (enum_history
== NULL
)
1313 enum_history
= new_enum_history
;
1314 max_enum
= enum_history
;
1318 new_enum_history
->next
= enum_history
;
1319 enum_history
= new_enum_history
;
1321 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1322 new_enum_history
->initializer
->value
.integer
) < 0)
1323 max_enum
= new_enum_history
;
1328 /* Function to free enum kind history. */
1331 gfc_free_enum_history (void)
1333 enumerator_history
*current
= enum_history
;
1334 enumerator_history
*next
;
1336 while (current
!= NULL
)
1338 next
= current
->next
;
1343 enum_history
= NULL
;
1347 /* Function called by variable_decl() that adds an initialization
1348 expression to a symbol. */
1351 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1353 symbol_attribute attr
;
1358 if (find_special (name
, &sym
, false))
1363 /* If this symbol is confirming an implicit parameter type,
1364 then an initialization expression is not allowed. */
1365 if (attr
.flavor
== FL_PARAMETER
1366 && sym
->value
!= NULL
1369 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1376 /* An initializer is required for PARAMETER declarations. */
1377 if (attr
.flavor
== FL_PARAMETER
)
1379 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1385 /* If a variable appears in a DATA block, it cannot have an
1389 gfc_error ("Variable %qs at %C with an initializer already "
1390 "appears in a DATA statement", sym
->name
);
1394 /* Check if the assignment can happen. This has to be put off
1395 until later for derived type variables and procedure pointers. */
1396 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1397 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1398 && !sym
->attr
.proc_pointer
1399 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1402 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1403 && init
->ts
.type
== BT_CHARACTER
)
1405 /* Update symbol character length according initializer. */
1406 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1409 if (sym
->ts
.u
.cl
->length
== NULL
)
1412 /* If there are multiple CHARACTER variables declared on the
1413 same line, we don't want them to share the same length. */
1414 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1416 if (sym
->attr
.flavor
== FL_PARAMETER
)
1418 if (init
->expr_type
== EXPR_CONSTANT
)
1420 clen
= init
->value
.character
.length
;
1421 sym
->ts
.u
.cl
->length
1422 = gfc_get_int_expr (gfc_default_integer_kind
,
1425 else if (init
->expr_type
== EXPR_ARRAY
)
1427 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1428 sym
->ts
.u
.cl
->length
1429 = gfc_get_int_expr (gfc_default_integer_kind
,
1432 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1433 sym
->ts
.u
.cl
->length
=
1434 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1437 /* Update initializer character length according symbol. */
1438 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1440 int len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1442 if (init
->expr_type
== EXPR_CONSTANT
)
1443 gfc_set_constant_character_len (len
, init
, -1);
1444 else if (init
->expr_type
== EXPR_ARRAY
)
1448 /* Build a new charlen to prevent simplification from
1449 deleting the length before it is resolved. */
1450 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1451 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1453 for (c
= gfc_constructor_first (init
->value
.constructor
);
1454 c
; c
= gfc_constructor_next (c
))
1455 gfc_set_constant_character_len (len
, c
->expr
, -1);
1460 /* If sym is implied-shape, set its upper bounds from init. */
1461 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1462 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1466 if (init
->rank
== 0)
1468 gfc_error ("Can't initialize implied-shape array at %L"
1469 " with scalar", &sym
->declared_at
);
1472 gcc_assert (sym
->as
->rank
== init
->rank
);
1474 /* Shape should be present, we get an initialization expression. */
1475 gcc_assert (init
->shape
);
1477 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1483 lower
= sym
->as
->lower
[dim
];
1484 if (lower
->expr_type
!= EXPR_CONSTANT
)
1486 gfc_error ("Non-constant lower bound in implied-shape"
1487 " declaration at %L", &lower
->where
);
1491 /* All dimensions must be without upper bound. */
1492 gcc_assert (!sym
->as
->upper
[dim
]);
1495 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1496 mpz_add (e
->value
.integer
,
1497 lower
->value
.integer
, init
->shape
[dim
]);
1498 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1499 sym
->as
->upper
[dim
] = e
;
1502 sym
->as
->type
= AS_EXPLICIT
;
1505 /* Need to check if the expression we initialized this
1506 to was one of the iso_c_binding named constants. If so,
1507 and we're a parameter (constant), let it be iso_c.
1509 integer(c_int), parameter :: my_int = c_int
1510 integer(my_int) :: my_int_2
1511 If we mark my_int as iso_c (since we can see it's value
1512 is equal to one of the named constants), then my_int_2
1513 will be considered C interoperable. */
1514 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1516 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1517 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1518 /* attr bits needed for module files. */
1519 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1520 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1521 if (init
->ts
.is_iso_c
)
1522 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1525 /* Add initializer. Make sure we keep the ranks sane. */
1526 if (sym
->attr
.dimension
&& init
->rank
== 0)
1531 if (sym
->attr
.flavor
== FL_PARAMETER
1532 && init
->expr_type
== EXPR_CONSTANT
1533 && spec_size (sym
->as
, &size
)
1534 && mpz_cmp_si (size
, 0) > 0)
1536 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1538 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1539 gfc_constructor_append_expr (&array
->value
.constructor
,
1542 : gfc_copy_expr (init
),
1545 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1546 for (n
= 0; n
< sym
->as
->rank
; n
++)
1547 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1552 init
->rank
= sym
->as
->rank
;
1556 if (sym
->attr
.save
== SAVE_NONE
)
1557 sym
->attr
.save
= SAVE_IMPLICIT
;
1565 /* Function called by variable_decl() that adds a name to a structure
1569 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1570 gfc_array_spec
**as
)
1575 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1576 constructing, it must have the pointer attribute. */
1577 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1578 && current_ts
.u
.derived
== gfc_current_block ()
1579 && current_attr
.pointer
== 0)
1581 gfc_error ("Component at %C must have the POINTER attribute");
1585 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1587 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1589 gfc_error ("Array component of structure at %C must have explicit "
1590 "or deferred shape");
1595 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1599 if (c
->ts
.type
== BT_CHARACTER
)
1601 c
->attr
= current_attr
;
1603 c
->initializer
= *init
;
1610 c
->attr
.codimension
= 1;
1612 c
->attr
.dimension
= 1;
1616 /* Should this ever get more complicated, combine with similar section
1617 in add_init_expr_to_sym into a separate function. */
1618 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1620 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1624 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1625 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1626 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1628 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1630 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1631 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1632 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1633 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1635 gfc_constructor
*ctor
;
1636 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1641 bool has_ts
= (c
->initializer
->ts
.u
.cl
1642 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1644 /* Remember the length of the first element for checking
1645 that all elements *in the constructor* have the same
1646 length. This need not be the length of the LHS! */
1647 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1648 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1649 first_len
= ctor
->expr
->value
.character
.length
;
1651 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1652 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1654 gfc_set_constant_character_len (len
, ctor
->expr
,
1655 has_ts
? -1 : first_len
);
1656 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1662 /* Check array components. */
1663 if (!c
->attr
.dimension
)
1666 if (c
->attr
.pointer
)
1668 if (c
->as
->type
!= AS_DEFERRED
)
1670 gfc_error ("Pointer array component of structure at %C must have a "
1675 else if (c
->attr
.allocatable
)
1677 if (c
->as
->type
!= AS_DEFERRED
)
1679 gfc_error ("Allocatable component of structure at %C must have a "
1686 if (c
->as
->type
!= AS_EXPLICIT
)
1688 gfc_error ("Array component of structure at %C must have an "
1695 if (c
->ts
.type
== BT_CLASS
)
1697 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1707 /* Match a 'NULL()', and possibly take care of some side effects. */
1710 gfc_match_null (gfc_expr
**result
)
1713 match m
, m2
= MATCH_NO
;
1715 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1721 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1723 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1726 old_loc
= gfc_current_locus
;
1727 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1730 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1734 gfc_current_locus
= old_loc
;
1739 /* The NULL symbol now has to be/become an intrinsic function. */
1740 if (gfc_get_symbol ("null", NULL
, &sym
))
1742 gfc_error ("NULL() initialization at %C is ambiguous");
1746 gfc_intrinsic_symbol (sym
);
1748 if (sym
->attr
.proc
!= PROC_INTRINSIC
1749 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
1750 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1751 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1754 *result
= gfc_get_null_expr (&gfc_current_locus
);
1756 /* Invalid per F2008, C512. */
1757 if (m2
== MATCH_YES
)
1759 gfc_error ("NULL() initialization at %C may not have MOLD");
1767 /* Match the initialization expr for a data pointer or procedure pointer. */
1770 match_pointer_init (gfc_expr
**init
, int procptr
)
1774 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1776 gfc_error ("Initialization of pointer at %C is not allowed in "
1777 "a PURE procedure");
1780 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
1782 /* Match NULL() initialization. */
1783 m
= gfc_match_null (init
);
1787 /* Match non-NULL initialization. */
1788 gfc_matching_ptr_assignment
= !procptr
;
1789 gfc_matching_procptr_assignment
= procptr
;
1790 m
= gfc_match_rvalue (init
);
1791 gfc_matching_ptr_assignment
= 0;
1792 gfc_matching_procptr_assignment
= 0;
1793 if (m
== MATCH_ERROR
)
1795 else if (m
== MATCH_NO
)
1797 gfc_error ("Error in pointer initialization at %C");
1801 if (!procptr
&& !gfc_resolve_expr (*init
))
1804 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1805 "initialization at %C"))
1813 check_function_name (char *name
)
1815 /* In functions that have a RESULT variable defined, the function name always
1816 refers to function calls. Therefore, the name is not allowed to appear in
1817 specification statements. When checking this, be careful about
1818 'hidden' procedure pointer results ('ppr@'). */
1820 if (gfc_current_state () == COMP_FUNCTION
)
1822 gfc_symbol
*block
= gfc_current_block ();
1823 if (block
&& block
->result
&& block
->result
!= block
1824 && strcmp (block
->result
->name
, "ppr@") != 0
1825 && strcmp (block
->name
, name
) == 0)
1827 gfc_error ("Function name %qs not allowed at %C", name
);
1836 /* Match a variable name with an optional initializer. When this
1837 subroutine is called, a variable is expected to be parsed next.
1838 Depending on what is happening at the moment, updates either the
1839 symbol table or the current interface. */
1842 variable_decl (int elem
)
1844 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1845 gfc_expr
*initializer
, *char_len
;
1847 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1859 /* When we get here, we've just matched a list of attributes and
1860 maybe a type and a double colon. The next thing we expect to see
1861 is the name of the symbol. */
1862 m
= gfc_match_name (name
);
1866 var_locus
= gfc_current_locus
;
1868 /* Now we could see the optional array spec. or character length. */
1869 m
= gfc_match_array_spec (&as
, true, true);
1870 if (m
== MATCH_ERROR
)
1874 as
= gfc_copy_array_spec (current_as
);
1876 && !merge_array_spec (current_as
, as
, true))
1882 if (flag_cray_pointer
)
1883 cp_as
= gfc_copy_array_spec (as
);
1885 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1886 determine (and check) whether it can be implied-shape. If it
1887 was parsed as assumed-size, change it because PARAMETERs can not
1891 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1894 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
1899 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1900 && current_attr
.flavor
== FL_PARAMETER
)
1901 as
->type
= AS_IMPLIED_SHAPE
;
1903 if (as
->type
== AS_IMPLIED_SHAPE
1904 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1914 cl_deferred
= false;
1916 if (current_ts
.type
== BT_CHARACTER
)
1918 switch (match_char_length (&char_len
, &cl_deferred
, false))
1921 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1923 cl
->length
= char_len
;
1926 /* Non-constant lengths need to be copied after the first
1927 element. Also copy assumed lengths. */
1930 && (current_ts
.u
.cl
->length
== NULL
1931 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1933 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1934 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1937 cl
= current_ts
.u
.cl
;
1939 cl_deferred
= current_ts
.deferred
;
1948 /* The dummy arguments and result of the abreviated form of MODULE
1949 PROCEDUREs, used in SUBMODULES should not be redefined. */
1950 if (gfc_current_ns
->proc_name
1951 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
1953 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1954 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
1957 gfc_error ("'%s' at %C is a redefinition of the declaration "
1958 "in the corresponding interface for MODULE "
1959 "PROCEDURE '%s'", sym
->name
,
1960 gfc_current_ns
->proc_name
->name
);
1965 /* If this symbol has already shown up in a Cray Pointer declaration,
1966 and this is not a component declaration,
1967 then we want to set the type & bail out. */
1968 if (flag_cray_pointer
&& gfc_current_state () != COMP_DERIVED
)
1970 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1971 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1973 sym
->ts
.type
= current_ts
.type
;
1974 sym
->ts
.kind
= current_ts
.kind
;
1976 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1977 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1978 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1981 /* Check to see if we have an array specification. */
1984 if (sym
->as
!= NULL
)
1986 gfc_error ("Duplicate array spec for Cray pointee at %C");
1987 gfc_free_array_spec (cp_as
);
1993 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
1994 gfc_internal_error ("Couldn't set pointee array spec.");
1996 /* Fix the array spec. */
1997 m
= gfc_mod_pointee_as (sym
->as
);
1998 if (m
== MATCH_ERROR
)
2006 gfc_free_array_spec (cp_as
);
2010 /* Procedure pointer as function result. */
2011 if (gfc_current_state () == COMP_FUNCTION
2012 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2013 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2014 strcpy (name
, "ppr@");
2016 if (gfc_current_state () == COMP_FUNCTION
2017 && strcmp (name
, gfc_current_block ()->name
) == 0
2018 && gfc_current_block ()->result
2019 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2020 strcpy (name
, "ppr@");
2022 /* OK, we've successfully matched the declaration. Now put the
2023 symbol in the current namespace, because it might be used in the
2024 optional initialization expression for this symbol, e.g. this is
2027 integer, parameter :: i = huge(i)
2029 This is only true for parameters or variables of a basic type.
2030 For components of derived types, it is not true, so we don't
2031 create a symbol for those yet. If we fail to create the symbol,
2033 if (gfc_current_state () != COMP_DERIVED
2034 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2040 if (!check_function_name (name
))
2046 /* We allow old-style initializations of the form
2047 integer i /2/, j(4) /3*3, 1/
2048 (if no colon has been seen). These are different from data
2049 statements in that initializers are only allowed to apply to the
2050 variable immediately preceding, i.e.
2052 is not allowed. Therefore we have to do some work manually, that
2053 could otherwise be left to the matchers for DATA statements. */
2055 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2057 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2058 "initialization at %C"))
2060 else if (gfc_current_state () == COMP_DERIVED
)
2062 gfc_error ("Invalid old style initialization for derived type "
2068 return match_old_style_init (name
);
2071 /* The double colon must be present in order to have initializers.
2072 Otherwise the statement is ambiguous with an assignment statement. */
2075 if (gfc_match (" =>") == MATCH_YES
)
2077 if (!current_attr
.pointer
)
2079 gfc_error ("Initialization at %C isn't for a pointer variable");
2084 m
= match_pointer_init (&initializer
, 0);
2088 else if (gfc_match_char ('=') == MATCH_YES
)
2090 if (current_attr
.pointer
)
2092 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2098 m
= gfc_match_init_expr (&initializer
);
2101 gfc_error ("Expected an initialization expression at %C");
2105 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2106 && gfc_state_stack
->state
!= COMP_DERIVED
)
2108 gfc_error ("Initialization of variable at %C is not allowed in "
2109 "a PURE procedure");
2113 if (current_attr
.flavor
!= FL_PARAMETER
2114 && gfc_state_stack
->state
!= COMP_DERIVED
)
2115 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2122 if (initializer
!= NULL
&& current_attr
.allocatable
2123 && gfc_current_state () == COMP_DERIVED
)
2125 gfc_error ("Initialization of allocatable component at %C is not "
2131 /* Add the initializer. Note that it is fine if initializer is
2132 NULL here, because we sometimes also need to check if a
2133 declaration *must* have an initialization expression. */
2134 if (gfc_current_state () != COMP_DERIVED
)
2135 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2138 if (current_ts
.type
== BT_DERIVED
2139 && !current_attr
.pointer
&& !initializer
)
2140 initializer
= gfc_default_initializer (¤t_ts
);
2141 t
= build_struct (name
, cl
, &initializer
, &as
);
2144 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2147 /* Free stuff up and return. */
2148 gfc_free_expr (initializer
);
2149 gfc_free_array_spec (as
);
2155 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2156 This assumes that the byte size is equal to the kind number for
2157 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2160 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2165 if (gfc_match_char ('*') != MATCH_YES
)
2168 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2172 original_kind
= ts
->kind
;
2174 /* Massage the kind numbers for complex types. */
2175 if (ts
->type
== BT_COMPLEX
)
2179 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2180 gfc_basic_typename (ts
->type
), original_kind
);
2187 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2190 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2194 if (flag_real4_kind
== 8)
2196 if (flag_real4_kind
== 10)
2198 if (flag_real4_kind
== 16)
2204 if (flag_real8_kind
== 4)
2206 if (flag_real8_kind
== 10)
2208 if (flag_real8_kind
== 16)
2213 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2215 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2216 gfc_basic_typename (ts
->type
), original_kind
);
2220 if (!gfc_notify_std (GFC_STD_GNU
,
2221 "Nonstandard type declaration %s*%d at %C",
2222 gfc_basic_typename(ts
->type
), original_kind
))
2229 /* Match a kind specification. Since kinds are generally optional, we
2230 usually return MATCH_NO if something goes wrong. If a "kind="
2231 string is found, then we know we have an error. */
2234 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2246 where
= loc
= gfc_current_locus
;
2251 if (gfc_match_char ('(') == MATCH_NO
)
2254 /* Also gobbles optional text. */
2255 if (gfc_match (" kind = ") == MATCH_YES
)
2258 loc
= gfc_current_locus
;
2261 n
= gfc_match_init_expr (&e
);
2265 if (gfc_matching_function
)
2267 /* The function kind expression might include use associated or
2268 imported parameters and try again after the specification
2270 if (gfc_match_char (')') != MATCH_YES
)
2272 gfc_error ("Missing right parenthesis at %C");
2278 gfc_undo_symbols ();
2283 /* ....or else, the match is real. */
2285 gfc_error ("Expected initialization expression at %C");
2293 gfc_error ("Expected scalar initialization expression at %C");
2298 msg
= gfc_extract_int (e
, &ts
->kind
);
2307 /* Before throwing away the expression, let's see if we had a
2308 C interoperable kind (and store the fact). */
2309 if (e
->ts
.is_c_interop
== 1)
2311 /* Mark this as C interoperable if being declared with one
2312 of the named constants from iso_c_binding. */
2313 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2314 ts
->f90_type
= e
->ts
.f90_type
;
2320 /* Ignore errors to this point, if we've gotten here. This means
2321 we ignore the m=MATCH_ERROR from above. */
2322 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2324 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2325 gfc_basic_typename (ts
->type
));
2326 gfc_current_locus
= where
;
2330 /* Warn if, e.g., c_int is used for a REAL variable, but not
2331 if, e.g., c_double is used for COMPLEX as the standard
2332 explicitly says that the kind type parameter for complex and real
2333 variable is the same, i.e. c_float == c_float_complex. */
2334 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2335 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2336 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2337 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2338 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2339 gfc_basic_typename (ts
->type
));
2341 gfc_gobble_whitespace ();
2342 if ((c
= gfc_next_ascii_char ()) != ')'
2343 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2345 if (ts
->type
== BT_CHARACTER
)
2346 gfc_error ("Missing right parenthesis or comma at %C");
2348 gfc_error ("Missing right parenthesis at %C");
2352 /* All tests passed. */
2355 if(m
== MATCH_ERROR
)
2356 gfc_current_locus
= where
;
2358 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2361 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2365 if (flag_real4_kind
== 8)
2367 if (flag_real4_kind
== 10)
2369 if (flag_real4_kind
== 16)
2375 if (flag_real8_kind
== 4)
2377 if (flag_real8_kind
== 10)
2379 if (flag_real8_kind
== 16)
2384 /* Return what we know from the test(s). */
2389 gfc_current_locus
= where
;
2395 match_char_kind (int * kind
, int * is_iso_c
)
2404 where
= gfc_current_locus
;
2406 n
= gfc_match_init_expr (&e
);
2408 if (n
!= MATCH_YES
&& gfc_matching_function
)
2410 /* The expression might include use-associated or imported
2411 parameters and try again after the specification
2414 gfc_undo_symbols ();
2419 gfc_error ("Expected initialization expression at %C");
2425 gfc_error ("Expected scalar initialization expression at %C");
2430 msg
= gfc_extract_int (e
, kind
);
2431 *is_iso_c
= e
->ts
.is_iso_c
;
2441 /* Ignore errors to this point, if we've gotten here. This means
2442 we ignore the m=MATCH_ERROR from above. */
2443 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2445 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2449 /* All tests passed. */
2452 if (m
== MATCH_ERROR
)
2453 gfc_current_locus
= where
;
2455 /* Return what we know from the test(s). */
2460 gfc_current_locus
= where
;
2465 /* Match the various kind/length specifications in a CHARACTER
2466 declaration. We don't return MATCH_NO. */
2469 gfc_match_char_spec (gfc_typespec
*ts
)
2471 int kind
, seen_length
, is_iso_c
;
2483 /* Try the old-style specification first. */
2484 old_char_selector
= 0;
2486 m
= match_char_length (&len
, &deferred
, true);
2490 old_char_selector
= 1;
2495 m
= gfc_match_char ('(');
2498 m
= MATCH_YES
; /* Character without length is a single char. */
2502 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2503 if (gfc_match (" kind =") == MATCH_YES
)
2505 m
= match_char_kind (&kind
, &is_iso_c
);
2507 if (m
== MATCH_ERROR
)
2512 if (gfc_match (" , len =") == MATCH_NO
)
2515 m
= char_len_param_value (&len
, &deferred
);
2518 if (m
== MATCH_ERROR
)
2525 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2526 if (gfc_match (" len =") == MATCH_YES
)
2528 m
= char_len_param_value (&len
, &deferred
);
2531 if (m
== MATCH_ERROR
)
2535 if (gfc_match_char (')') == MATCH_YES
)
2538 if (gfc_match (" , kind =") != MATCH_YES
)
2541 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2547 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2548 m
= char_len_param_value (&len
, &deferred
);
2551 if (m
== MATCH_ERROR
)
2555 m
= gfc_match_char (')');
2559 if (gfc_match_char (',') != MATCH_YES
)
2562 gfc_match (" kind ="); /* Gobble optional text. */
2564 m
= match_char_kind (&kind
, &is_iso_c
);
2565 if (m
== MATCH_ERROR
)
2571 /* Require a right-paren at this point. */
2572 m
= gfc_match_char (')');
2577 gfc_error ("Syntax error in CHARACTER declaration at %C");
2579 gfc_free_expr (len
);
2583 /* Deal with character functions after USE and IMPORT statements. */
2584 if (gfc_matching_function
)
2586 gfc_free_expr (len
);
2587 gfc_undo_symbols ();
2593 gfc_free_expr (len
);
2597 /* Do some final massaging of the length values. */
2598 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2600 if (seen_length
== 0)
2601 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2606 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2607 ts
->deferred
= deferred
;
2609 /* We have to know if it was a C interoperable kind so we can
2610 do accurate type checking of bind(c) procs, etc. */
2612 /* Mark this as C interoperable if being declared with one
2613 of the named constants from iso_c_binding. */
2614 ts
->is_c_interop
= is_iso_c
;
2615 else if (len
!= NULL
)
2616 /* Here, we might have parsed something such as: character(c_char)
2617 In this case, the parsing code above grabs the c_char when
2618 looking for the length (line 1690, roughly). it's the last
2619 testcase for parsing the kind params of a character variable.
2620 However, it's not actually the length. this seems like it
2622 To see if the user used a C interop kind, test the expr
2623 of the so called length, and see if it's C interoperable. */
2624 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2630 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2631 structure to the matched specification. This is necessary for FUNCTION and
2632 IMPLICIT statements.
2634 If implicit_flag is nonzero, then we don't check for the optional
2635 kind specification. Not doing so is needed for matching an IMPLICIT
2636 statement correctly. */
2639 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2641 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2642 gfc_symbol
*sym
, *dt_sym
;
2645 bool seen_deferred_kind
, matched_type
;
2646 const char *dt_name
;
2648 /* A belt and braces check that the typespec is correctly being treated
2649 as a deferred characteristic association. */
2650 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2651 && (gfc_current_block ()->result
->ts
.kind
== -1)
2652 && (ts
->kind
== -1);
2654 if (seen_deferred_kind
)
2657 /* Clear the current binding label, in case one is given. */
2658 curr_binding_label
= NULL
;
2660 if (gfc_match (" byte") == MATCH_YES
)
2662 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2665 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2667 gfc_error ("BYTE type used at %C "
2668 "is not available on the target machine");
2672 ts
->type
= BT_INTEGER
;
2678 m
= gfc_match (" type (");
2679 matched_type
= (m
== MATCH_YES
);
2682 gfc_gobble_whitespace ();
2683 if (gfc_peek_ascii_char () == '*')
2685 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2687 if (gfc_current_state () == COMP_DERIVED
)
2689 gfc_error ("Assumed type at %C is not allowed for components");
2692 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2695 ts
->type
= BT_ASSUMED
;
2699 m
= gfc_match ("%n", name
);
2700 matched_type
= (m
== MATCH_YES
);
2703 if ((matched_type
&& strcmp ("integer", name
) == 0)
2704 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2706 ts
->type
= BT_INTEGER
;
2707 ts
->kind
= gfc_default_integer_kind
;
2711 if ((matched_type
&& strcmp ("character", name
) == 0)
2712 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2715 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2716 "intrinsic-type-spec at %C"))
2719 ts
->type
= BT_CHARACTER
;
2720 if (implicit_flag
== 0)
2721 m
= gfc_match_char_spec (ts
);
2725 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2731 if ((matched_type
&& strcmp ("real", name
) == 0)
2732 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2735 ts
->kind
= gfc_default_real_kind
;
2740 && (strcmp ("doubleprecision", name
) == 0
2741 || (strcmp ("double", name
) == 0
2742 && gfc_match (" precision") == MATCH_YES
)))
2743 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2746 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2747 "intrinsic-type-spec at %C"))
2749 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2753 ts
->kind
= gfc_default_double_kind
;
2757 if ((matched_type
&& strcmp ("complex", name
) == 0)
2758 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2760 ts
->type
= BT_COMPLEX
;
2761 ts
->kind
= gfc_default_complex_kind
;
2766 && (strcmp ("doublecomplex", name
) == 0
2767 || (strcmp ("double", name
) == 0
2768 && gfc_match (" complex") == MATCH_YES
)))
2769 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2771 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2775 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2776 "intrinsic-type-spec at %C"))
2779 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2782 ts
->type
= BT_COMPLEX
;
2783 ts
->kind
= gfc_default_double_kind
;
2787 if ((matched_type
&& strcmp ("logical", name
) == 0)
2788 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2790 ts
->type
= BT_LOGICAL
;
2791 ts
->kind
= gfc_default_logical_kind
;
2796 m
= gfc_match_char (')');
2799 ts
->type
= BT_DERIVED
;
2802 /* Match CLASS declarations. */
2803 m
= gfc_match (" class ( * )");
2804 if (m
== MATCH_ERROR
)
2806 else if (m
== MATCH_YES
)
2810 ts
->type
= BT_CLASS
;
2811 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2814 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2815 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2817 gfc_set_sym_referenced (upe
);
2819 upe
->ts
.type
= BT_VOID
;
2820 upe
->attr
.unlimited_polymorphic
= 1;
2821 /* This is essential to force the construction of
2822 unlimited polymorphic component class containers. */
2823 upe
->attr
.zero_comp
= 1;
2824 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2825 &gfc_current_locus
))
2830 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2832 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2836 ts
->u
.derived
= upe
;
2840 m
= gfc_match (" class ( %n )", name
);
2843 ts
->type
= BT_CLASS
;
2845 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2849 /* Defer association of the derived type until the end of the
2850 specification block. However, if the derived type can be
2851 found, add it to the typespec. */
2852 if (gfc_matching_function
)
2854 ts
->u
.derived
= NULL
;
2855 if (gfc_current_state () != COMP_INTERFACE
2856 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2858 sym
= gfc_find_dt_in_generic (sym
);
2859 ts
->u
.derived
= sym
;
2864 /* Search for the name but allow the components to be defined later. If
2865 type = -1, this typespec has been seen in a function declaration but
2866 the type could not be accessed at that point. The actual derived type is
2867 stored in a symtree with the first letter of the name capitalized; the
2868 symtree with the all lower-case name contains the associated
2869 generic function. */
2870 dt_name
= gfc_get_string ("%c%s",
2871 (char) TOUPPER ((unsigned char) name
[0]),
2872 (const char*)&name
[1]);
2877 gfc_get_ha_symbol (name
, &sym
);
2878 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2880 gfc_error ("Type name %qs at %C is ambiguous", name
);
2883 if (sym
->generic
&& !dt_sym
)
2884 dt_sym
= gfc_find_dt_in_generic (sym
);
2886 else if (ts
->kind
== -1)
2888 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2889 || gfc_current_ns
->has_import_set
;
2890 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2891 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2893 gfc_error ("Type name %qs at %C is ambiguous", name
);
2896 if (sym
&& sym
->generic
&& !dt_sym
)
2897 dt_sym
= gfc_find_dt_in_generic (sym
);
2904 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2905 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2906 || sym
->attr
.subroutine
)
2908 gfc_error ("Type name %qs at %C conflicts with previously declared "
2909 "entity at %L, which has the same name", name
,
2914 gfc_save_symbol_data (sym
);
2915 gfc_set_sym_referenced (sym
);
2916 if (!sym
->attr
.generic
2917 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2920 if (!sym
->attr
.function
2921 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2926 gfc_interface
*intr
, *head
;
2928 /* Use upper case to save the actual derived-type symbol. */
2929 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2930 dt_sym
->name
= gfc_get_string (sym
->name
);
2931 head
= sym
->generic
;
2932 intr
= gfc_get_interface ();
2934 intr
->where
= gfc_current_locus
;
2936 sym
->generic
= intr
;
2937 sym
->attr
.if_source
= IFSRC_DECL
;
2940 gfc_save_symbol_data (dt_sym
);
2942 gfc_set_sym_referenced (dt_sym
);
2944 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2945 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2948 ts
->u
.derived
= dt_sym
;
2954 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2955 "intrinsic-type-spec at %C"))
2958 /* For all types except double, derived and character, look for an
2959 optional kind specifier. MATCH_NO is actually OK at this point. */
2960 if (implicit_flag
== 1)
2962 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2968 if (gfc_current_form
== FORM_FREE
)
2970 c
= gfc_peek_ascii_char ();
2971 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2972 && c
!= ':' && c
!= ',')
2974 if (matched_type
&& c
== ')')
2976 gfc_next_ascii_char ();
2983 m
= gfc_match_kind_spec (ts
, false);
2984 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2985 m
= gfc_match_old_kind_spec (ts
);
2987 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2990 /* Defer association of the KIND expression of function results
2991 until after USE and IMPORT statements. */
2992 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
2993 || gfc_matching_function
)
2997 m
= MATCH_YES
; /* No kind specifier found. */
3003 /* Match an IMPLICIT NONE statement. Actually, this statement is
3004 already matched in parse.c, or we would not end up here in the
3005 first place. So the only thing we need to check, is if there is
3006 trailing garbage. If not, the match is successful. */
3009 gfc_match_implicit_none (void)
3013 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3015 bool external
= false;
3016 locus cur_loc
= gfc_current_locus
;
3018 if (gfc_current_ns
->seen_implicit_none
3019 || gfc_current_ns
->has_implicit_none_export
)
3021 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3025 gfc_gobble_whitespace ();
3026 c
= gfc_peek_ascii_char ();
3029 (void) gfc_next_ascii_char ();
3030 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3033 gfc_gobble_whitespace ();
3034 if (gfc_peek_ascii_char () == ')')
3036 (void) gfc_next_ascii_char ();
3042 m
= gfc_match (" %n", name
);
3046 if (strcmp (name
, "type") == 0)
3048 else if (strcmp (name
, "external") == 0)
3053 gfc_gobble_whitespace ();
3054 c
= gfc_next_ascii_char ();
3065 if (gfc_match_eos () != MATCH_YES
)
3068 gfc_set_implicit_none (type
, external
, &cur_loc
);
3074 /* Match the letter range(s) of an IMPLICIT statement. */
3077 match_implicit_range (void)
3083 cur_loc
= gfc_current_locus
;
3085 gfc_gobble_whitespace ();
3086 c
= gfc_next_ascii_char ();
3089 gfc_error ("Missing character range in IMPLICIT at %C");
3096 gfc_gobble_whitespace ();
3097 c1
= gfc_next_ascii_char ();
3101 gfc_gobble_whitespace ();
3102 c
= gfc_next_ascii_char ();
3107 inner
= 0; /* Fall through. */
3114 gfc_gobble_whitespace ();
3115 c2
= gfc_next_ascii_char ();
3119 gfc_gobble_whitespace ();
3120 c
= gfc_next_ascii_char ();
3122 if ((c
!= ',') && (c
!= ')'))
3135 gfc_error ("Letters must be in alphabetic order in "
3136 "IMPLICIT statement at %C");
3140 /* See if we can add the newly matched range to the pending
3141 implicits from this IMPLICIT statement. We do not check for
3142 conflicts with whatever earlier IMPLICIT statements may have
3143 set. This is done when we've successfully finished matching
3145 if (!gfc_add_new_implicit_range (c1
, c2
))
3152 gfc_syntax_error (ST_IMPLICIT
);
3154 gfc_current_locus
= cur_loc
;
3159 /* Match an IMPLICIT statement, storing the types for
3160 gfc_set_implicit() if the statement is accepted by the parser.
3161 There is a strange looking, but legal syntactic construction
3162 possible. It looks like:
3164 IMPLICIT INTEGER (a-b) (c-d)
3166 This is legal if "a-b" is a constant expression that happens to
3167 equal one of the legal kinds for integers. The real problem
3168 happens with an implicit specification that looks like:
3170 IMPLICIT INTEGER (a-b)
3172 In this case, a typespec matcher that is "greedy" (as most of the
3173 matchers are) gobbles the character range as a kindspec, leaving
3174 nothing left. We therefore have to go a bit more slowly in the
3175 matching process by inhibiting the kindspec checking during
3176 typespec matching and checking for a kind later. */
3179 gfc_match_implicit (void)
3186 if (gfc_current_ns
->seen_implicit_none
)
3188 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3195 /* We don't allow empty implicit statements. */
3196 if (gfc_match_eos () == MATCH_YES
)
3198 gfc_error ("Empty IMPLICIT statement at %C");
3204 /* First cleanup. */
3205 gfc_clear_new_implicit ();
3207 /* A basic type is mandatory here. */
3208 m
= gfc_match_decl_type_spec (&ts
, 1);
3209 if (m
== MATCH_ERROR
)
3214 cur_loc
= gfc_current_locus
;
3215 m
= match_implicit_range ();
3219 /* We may have <TYPE> (<RANGE>). */
3220 gfc_gobble_whitespace ();
3221 c
= gfc_peek_ascii_char ();
3222 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3224 /* Check for CHARACTER with no length parameter. */
3225 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3227 ts
.kind
= gfc_default_character_kind
;
3228 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3229 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3233 /* Record the Successful match. */
3234 if (!gfc_merge_new_implicit (&ts
))
3237 c
= gfc_next_ascii_char ();
3238 else if (gfc_match_eos () == MATCH_ERROR
)
3243 gfc_current_locus
= cur_loc
;
3246 /* Discard the (incorrectly) matched range. */
3247 gfc_clear_new_implicit ();
3249 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3250 if (ts
.type
== BT_CHARACTER
)
3251 m
= gfc_match_char_spec (&ts
);
3254 m
= gfc_match_kind_spec (&ts
, false);
3257 m
= gfc_match_old_kind_spec (&ts
);
3258 if (m
== MATCH_ERROR
)
3264 if (m
== MATCH_ERROR
)
3267 m
= match_implicit_range ();
3268 if (m
== MATCH_ERROR
)
3273 gfc_gobble_whitespace ();
3274 c
= gfc_next_ascii_char ();
3275 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3278 if (!gfc_merge_new_implicit (&ts
))
3286 gfc_syntax_error (ST_IMPLICIT
);
3294 gfc_match_import (void)
3296 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3301 if (gfc_current_ns
->proc_name
== NULL
3302 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3304 gfc_error ("IMPORT statement at %C only permitted in "
3305 "an INTERFACE body");
3309 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3311 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3312 "in a module procedure interface body");
3316 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3319 if (gfc_match_eos () == MATCH_YES
)
3321 /* All host variables should be imported. */
3322 gfc_current_ns
->has_import_set
= 1;
3326 if (gfc_match (" ::") == MATCH_YES
)
3328 if (gfc_match_eos () == MATCH_YES
)
3330 gfc_error ("Expecting list of named entities at %C");
3338 m
= gfc_match (" %n", name
);
3342 if (gfc_current_ns
->parent
!= NULL
3343 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3345 gfc_error ("Type name %qs at %C is ambiguous", name
);
3348 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3349 && gfc_find_symbol (name
,
3350 gfc_current_ns
->proc_name
->ns
->parent
,
3353 gfc_error ("Type name %qs at %C is ambiguous", name
);
3359 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3360 "at %C - does not exist.", name
);
3364 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3366 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3371 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3374 sym
->attr
.imported
= 1;
3376 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3378 /* The actual derived type is stored in a symtree with the first
3379 letter of the name capitalized; the symtree with the all
3380 lower-case name contains the associated generic function. */
3381 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3382 gfc_get_string ("%c%s",
3383 (char) TOUPPER ((unsigned char) name
[0]),
3387 sym
->attr
.imported
= 1;
3400 if (gfc_match_eos () == MATCH_YES
)
3402 if (gfc_match_char (',') != MATCH_YES
)
3409 gfc_error ("Syntax error in IMPORT statement at %C");
3414 /* A minimal implementation of gfc_match without whitespace, escape
3415 characters or variable arguments. Returns true if the next
3416 characters match the TARGET template exactly. */
3419 match_string_p (const char *target
)
3423 for (p
= target
; *p
; p
++)
3424 if ((char) gfc_next_ascii_char () != *p
)
3429 /* Matches an attribute specification including array specs. If
3430 successful, leaves the variables current_attr and current_as
3431 holding the specification. Also sets the colon_seen variable for
3432 later use by matchers associated with initializations.
3434 This subroutine is a little tricky in the sense that we don't know
3435 if we really have an attr-spec until we hit the double colon.
3436 Until that time, we can only return MATCH_NO. This forces us to
3437 check for duplicate specification at this level. */
3440 match_attr_spec (void)
3442 /* Modifiers that can exist in a type statement. */
3444 { GFC_DECL_BEGIN
= 0,
3445 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3446 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3447 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3448 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3449 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3450 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3453 /* GFC_DECL_END is the sentinel, index starts at 0. */
3454 #define NUM_DECL GFC_DECL_END
3456 locus start
, seen_at
[NUM_DECL
];
3463 gfc_clear_attr (¤t_attr
);
3464 start
= gfc_current_locus
;
3469 /* See if we get all of the keywords up to the final double colon. */
3470 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3478 gfc_gobble_whitespace ();
3480 ch
= gfc_next_ascii_char ();
3483 /* This is the successful exit condition for the loop. */
3484 if (gfc_next_ascii_char () == ':')
3489 gfc_gobble_whitespace ();
3490 switch (gfc_peek_ascii_char ())
3493 gfc_next_ascii_char ();
3494 switch (gfc_next_ascii_char ())
3497 if (match_string_p ("locatable"))
3499 /* Matched "allocatable". */
3500 d
= DECL_ALLOCATABLE
;
3505 if (match_string_p ("ynchronous"))
3507 /* Matched "asynchronous". */
3508 d
= DECL_ASYNCHRONOUS
;
3515 /* Try and match the bind(c). */
3516 m
= gfc_match_bind_c (NULL
, true);
3519 else if (m
== MATCH_ERROR
)
3524 gfc_next_ascii_char ();
3525 if ('o' != gfc_next_ascii_char ())
3527 switch (gfc_next_ascii_char ())
3530 if (match_string_p ("imension"))
3532 d
= DECL_CODIMENSION
;
3536 if (match_string_p ("tiguous"))
3538 d
= DECL_CONTIGUOUS
;
3545 if (match_string_p ("dimension"))
3550 if (match_string_p ("external"))
3555 if (match_string_p ("int"))
3557 ch
= gfc_next_ascii_char ();
3560 if (match_string_p ("nt"))
3562 /* Matched "intent". */
3563 /* TODO: Call match_intent_spec from here. */
3564 if (gfc_match (" ( in out )") == MATCH_YES
)
3566 else if (gfc_match (" ( in )") == MATCH_YES
)
3568 else if (gfc_match (" ( out )") == MATCH_YES
)
3574 if (match_string_p ("insic"))
3576 /* Matched "intrinsic". */
3584 if (match_string_p ("optional"))
3589 gfc_next_ascii_char ();
3590 switch (gfc_next_ascii_char ())
3593 if (match_string_p ("rameter"))
3595 /* Matched "parameter". */
3601 if (match_string_p ("inter"))
3603 /* Matched "pointer". */
3609 ch
= gfc_next_ascii_char ();
3612 if (match_string_p ("vate"))
3614 /* Matched "private". */
3620 if (match_string_p ("tected"))
3622 /* Matched "protected". */
3629 if (match_string_p ("blic"))
3631 /* Matched "public". */
3639 if (match_string_p ("save"))
3644 if (match_string_p ("target"))
3649 gfc_next_ascii_char ();
3650 ch
= gfc_next_ascii_char ();
3653 if (match_string_p ("lue"))
3655 /* Matched "value". */
3661 if (match_string_p ("latile"))
3663 /* Matched "volatile". */
3671 /* No double colon and no recognizable decl_type, so assume that
3672 we've been looking at something else the whole time. */
3679 /* Check to make sure any parens are paired up correctly. */
3680 if (gfc_match_parens () == MATCH_ERROR
)
3687 seen_at
[d
] = gfc_current_locus
;
3689 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3691 gfc_array_spec
*as
= NULL
;
3693 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3694 d
== DECL_CODIMENSION
);
3696 if (current_as
== NULL
)
3698 else if (m
== MATCH_YES
)
3700 if (!merge_array_spec (as
, current_as
, false))
3707 if (d
== DECL_CODIMENSION
)
3708 gfc_error ("Missing codimension specification at %C");
3710 gfc_error ("Missing dimension specification at %C");
3714 if (m
== MATCH_ERROR
)
3719 /* Since we've seen a double colon, we have to be looking at an
3720 attr-spec. This means that we can now issue errors. */
3721 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3726 case DECL_ALLOCATABLE
:
3727 attr
= "ALLOCATABLE";
3729 case DECL_ASYNCHRONOUS
:
3730 attr
= "ASYNCHRONOUS";
3732 case DECL_CODIMENSION
:
3733 attr
= "CODIMENSION";
3735 case DECL_CONTIGUOUS
:
3736 attr
= "CONTIGUOUS";
3738 case DECL_DIMENSION
:
3745 attr
= "INTENT (IN)";
3748 attr
= "INTENT (OUT)";
3751 attr
= "INTENT (IN OUT)";
3753 case DECL_INTRINSIC
:
3759 case DECL_PARAMETER
:
3765 case DECL_PROTECTED
:
3780 case DECL_IS_BIND_C
:
3790 attr
= NULL
; /* This shouldn't happen. */
3793 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3798 /* Now that we've dealt with duplicate attributes, add the attributes
3799 to the current attribute. */
3800 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3805 if (gfc_current_state () == COMP_DERIVED
3806 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3807 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3808 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3810 if (d
== DECL_ALLOCATABLE
)
3812 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3813 "attribute at %C in a TYPE definition"))
3821 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3828 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3829 && gfc_current_state () != COMP_MODULE
)
3831 if (d
== DECL_PRIVATE
)
3835 if (gfc_current_state () == COMP_DERIVED
3836 && gfc_state_stack
->previous
3837 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3839 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3840 "at %L in a TYPE definition", attr
,
3849 gfc_error ("%s attribute at %L is not allowed outside of the "
3850 "specification part of a module", attr
, &seen_at
[d
]);
3858 case DECL_ALLOCATABLE
:
3859 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3862 case DECL_ASYNCHRONOUS
:
3863 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3866 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3869 case DECL_CODIMENSION
:
3870 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3873 case DECL_CONTIGUOUS
:
3874 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3877 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3880 case DECL_DIMENSION
:
3881 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3885 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3889 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3893 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3897 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3900 case DECL_INTRINSIC
:
3901 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3905 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3908 case DECL_PARAMETER
:
3909 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3913 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3916 case DECL_PROTECTED
:
3917 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3919 gfc_error ("PROTECTED at %C only allowed in specification "
3920 "part of a module");
3925 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3928 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3932 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3937 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3942 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3946 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3949 case DECL_IS_BIND_C
:
3950 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3954 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3957 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3961 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3964 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3968 gfc_internal_error ("match_attr_spec(): Bad attribute");
3978 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3979 if ((gfc_current_state () == COMP_MODULE
3980 || gfc_current_state () == COMP_SUBMODULE
)
3981 && !current_attr
.save
3982 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3983 current_attr
.save
= SAVE_IMPLICIT
;
3989 gfc_current_locus
= start
;
3990 gfc_free_array_spec (current_as
);
3996 /* Set the binding label, dest_label, either with the binding label
3997 stored in the given gfc_typespec, ts, or if none was provided, it
3998 will be the symbol name in all lower case, as required by the draft
3999 (J3/04-007, section 15.4.1). If a binding label was given and
4000 there is more than one argument (num_idents), it is an error. */
4003 set_binding_label (const char **dest_label
, const char *sym_name
,
4006 if (num_idents
> 1 && has_name_equals
)
4008 gfc_error ("Multiple identifiers provided with "
4009 "single NAME= specifier at %C");
4013 if (curr_binding_label
)
4014 /* Binding label given; store in temp holder till have sym. */
4015 *dest_label
= curr_binding_label
;
4018 /* No binding label given, and the NAME= specifier did not exist,
4019 which means there was no NAME="". */
4020 if (sym_name
!= NULL
&& has_name_equals
== 0)
4021 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4028 /* Set the status of the given common block as being BIND(C) or not,
4029 depending on the given parameter, is_bind_c. */
4032 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4034 com_block
->is_bind_c
= is_bind_c
;
4039 /* Verify that the given gfc_typespec is for a C interoperable type. */
4042 gfc_verify_c_interop (gfc_typespec
*ts
)
4044 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4045 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4047 else if (ts
->type
== BT_CLASS
)
4049 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4056 /* Verify that the variables of a given common block, which has been
4057 defined with the attribute specifier bind(c), to be of a C
4058 interoperable type. Errors will be reported here, if
4062 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4064 gfc_symbol
*curr_sym
= NULL
;
4067 curr_sym
= com_block
->head
;
4069 /* Make sure we have at least one symbol. */
4070 if (curr_sym
== NULL
)
4073 /* Here we know we have a symbol, so we'll execute this loop
4077 /* The second to last param, 1, says this is in a common block. */
4078 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4079 curr_sym
= curr_sym
->common_next
;
4080 } while (curr_sym
!= NULL
);
4086 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4087 an appropriate error message is reported. */
4090 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4091 int is_in_common
, gfc_common_head
*com_block
)
4093 bool bind_c_function
= false;
4096 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4097 bind_c_function
= true;
4099 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4101 tmp_sym
= tmp_sym
->result
;
4102 /* Make sure it wasn't an implicitly typed result. */
4103 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4105 gfc_warning (OPT_Wc_binding_type
,
4106 "Implicitly declared BIND(C) function %qs at "
4107 "%L may not be C interoperable", tmp_sym
->name
,
4108 &tmp_sym
->declared_at
);
4109 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4110 /* Mark it as C interoperable to prevent duplicate warnings. */
4111 tmp_sym
->ts
.is_c_interop
= 1;
4112 tmp_sym
->attr
.is_c_interop
= 1;
4116 /* Here, we know we have the bind(c) attribute, so if we have
4117 enough type info, then verify that it's a C interop kind.
4118 The info could be in the symbol already, or possibly still in
4119 the given ts (current_ts), so look in both. */
4120 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4122 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4124 /* See if we're dealing with a sym in a common block or not. */
4125 if (is_in_common
== 1 && warn_c_binding_type
)
4127 gfc_warning (OPT_Wc_binding_type
,
4128 "Variable %qs in common block %qs at %L "
4129 "may not be a C interoperable "
4130 "kind though common block %qs is BIND(C)",
4131 tmp_sym
->name
, com_block
->name
,
4132 &(tmp_sym
->declared_at
), com_block
->name
);
4136 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4137 gfc_error ("Type declaration %qs at %L is not C "
4138 "interoperable but it is BIND(C)",
4139 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4140 else if (warn_c_binding_type
)
4141 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4142 "may not be a C interoperable "
4143 "kind but it is BIND(C)",
4144 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4148 /* Variables declared w/in a common block can't be bind(c)
4149 since there's no way for C to see these variables, so there's
4150 semantically no reason for the attribute. */
4151 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4153 gfc_error ("Variable %qs in common block %qs at "
4154 "%L cannot be declared with BIND(C) "
4155 "since it is not a global",
4156 tmp_sym
->name
, com_block
->name
,
4157 &(tmp_sym
->declared_at
));
4161 /* Scalar variables that are bind(c) can not have the pointer
4162 or allocatable attributes. */
4163 if (tmp_sym
->attr
.is_bind_c
== 1)
4165 if (tmp_sym
->attr
.pointer
== 1)
4167 gfc_error ("Variable %qs at %L cannot have both the "
4168 "POINTER and BIND(C) attributes",
4169 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4173 if (tmp_sym
->attr
.allocatable
== 1)
4175 gfc_error ("Variable %qs at %L cannot have both the "
4176 "ALLOCATABLE and BIND(C) attributes",
4177 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4183 /* If it is a BIND(C) function, make sure the return value is a
4184 scalar value. The previous tests in this function made sure
4185 the type is interoperable. */
4186 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4187 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4188 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4190 /* BIND(C) functions can not return a character string. */
4191 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4192 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4193 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4194 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4195 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4196 "be a character string", tmp_sym
->name
,
4197 &(tmp_sym
->declared_at
));
4200 /* See if the symbol has been marked as private. If it has, make sure
4201 there is no binding label and warn the user if there is one. */
4202 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4203 && tmp_sym
->binding_label
)
4204 /* Use gfc_warning_now because we won't say that the symbol fails
4205 just because of this. */
4206 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4207 "given the binding label %qs", tmp_sym
->name
,
4208 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4214 /* Set the appropriate fields for a symbol that's been declared as
4215 BIND(C) (the is_bind_c flag and the binding label), and verify that
4216 the type is C interoperable. Errors are reported by the functions
4217 used to set/test these fields. */
4220 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4224 /* TODO: Do we need to make sure the vars aren't marked private? */
4226 /* Set the is_bind_c bit in symbol_attribute. */
4227 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4229 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4236 /* Set the fields marking the given common block as BIND(C), including
4237 a binding label, and report any errors encountered. */
4240 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4244 /* destLabel, common name, typespec (which may have binding label). */
4245 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4249 /* Set the given common block (com_block) to being bind(c) (1). */
4250 set_com_block_bind_c (com_block
, 1);
4256 /* Retrieve the list of one or more identifiers that the given bind(c)
4257 attribute applies to. */
4260 get_bind_c_idents (void)
4262 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4264 gfc_symbol
*tmp_sym
= NULL
;
4266 gfc_common_head
*com_block
= NULL
;
4268 if (gfc_match_name (name
) == MATCH_YES
)
4270 found_id
= MATCH_YES
;
4271 gfc_get_ha_symbol (name
, &tmp_sym
);
4273 else if (match_common_name (name
) == MATCH_YES
)
4275 found_id
= MATCH_YES
;
4276 com_block
= gfc_get_common (name
, 0);
4280 gfc_error ("Need either entity or common block name for "
4281 "attribute specification statement at %C");
4285 /* Save the current identifier and look for more. */
4288 /* Increment the number of identifiers found for this spec stmt. */
4291 /* Make sure we have a sym or com block, and verify that it can
4292 be bind(c). Set the appropriate field(s) and look for more
4294 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4296 if (tmp_sym
!= NULL
)
4298 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4303 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4307 /* Look to see if we have another identifier. */
4309 if (gfc_match_eos () == MATCH_YES
)
4310 found_id
= MATCH_NO
;
4311 else if (gfc_match_char (',') != MATCH_YES
)
4312 found_id
= MATCH_NO
;
4313 else if (gfc_match_name (name
) == MATCH_YES
)
4315 found_id
= MATCH_YES
;
4316 gfc_get_ha_symbol (name
, &tmp_sym
);
4318 else if (match_common_name (name
) == MATCH_YES
)
4320 found_id
= MATCH_YES
;
4321 com_block
= gfc_get_common (name
, 0);
4325 gfc_error ("Missing entity or common block name for "
4326 "attribute specification statement at %C");
4332 gfc_internal_error ("Missing symbol");
4334 } while (found_id
== MATCH_YES
);
4336 /* if we get here we were successful */
4341 /* Try and match a BIND(C) attribute specification statement. */
4344 gfc_match_bind_c_stmt (void)
4346 match found_match
= MATCH_NO
;
4351 /* This may not be necessary. */
4353 /* Clear the temporary binding label holder. */
4354 curr_binding_label
= NULL
;
4356 /* Look for the bind(c). */
4357 found_match
= gfc_match_bind_c (NULL
, true);
4359 if (found_match
== MATCH_YES
)
4361 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4364 /* Look for the :: now, but it is not required. */
4367 /* Get the identifier(s) that needs to be updated. This may need to
4368 change to hand the flag(s) for the attr specified so all identifiers
4369 found can have all appropriate parts updated (assuming that the same
4370 spec stmt can have multiple attrs, such as both bind(c) and
4372 if (!get_bind_c_idents ())
4373 /* Error message should have printed already. */
4381 /* Match a data declaration statement. */
4384 gfc_match_data_decl (void)
4390 num_idents_on_line
= 0;
4392 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4396 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4397 && gfc_current_state () != COMP_DERIVED
)
4399 sym
= gfc_use_derived (current_ts
.u
.derived
);
4407 current_ts
.u
.derived
= sym
;
4410 m
= match_attr_spec ();
4411 if (m
== MATCH_ERROR
)
4417 if (current_ts
.type
== BT_CLASS
4418 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4421 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4422 && current_ts
.u
.derived
->components
== NULL
4423 && !current_ts
.u
.derived
->attr
.zero_comp
)
4426 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4429 gfc_find_symbol (current_ts
.u
.derived
->name
,
4430 current_ts
.u
.derived
->ns
, 1, &sym
);
4432 /* Any symbol that we find had better be a type definition
4433 which has its components defined. */
4434 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4435 && (current_ts
.u
.derived
->components
!= NULL
4436 || current_ts
.u
.derived
->attr
.zero_comp
))
4439 gfc_error ("Derived type at %C has not been previously defined "
4440 "and so cannot appear in a derived type definition");
4446 /* If we have an old-style character declaration, and no new-style
4447 attribute specifications, then there a comma is optional between
4448 the type specification and the variable list. */
4449 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4450 gfc_match_char (',');
4452 /* Give the types/attributes to symbols that follow. Give the element
4453 a number so that repeat character length expressions can be copied. */
4457 num_idents_on_line
++;
4458 m
= variable_decl (elem
++);
4459 if (m
== MATCH_ERROR
)
4464 if (gfc_match_eos () == MATCH_YES
)
4466 if (gfc_match_char (',') != MATCH_YES
)
4470 if (!gfc_error_flag_test ())
4471 gfc_error ("Syntax error in data declaration at %C");
4474 gfc_free_data_all (gfc_current_ns
);
4477 gfc_free_array_spec (current_as
);
4483 /* Match a prefix associated with a function or subroutine
4484 declaration. If the typespec pointer is nonnull, then a typespec
4485 can be matched. Note that if nothing matches, MATCH_YES is
4486 returned (the null string was matched). */
4489 gfc_match_prefix (gfc_typespec
*ts
)
4495 gfc_clear_attr (¤t_attr
);
4497 seen_impure
= false;
4499 gcc_assert (!gfc_matching_prefix
);
4500 gfc_matching_prefix
= true;
4504 found_prefix
= false;
4506 if (!seen_type
&& ts
!= NULL
4507 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4508 && gfc_match_space () == MATCH_YES
)
4512 found_prefix
= true;
4515 if (gfc_match ("elemental% ") == MATCH_YES
)
4517 if (!gfc_add_elemental (¤t_attr
, NULL
))
4520 found_prefix
= true;
4523 if (gfc_match ("pure% ") == MATCH_YES
)
4525 if (!gfc_add_pure (¤t_attr
, NULL
))
4528 found_prefix
= true;
4531 if (gfc_match ("recursive% ") == MATCH_YES
)
4533 if (!gfc_add_recursive (¤t_attr
, NULL
))
4536 found_prefix
= true;
4539 /* IMPURE is a somewhat special case, as it needs not set an actual
4540 attribute but rather only prevents ELEMENTAL routines from being
4541 automatically PURE. */
4542 if (gfc_match ("impure% ") == MATCH_YES
)
4544 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4548 found_prefix
= true;
4551 while (found_prefix
);
4553 /* IMPURE and PURE must not both appear, of course. */
4554 if (seen_impure
&& current_attr
.pure
)
4556 gfc_error ("PURE and IMPURE must not appear both at %C");
4560 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4561 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4563 if (!gfc_add_pure (¤t_attr
, NULL
))
4567 /* At this point, the next item is not a prefix. */
4568 gcc_assert (gfc_matching_prefix
);
4570 /* MODULE should be the last prefix before FUNCTION or SUBROUTINE.
4571 Since this is a prefix like PURE, ELEMENTAL, etc., having a
4572 corresponding attribute seems natural and distinguishes these
4573 procedures from procedure types of PROC_MODULE, which these are
4575 if ((gfc_current_state () == COMP_INTERFACE
4576 || gfc_current_state () == COMP_CONTAINS
)
4577 && gfc_match ("module% ") == MATCH_YES
)
4579 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4582 current_attr
.module_procedure
= 1;
4585 gfc_matching_prefix
= false;
4589 gcc_assert (gfc_matching_prefix
);
4590 gfc_matching_prefix
= false;
4595 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4598 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4600 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4603 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4606 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4613 /* Match a formal argument list. */
4616 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4618 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4619 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4622 gfc_formal_arglist
*formal
= NULL
;
4626 /* Keep the interface formal argument list and null it so that the
4627 matching for the new declaration can be done. The numbers and
4628 names of the arguments are checked here. The interface formal
4629 arguments are retained in formal_arglist and the characteristics
4630 are compared in resolve.c(resolve_fl_procedure). See the remark
4631 in get_proc_name about the eventual need to copy the formal_arglist
4632 and populate the formal namespace of the interface symbol. */
4633 if (progname
->attr
.module_procedure
4634 && progname
->attr
.host_assoc
)
4636 formal
= progname
->formal
;
4637 progname
->formal
= NULL
;
4640 if (gfc_match_char ('(') != MATCH_YES
)
4647 if (gfc_match_char (')') == MATCH_YES
)
4652 if (gfc_match_char ('*') == MATCH_YES
)
4655 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4664 m
= gfc_match_name (name
);
4668 if (gfc_get_symbol (name
, NULL
, &sym
))
4672 p
= gfc_get_formal_arglist ();
4684 /* We don't add the VARIABLE flavor because the name could be a
4685 dummy procedure. We don't apply these attributes to formal
4686 arguments of statement functions. */
4687 if (sym
!= NULL
&& !st_flag
4688 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4689 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4695 /* The name of a program unit can be in a different namespace,
4696 so check for it explicitly. After the statement is accepted,
4697 the name is checked for especially in gfc_get_symbol(). */
4698 if (gfc_new_block
!= NULL
&& sym
!= NULL
4699 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4701 gfc_error ("Name %qs at %C is the name of the procedure",
4707 if (gfc_match_char (')') == MATCH_YES
)
4710 m
= gfc_match_char (',');
4713 gfc_error ("Unexpected junk in formal argument list at %C");
4719 /* Check for duplicate symbols in the formal argument list. */
4722 for (p
= head
; p
->next
; p
= p
->next
)
4727 for (q
= p
->next
; q
; q
= q
->next
)
4728 if (p
->sym
== q
->sym
)
4730 gfc_error ("Duplicate symbol %qs in formal argument list "
4731 "at %C", p
->sym
->name
);
4739 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4747 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
4749 if ((p
->next
!= NULL
&& q
->next
== NULL
)
4750 || (p
->next
== NULL
&& q
->next
!= NULL
))
4751 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
4752 "formal arguments at %C");
4753 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
4754 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
4757 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
4758 "argument names (%s/%s) at %C",
4759 p
->sym
->name
, q
->sym
->name
);
4766 gfc_free_formal_arglist (head
);
4771 /* Match a RESULT specification following a function declaration or
4772 ENTRY statement. Also matches the end-of-statement. */
4775 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4777 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4781 if (gfc_match (" result (") != MATCH_YES
)
4784 m
= gfc_match_name (name
);
4788 /* Get the right paren, and that's it because there could be the
4789 bind(c) attribute after the result clause. */
4790 if (gfc_match_char (')') != MATCH_YES
)
4792 /* TODO: should report the missing right paren here. */
4796 if (strcmp (function
->name
, name
) == 0)
4798 gfc_error ("RESULT variable at %C must be different than function name");
4802 if (gfc_get_symbol (name
, NULL
, &r
))
4805 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4814 /* Match a function suffix, which could be a combination of a result
4815 clause and BIND(C), either one, or neither. The draft does not
4816 require them to come in a specific order. */
4819 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4821 match is_bind_c
; /* Found bind(c). */
4822 match is_result
; /* Found result clause. */
4823 match found_match
; /* Status of whether we've found a good match. */
4824 char peek_char
; /* Character we're going to peek at. */
4825 bool allow_binding_name
;
4827 /* Initialize to having found nothing. */
4828 found_match
= MATCH_NO
;
4829 is_bind_c
= MATCH_NO
;
4830 is_result
= MATCH_NO
;
4832 /* Get the next char to narrow between result and bind(c). */
4833 gfc_gobble_whitespace ();
4834 peek_char
= gfc_peek_ascii_char ();
4836 /* C binding names are not allowed for internal procedures. */
4837 if (gfc_current_state () == COMP_CONTAINS
4838 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4839 allow_binding_name
= false;
4841 allow_binding_name
= true;
4846 /* Look for result clause. */
4847 is_result
= match_result (sym
, result
);
4848 if (is_result
== MATCH_YES
)
4850 /* Now see if there is a bind(c) after it. */
4851 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4852 /* We've found the result clause and possibly bind(c). */
4853 found_match
= MATCH_YES
;
4856 /* This should only be MATCH_ERROR. */
4857 found_match
= is_result
;
4860 /* Look for bind(c) first. */
4861 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4862 if (is_bind_c
== MATCH_YES
)
4864 /* Now see if a result clause followed it. */
4865 is_result
= match_result (sym
, result
);
4866 found_match
= MATCH_YES
;
4870 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4871 found_match
= MATCH_ERROR
;
4875 gfc_error ("Unexpected junk after function declaration at %C");
4876 found_match
= MATCH_ERROR
;
4880 if (is_bind_c
== MATCH_YES
)
4882 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4883 if (gfc_current_state () == COMP_CONTAINS
4884 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4885 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4886 "at %L may not be specified for an internal "
4887 "procedure", &gfc_current_locus
))
4890 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4898 /* Procedure pointer return value without RESULT statement:
4899 Add "hidden" result variable named "ppr@". */
4902 add_hidden_procptr_result (gfc_symbol
*sym
)
4906 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4909 /* First usage case: PROCEDURE and EXTERNAL statements. */
4910 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4911 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4912 && sym
->attr
.external
;
4913 /* Second usage case: INTERFACE statements. */
4914 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4915 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4916 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4922 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4926 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4927 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4928 st2
->n
.sym
= stree
->n
.sym
;
4930 sym
->result
= stree
->n
.sym
;
4932 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4933 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4934 sym
->result
->attr
.external
= sym
->attr
.external
;
4935 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4936 sym
->result
->ts
= sym
->ts
;
4937 sym
->attr
.proc_pointer
= 0;
4938 sym
->attr
.pointer
= 0;
4939 sym
->attr
.external
= 0;
4940 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4942 sym
->result
->attr
.pointer
= 0;
4943 sym
->result
->attr
.proc_pointer
= 1;
4946 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4948 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4949 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4950 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4951 && sym
== gfc_current_ns
->proc_name
4952 && sym
== sym
->result
->ns
->proc_name
4953 && strcmp ("ppr@", sym
->result
->name
) == 0)
4955 sym
->result
->attr
.proc_pointer
= 1;
4956 sym
->attr
.pointer
= 0;
4964 /* Match the interface for a PROCEDURE declaration,
4965 including brackets (R1212). */
4968 match_procedure_interface (gfc_symbol
**proc_if
)
4972 locus old_loc
, entry_loc
;
4973 gfc_namespace
*old_ns
= gfc_current_ns
;
4974 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4976 old_loc
= entry_loc
= gfc_current_locus
;
4977 gfc_clear_ts (¤t_ts
);
4979 if (gfc_match (" (") != MATCH_YES
)
4981 gfc_current_locus
= entry_loc
;
4985 /* Get the type spec. for the procedure interface. */
4986 old_loc
= gfc_current_locus
;
4987 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4988 gfc_gobble_whitespace ();
4989 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4992 if (m
== MATCH_ERROR
)
4995 /* Procedure interface is itself a procedure. */
4996 gfc_current_locus
= old_loc
;
4997 m
= gfc_match_name (name
);
4999 /* First look to see if it is already accessible in the current
5000 namespace because it is use associated or contained. */
5002 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5005 /* If it is still not found, then try the parent namespace, if it
5006 exists and create the symbol there if it is still not found. */
5007 if (gfc_current_ns
->parent
)
5008 gfc_current_ns
= gfc_current_ns
->parent
;
5009 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5012 gfc_current_ns
= old_ns
;
5013 *proc_if
= st
->n
.sym
;
5018 /* Resolve interface if possible. That way, attr.procedure is only set
5019 if it is declared by a later procedure-declaration-stmt, which is
5020 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5021 while ((*proc_if
)->ts
.interface
)
5022 *proc_if
= (*proc_if
)->ts
.interface
;
5024 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5025 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5026 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5027 (*proc_if
)->name
, NULL
))
5032 if (gfc_match (" )") != MATCH_YES
)
5034 gfc_current_locus
= entry_loc
;
5042 /* Match a PROCEDURE declaration (R1211). */
5045 match_procedure_decl (void)
5048 gfc_symbol
*sym
, *proc_if
= NULL
;
5050 gfc_expr
*initializer
= NULL
;
5052 /* Parse interface (with brackets). */
5053 m
= match_procedure_interface (&proc_if
);
5057 /* Parse attributes (with colons). */
5058 m
= match_attr_spec();
5059 if (m
== MATCH_ERROR
)
5062 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5064 current_attr
.is_bind_c
= 1;
5065 has_name_equals
= 0;
5066 curr_binding_label
= NULL
;
5069 /* Get procedure symbols. */
5072 m
= gfc_match_symbol (&sym
, 0);
5075 else if (m
== MATCH_ERROR
)
5078 /* Add current_attr to the symbol attributes. */
5079 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5082 if (sym
->attr
.is_bind_c
)
5084 /* Check for C1218. */
5085 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5087 gfc_error ("BIND(C) attribute at %C requires "
5088 "an interface with BIND(C)");
5091 /* Check for C1217. */
5092 if (has_name_equals
&& sym
->attr
.pointer
)
5094 gfc_error ("BIND(C) procedure with NAME may not have "
5095 "POINTER attribute at %C");
5098 if (has_name_equals
&& sym
->attr
.dummy
)
5100 gfc_error ("Dummy procedure at %C may not have "
5101 "BIND(C) attribute with NAME");
5104 /* Set binding label for BIND(C). */
5105 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5109 if (!gfc_add_external (&sym
->attr
, NULL
))
5112 if (add_hidden_procptr_result (sym
))
5115 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5118 /* Set interface. */
5119 if (proc_if
!= NULL
)
5121 if (sym
->ts
.type
!= BT_UNKNOWN
)
5123 gfc_error ("Procedure %qs at %L already has basic type of %s",
5124 sym
->name
, &gfc_current_locus
,
5125 gfc_basic_typename (sym
->ts
.type
));
5128 sym
->ts
.interface
= proc_if
;
5129 sym
->attr
.untyped
= 1;
5130 sym
->attr
.if_source
= IFSRC_IFBODY
;
5132 else if (current_ts
.type
!= BT_UNKNOWN
)
5134 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5136 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5137 sym
->ts
.interface
->ts
= current_ts
;
5138 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5139 sym
->ts
.interface
->attr
.function
= 1;
5140 sym
->attr
.function
= 1;
5141 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5144 if (gfc_match (" =>") == MATCH_YES
)
5146 if (!current_attr
.pointer
)
5148 gfc_error ("Initialization at %C isn't for a pointer variable");
5153 m
= match_pointer_init (&initializer
, 1);
5157 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5162 if (gfc_match_eos () == MATCH_YES
)
5164 if (gfc_match_char (',') != MATCH_YES
)
5169 gfc_error ("Syntax error in PROCEDURE statement at %C");
5173 /* Free stuff up and return. */
5174 gfc_free_expr (initializer
);
5180 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5183 /* Match a procedure pointer component declaration (R445). */
5186 match_ppc_decl (void)
5189 gfc_symbol
*proc_if
= NULL
;
5193 gfc_expr
*initializer
= NULL
;
5194 gfc_typebound_proc
* tb
;
5195 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5197 /* Parse interface (with brackets). */
5198 m
= match_procedure_interface (&proc_if
);
5202 /* Parse attributes. */
5203 tb
= XCNEW (gfc_typebound_proc
);
5204 tb
->where
= gfc_current_locus
;
5205 m
= match_binding_attributes (tb
, false, true);
5206 if (m
== MATCH_ERROR
)
5209 gfc_clear_attr (¤t_attr
);
5210 current_attr
.procedure
= 1;
5211 current_attr
.proc_pointer
= 1;
5212 current_attr
.access
= tb
->access
;
5213 current_attr
.flavor
= FL_PROCEDURE
;
5215 /* Match the colons (required). */
5216 if (gfc_match (" ::") != MATCH_YES
)
5218 gfc_error ("Expected %<::%> after binding-attributes at %C");
5222 /* Check for C450. */
5223 if (!tb
->nopass
&& proc_if
== NULL
)
5225 gfc_error("NOPASS or explicit interface required at %C");
5229 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5232 /* Match PPC names. */
5236 m
= gfc_match_name (name
);
5239 else if (m
== MATCH_ERROR
)
5242 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5245 /* Add current_attr to the symbol attributes. */
5246 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5249 if (!gfc_add_external (&c
->attr
, NULL
))
5252 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5259 c
->tb
= XCNEW (gfc_typebound_proc
);
5260 c
->tb
->where
= gfc_current_locus
;
5264 /* Set interface. */
5265 if (proc_if
!= NULL
)
5267 c
->ts
.interface
= proc_if
;
5268 c
->attr
.untyped
= 1;
5269 c
->attr
.if_source
= IFSRC_IFBODY
;
5271 else if (ts
.type
!= BT_UNKNOWN
)
5274 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5275 c
->ts
.interface
->result
= c
->ts
.interface
;
5276 c
->ts
.interface
->ts
= ts
;
5277 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5278 c
->ts
.interface
->attr
.function
= 1;
5279 c
->attr
.function
= 1;
5280 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5283 if (gfc_match (" =>") == MATCH_YES
)
5285 m
= match_pointer_init (&initializer
, 1);
5288 gfc_free_expr (initializer
);
5291 c
->initializer
= initializer
;
5294 if (gfc_match_eos () == MATCH_YES
)
5296 if (gfc_match_char (',') != MATCH_YES
)
5301 gfc_error ("Syntax error in procedure pointer component at %C");
5306 /* Match a PROCEDURE declaration inside an interface (R1206). */
5309 match_procedure_in_interface (void)
5313 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5316 if (current_interface
.type
== INTERFACE_NAMELESS
5317 || current_interface
.type
== INTERFACE_ABSTRACT
)
5319 gfc_error ("PROCEDURE at %C must be in a generic interface");
5323 /* Check if the F2008 optional double colon appears. */
5324 gfc_gobble_whitespace ();
5325 old_locus
= gfc_current_locus
;
5326 if (gfc_match ("::") == MATCH_YES
)
5328 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5329 "MODULE PROCEDURE statement at %L", &old_locus
))
5333 gfc_current_locus
= old_locus
;
5337 m
= gfc_match_name (name
);
5340 else if (m
== MATCH_ERROR
)
5342 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5345 if (!gfc_add_interface (sym
))
5348 if (gfc_match_eos () == MATCH_YES
)
5350 if (gfc_match_char (',') != MATCH_YES
)
5357 gfc_error ("Syntax error in PROCEDURE statement at %C");
5362 /* General matcher for PROCEDURE declarations. */
5364 static match
match_procedure_in_type (void);
5367 gfc_match_procedure (void)
5371 switch (gfc_current_state ())
5376 case COMP_SUBMODULE
:
5377 case COMP_SUBROUTINE
:
5380 m
= match_procedure_decl ();
5382 case COMP_INTERFACE
:
5383 m
= match_procedure_in_interface ();
5386 m
= match_ppc_decl ();
5388 case COMP_DERIVED_CONTAINS
:
5389 m
= match_procedure_in_type ();
5398 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5405 /* Warn if a matched procedure has the same name as an intrinsic; this is
5406 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5407 parser-state-stack to find out whether we're in a module. */
5410 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5414 in_module
= (gfc_state_stack
->previous
5415 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5416 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5418 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5422 /* Match a function declaration. */
5425 gfc_match_function_decl (void)
5427 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5428 gfc_symbol
*sym
, *result
;
5432 match found_match
; /* Status returned by match func. */
5434 if (gfc_current_state () != COMP_NONE
5435 && gfc_current_state () != COMP_INTERFACE
5436 && gfc_current_state () != COMP_CONTAINS
)
5439 gfc_clear_ts (¤t_ts
);
5441 old_loc
= gfc_current_locus
;
5443 m
= gfc_match_prefix (¤t_ts
);
5446 gfc_current_locus
= old_loc
;
5450 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5452 gfc_current_locus
= old_loc
;
5456 if (get_proc_name (name
, &sym
, false))
5459 if (add_hidden_procptr_result (sym
))
5462 if (current_attr
.module_procedure
)
5463 sym
->attr
.module_procedure
= 1;
5465 gfc_new_block
= sym
;
5467 m
= gfc_match_formal_arglist (sym
, 0, 0);
5470 gfc_error ("Expected formal argument list in function "
5471 "definition at %C");
5475 else if (m
== MATCH_ERROR
)
5480 /* According to the draft, the bind(c) and result clause can
5481 come in either order after the formal_arg_list (i.e., either
5482 can be first, both can exist together or by themselves or neither
5483 one). Therefore, the match_result can't match the end of the
5484 string, and check for the bind(c) or result clause in either order. */
5485 found_match
= gfc_match_eos ();
5487 /* Make sure that it isn't already declared as BIND(C). If it is, it
5488 must have been marked BIND(C) with a BIND(C) attribute and that is
5489 not allowed for procedures. */
5490 if (sym
->attr
.is_bind_c
== 1)
5492 sym
->attr
.is_bind_c
= 0;
5493 if (sym
->old_symbol
!= NULL
)
5494 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5495 "variables or common blocks",
5496 &(sym
->old_symbol
->declared_at
));
5498 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5499 "variables or common blocks", &gfc_current_locus
);
5502 if (found_match
!= MATCH_YES
)
5504 /* If we haven't found the end-of-statement, look for a suffix. */
5505 suffix_match
= gfc_match_suffix (sym
, &result
);
5506 if (suffix_match
== MATCH_YES
)
5507 /* Need to get the eos now. */
5508 found_match
= gfc_match_eos ();
5510 found_match
= suffix_match
;
5513 if(found_match
!= MATCH_YES
)
5517 /* Make changes to the symbol. */
5520 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5523 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5524 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5527 /* Delay matching the function characteristics until after the
5528 specification block by signalling kind=-1. */
5529 sym
->declared_at
= old_loc
;
5530 if (current_ts
.type
!= BT_UNKNOWN
)
5531 current_ts
.kind
= -1;
5533 current_ts
.kind
= 0;
5537 if (current_ts
.type
!= BT_UNKNOWN
5538 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5544 if (current_ts
.type
!= BT_UNKNOWN
5545 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5547 sym
->result
= result
;
5550 /* Warn if this procedure has the same name as an intrinsic. */
5551 do_warn_intrinsic_shadow (sym
, true);
5557 gfc_current_locus
= old_loc
;
5562 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5563 pass the name of the entry, rather than the gfc_current_block name, and
5564 to return false upon finding an existing global entry. */
5567 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5571 enum gfc_symbol_type type
;
5573 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5575 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5576 name is a global identifier. */
5577 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5579 s
= gfc_get_gsymbol (name
);
5581 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5583 gfc_global_used (s
, where
);
5592 s
->ns
= gfc_current_ns
;
5596 /* Don't add the symbol multiple times. */
5598 && (!gfc_notification_std (GFC_STD_F2008
)
5599 || strcmp (name
, binding_label
) != 0))
5601 s
= gfc_get_gsymbol (binding_label
);
5603 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5605 gfc_global_used (s
, where
);
5612 s
->binding_label
= binding_label
;
5615 s
->ns
= gfc_current_ns
;
5623 /* Match an ENTRY statement. */
5626 gfc_match_entry (void)
5631 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5632 gfc_compile_state state
;
5636 bool module_procedure
;
5640 m
= gfc_match_name (name
);
5644 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5647 state
= gfc_current_state ();
5648 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5653 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5656 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5658 case COMP_SUBMODULE
:
5659 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
5661 case COMP_BLOCK_DATA
:
5662 gfc_error ("ENTRY statement at %C cannot appear within "
5665 case COMP_INTERFACE
:
5666 gfc_error ("ENTRY statement at %C cannot appear within "
5670 gfc_error ("ENTRY statement at %C cannot appear within "
5671 "a DERIVED TYPE block");
5674 gfc_error ("ENTRY statement at %C cannot appear within "
5675 "an IF-THEN block");
5678 case COMP_DO_CONCURRENT
:
5679 gfc_error ("ENTRY statement at %C cannot appear within "
5683 gfc_error ("ENTRY statement at %C cannot appear within "
5687 gfc_error ("ENTRY statement at %C cannot appear within "
5691 gfc_error ("ENTRY statement at %C cannot appear within "
5695 gfc_error ("ENTRY statement at %C cannot appear within "
5696 "a contained subprogram");
5699 gfc_error ("Unexpected ENTRY statement at %C");
5704 module_procedure
= gfc_current_ns
->parent
!= NULL
5705 && gfc_current_ns
->parent
->proc_name
5706 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5709 if (gfc_current_ns
->parent
!= NULL
5710 && gfc_current_ns
->parent
->proc_name
5711 && !module_procedure
)
5713 gfc_error("ENTRY statement at %C cannot appear in a "
5714 "contained procedure");
5718 /* Module function entries need special care in get_proc_name
5719 because previous references within the function will have
5720 created symbols attached to the current namespace. */
5721 if (get_proc_name (name
, &entry
,
5722 gfc_current_ns
->parent
!= NULL
5723 && module_procedure
))
5726 proc
= gfc_current_block ();
5728 /* Make sure that it isn't already declared as BIND(C). If it is, it
5729 must have been marked BIND(C) with a BIND(C) attribute and that is
5730 not allowed for procedures. */
5731 if (entry
->attr
.is_bind_c
== 1)
5733 entry
->attr
.is_bind_c
= 0;
5734 if (entry
->old_symbol
!= NULL
)
5735 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5736 "variables or common blocks",
5737 &(entry
->old_symbol
->declared_at
));
5739 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5740 "variables or common blocks", &gfc_current_locus
);
5743 /* Check what next non-whitespace character is so we can tell if there
5744 is the required parens if we have a BIND(C). */
5745 old_loc
= gfc_current_locus
;
5746 gfc_gobble_whitespace ();
5747 peek_char
= gfc_peek_ascii_char ();
5749 if (state
== COMP_SUBROUTINE
)
5751 m
= gfc_match_formal_arglist (entry
, 0, 1);
5755 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5756 never be an internal procedure. */
5757 is_bind_c
= gfc_match_bind_c (entry
, true);
5758 if (is_bind_c
== MATCH_ERROR
)
5760 if (is_bind_c
== MATCH_YES
)
5762 if (peek_char
!= '(')
5764 gfc_error ("Missing required parentheses before BIND(C) at %C");
5767 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5768 &(entry
->declared_at
), 1))
5772 if (!gfc_current_ns
->parent
5773 && !add_global_entry (name
, entry
->binding_label
, true,
5777 /* An entry in a subroutine. */
5778 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5779 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5784 /* An entry in a function.
5785 We need to take special care because writing
5790 ENTRY f() RESULT (r)
5792 ENTRY f RESULT (r). */
5793 if (gfc_match_eos () == MATCH_YES
)
5795 gfc_current_locus
= old_loc
;
5796 /* Match the empty argument list, and add the interface to
5798 m
= gfc_match_formal_arglist (entry
, 0, 1);
5801 m
= gfc_match_formal_arglist (entry
, 0, 0);
5808 if (gfc_match_eos () == MATCH_YES
)
5810 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5811 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5814 entry
->result
= entry
;
5818 m
= gfc_match_suffix (entry
, &result
);
5820 gfc_syntax_error (ST_ENTRY
);
5826 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5827 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5828 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5830 entry
->result
= result
;
5834 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5835 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5837 entry
->result
= entry
;
5841 if (!gfc_current_ns
->parent
5842 && !add_global_entry (name
, entry
->binding_label
, false,
5847 if (gfc_match_eos () != MATCH_YES
)
5849 gfc_syntax_error (ST_ENTRY
);
5853 entry
->attr
.recursive
= proc
->attr
.recursive
;
5854 entry
->attr
.elemental
= proc
->attr
.elemental
;
5855 entry
->attr
.pure
= proc
->attr
.pure
;
5857 el
= gfc_get_entry_list ();
5859 el
->next
= gfc_current_ns
->entries
;
5860 gfc_current_ns
->entries
= el
;
5862 el
->id
= el
->next
->id
+ 1;
5866 new_st
.op
= EXEC_ENTRY
;
5867 new_st
.ext
.entry
= el
;
5873 /* Match a subroutine statement, including optional prefixes. */
5876 gfc_match_subroutine (void)
5878 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5883 bool allow_binding_name
;
5885 if (gfc_current_state () != COMP_NONE
5886 && gfc_current_state () != COMP_INTERFACE
5887 && gfc_current_state () != COMP_CONTAINS
)
5890 m
= gfc_match_prefix (NULL
);
5894 m
= gfc_match ("subroutine% %n", name
);
5898 if (get_proc_name (name
, &sym
, false))
5901 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5902 the symbol existed before. */
5903 sym
->declared_at
= gfc_current_locus
;
5905 if (current_attr
.module_procedure
)
5906 sym
->attr
.module_procedure
= 1;
5908 if (add_hidden_procptr_result (sym
))
5911 gfc_new_block
= sym
;
5913 /* Check what next non-whitespace character is so we can tell if there
5914 is the required parens if we have a BIND(C). */
5915 gfc_gobble_whitespace ();
5916 peek_char
= gfc_peek_ascii_char ();
5918 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5921 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5924 /* Make sure that it isn't already declared as BIND(C). If it is, it
5925 must have been marked BIND(C) with a BIND(C) attribute and that is
5926 not allowed for procedures. */
5927 if (sym
->attr
.is_bind_c
== 1)
5929 sym
->attr
.is_bind_c
= 0;
5930 if (sym
->old_symbol
!= NULL
)
5931 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5932 "variables or common blocks",
5933 &(sym
->old_symbol
->declared_at
));
5935 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5936 "variables or common blocks", &gfc_current_locus
);
5939 /* C binding names are not allowed for internal procedures. */
5940 if (gfc_current_state () == COMP_CONTAINS
5941 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5942 allow_binding_name
= false;
5944 allow_binding_name
= true;
5946 /* Here, we are just checking if it has the bind(c) attribute, and if
5947 so, then we need to make sure it's all correct. If it doesn't,
5948 we still need to continue matching the rest of the subroutine line. */
5949 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5950 if (is_bind_c
== MATCH_ERROR
)
5952 /* There was an attempt at the bind(c), but it was wrong. An
5953 error message should have been printed w/in the gfc_match_bind_c
5954 so here we'll just return the MATCH_ERROR. */
5958 if (is_bind_c
== MATCH_YES
)
5960 /* The following is allowed in the Fortran 2008 draft. */
5961 if (gfc_current_state () == COMP_CONTAINS
5962 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5963 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5964 "at %L may not be specified for an internal "
5965 "procedure", &gfc_current_locus
))
5968 if (peek_char
!= '(')
5970 gfc_error ("Missing required parentheses before BIND(C) at %C");
5973 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5974 &(sym
->declared_at
), 1))
5978 if (gfc_match_eos () != MATCH_YES
)
5980 gfc_syntax_error (ST_SUBROUTINE
);
5984 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5987 /* Warn if it has the same name as an intrinsic. */
5988 do_warn_intrinsic_shadow (sym
, false);
5994 /* Check that the NAME identifier in a BIND attribute or statement
5995 is conform to C identifier rules. */
5998 check_bind_name_identifier (char **name
)
6000 char *n
= *name
, *p
;
6002 /* Remove leading spaces. */
6006 /* On an empty string, free memory and set name to NULL. */
6014 /* Remove trailing spaces. */
6015 p
= n
+ strlen(n
) - 1;
6019 /* Insert the identifier into the symbol table. */
6024 /* Now check that identifier is valid under C rules. */
6027 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6032 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6034 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6042 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6043 given, and set the binding label in either the given symbol (if not
6044 NULL), or in the current_ts. The symbol may be NULL because we may
6045 encounter the BIND(C) before the declaration itself. Return
6046 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6047 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6048 or MATCH_YES if the specifier was correct and the binding label and
6049 bind(c) fields were set correctly for the given symbol or the
6050 current_ts. If allow_binding_name is false, no binding name may be
6054 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6056 char *binding_label
= NULL
;
6059 /* Initialize the flag that specifies whether we encountered a NAME=
6060 specifier or not. */
6061 has_name_equals
= 0;
6063 /* This much we have to be able to match, in this order, if
6064 there is a bind(c) label. */
6065 if (gfc_match (" bind ( c ") != MATCH_YES
)
6068 /* Now see if there is a binding label, or if we've reached the
6069 end of the bind(c) attribute without one. */
6070 if (gfc_match_char (',') == MATCH_YES
)
6072 if (gfc_match (" name = ") != MATCH_YES
)
6074 gfc_error ("Syntax error in NAME= specifier for binding label "
6076 /* should give an error message here */
6080 has_name_equals
= 1;
6082 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6088 if (!gfc_simplify_expr(e
, 0))
6090 gfc_error ("NAME= specifier at %C should be a constant expression");
6095 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6096 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6098 gfc_error ("NAME= specifier at %C should be a scalar of "
6099 "default character kind");
6104 // Get a C string from the Fortran string constant
6105 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6106 e
->value
.character
.length
);
6109 // Check that it is valid (old gfc_match_name_C)
6110 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6114 /* Get the required right paren. */
6115 if (gfc_match_char (')') != MATCH_YES
)
6117 gfc_error ("Missing closing paren for binding label at %C");
6121 if (has_name_equals
&& !allow_binding_name
)
6123 gfc_error ("No binding name is allowed in BIND(C) at %C");
6127 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6129 gfc_error ("For dummy procedure %s, no binding name is "
6130 "allowed in BIND(C) at %C", sym
->name
);
6135 /* Save the binding label to the symbol. If sym is null, we're
6136 probably matching the typespec attributes of a declaration and
6137 haven't gotten the name yet, and therefore, no symbol yet. */
6141 sym
->binding_label
= binding_label
;
6143 curr_binding_label
= binding_label
;
6145 else if (allow_binding_name
)
6147 /* No binding label, but if symbol isn't null, we
6148 can set the label for it here.
6149 If name="" or allow_binding_name is false, no C binding name is
6151 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6152 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6155 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6156 && current_interface
.type
== INTERFACE_ABSTRACT
)
6158 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6166 /* Return nonzero if we're currently compiling a contained procedure. */
6169 contained_procedure (void)
6171 gfc_state_data
*s
= gfc_state_stack
;
6173 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6174 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6180 /* Set the kind of each enumerator. The kind is selected such that it is
6181 interoperable with the corresponding C enumeration type, making
6182 sure that -fshort-enums is honored. */
6187 enumerator_history
*current_history
= NULL
;
6191 if (max_enum
== NULL
|| enum_history
== NULL
)
6194 if (!flag_short_enums
)
6200 kind
= gfc_integer_kinds
[i
++].kind
;
6202 while (kind
< gfc_c_int_kind
6203 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6206 current_history
= enum_history
;
6207 while (current_history
!= NULL
)
6209 current_history
->sym
->ts
.kind
= kind
;
6210 current_history
= current_history
->next
;
6215 /* Match any of the various end-block statements. Returns the type of
6216 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6217 and END BLOCK statements cannot be replaced by a single END statement. */
6220 gfc_match_end (gfc_statement
*st
)
6222 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6223 gfc_compile_state state
;
6225 const char *block_name
;
6229 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6230 gfc_namespace
**nsp
;
6231 bool abreviated_modproc_decl
;
6233 old_loc
= gfc_current_locus
;
6234 if (gfc_match ("end") != MATCH_YES
)
6237 state
= gfc_current_state ();
6238 block_name
= gfc_current_block () == NULL
6239 ? NULL
: gfc_current_block ()->name
;
6243 case COMP_ASSOCIATE
:
6245 if (!strncmp (block_name
, "block@", strlen("block@")))
6250 case COMP_DERIVED_CONTAINS
:
6251 state
= gfc_state_stack
->previous
->state
;
6252 block_name
= gfc_state_stack
->previous
->sym
== NULL
6253 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6260 abreviated_modproc_decl
6261 = gfc_current_block ()
6262 && gfc_current_block ()->abr_modproc_decl
;
6268 *st
= ST_END_PROGRAM
;
6269 target
= " program";
6273 case COMP_SUBROUTINE
:
6274 *st
= ST_END_SUBROUTINE
;
6275 if (!abreviated_modproc_decl
)
6276 target
= " subroutine";
6278 target
= " procedure";
6279 eos_ok
= !contained_procedure ();
6283 *st
= ST_END_FUNCTION
;
6284 if (!abreviated_modproc_decl
)
6285 target
= " function";
6287 target
= " procedure";
6288 eos_ok
= !contained_procedure ();
6291 case COMP_BLOCK_DATA
:
6292 *st
= ST_END_BLOCK_DATA
;
6293 target
= " block data";
6298 *st
= ST_END_MODULE
;
6303 case COMP_SUBMODULE
:
6304 *st
= ST_END_SUBMODULE
;
6305 target
= " submodule";
6309 case COMP_INTERFACE
:
6310 *st
= ST_END_INTERFACE
;
6311 target
= " interface";
6316 case COMP_DERIVED_CONTAINS
:
6322 case COMP_ASSOCIATE
:
6323 *st
= ST_END_ASSOCIATE
;
6324 target
= " associate";
6341 case COMP_DO_CONCURRENT
:
6348 *st
= ST_END_CRITICAL
;
6349 target
= " critical";
6354 case COMP_SELECT_TYPE
:
6355 *st
= ST_END_SELECT
;
6361 *st
= ST_END_FORALL
;
6376 last_initializer
= NULL
;
6378 gfc_free_enum_history ();
6382 gfc_error ("Unexpected END statement at %C");
6386 old_loc
= gfc_current_locus
;
6387 if (gfc_match_eos () == MATCH_YES
)
6389 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6391 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6392 "instead of %s statement at %L",
6393 abreviated_modproc_decl
? "END PROCEDURE"
6394 : gfc_ascii_statement(*st
), &old_loc
))
6399 /* We would have required END [something]. */
6400 gfc_error ("%s statement expected at %L",
6401 gfc_ascii_statement (*st
), &old_loc
);
6408 /* Verify that we've got the sort of end-block that we're expecting. */
6409 if (gfc_match (target
) != MATCH_YES
)
6411 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6412 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6416 old_loc
= gfc_current_locus
;
6417 /* If we're at the end, make sure a block name wasn't required. */
6418 if (gfc_match_eos () == MATCH_YES
)
6421 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6422 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6423 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6429 gfc_error ("Expected block name of %qs in %s statement at %L",
6430 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6435 /* END INTERFACE has a special handler for its several possible endings. */
6436 if (*st
== ST_END_INTERFACE
)
6437 return gfc_match_end_interface ();
6439 /* We haven't hit the end of statement, so what is left must be an
6441 m
= gfc_match_space ();
6443 m
= gfc_match_name (name
);
6446 gfc_error ("Expected terminating name at %C");
6450 if (block_name
== NULL
)
6453 /* We have to pick out the declared submodule name from the composite
6454 required by F2008:11.2.3 para 2, which ends in the declared name. */
6455 if (state
== COMP_SUBMODULE
)
6456 block_name
= strchr (block_name
, '.') + 1;
6458 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6460 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6461 gfc_ascii_statement (*st
));
6464 /* Procedure pointer as function result. */
6465 else if (strcmp (block_name
, "ppr@") == 0
6466 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6468 gfc_error ("Expected label %qs for %s statement at %C",
6469 gfc_current_block ()->ns
->proc_name
->name
,
6470 gfc_ascii_statement (*st
));
6474 if (gfc_match_eos () == MATCH_YES
)
6478 gfc_syntax_error (*st
);
6481 gfc_current_locus
= old_loc
;
6483 /* If we are missing an END BLOCK, we created a half-ready namespace.
6484 Remove it from the parent namespace's sibling list. */
6486 if (state
== COMP_BLOCK
)
6488 parent_ns
= gfc_current_ns
->parent
;
6490 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6496 if (ns
== gfc_current_ns
)
6498 if (prev_ns
== NULL
)
6501 prev_ns
->sibling
= ns
->sibling
;
6507 gfc_free_namespace (gfc_current_ns
);
6508 gfc_current_ns
= parent_ns
;
6516 /***************** Attribute declaration statements ****************/
6518 /* Set the attribute of a single variable. */
6523 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6526 /* Workaround -Wmaybe-uninitialized false positive during
6527 profiledbootstrap by initializing them. */
6528 gfc_symbol
*sym
= NULL
;
6534 m
= gfc_match_name (name
);
6538 if (find_special (name
, &sym
, false))
6541 if (!check_function_name (name
))
6547 var_locus
= gfc_current_locus
;
6549 /* Deal with possible array specification for certain attributes. */
6550 if (current_attr
.dimension
6551 || current_attr
.codimension
6552 || current_attr
.allocatable
6553 || current_attr
.pointer
6554 || current_attr
.target
)
6556 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6557 !current_attr
.dimension
6558 && !current_attr
.pointer
6559 && !current_attr
.target
);
6560 if (m
== MATCH_ERROR
)
6563 if (current_attr
.dimension
&& m
== MATCH_NO
)
6565 gfc_error ("Missing array specification at %L in DIMENSION "
6566 "statement", &var_locus
);
6571 if (current_attr
.dimension
&& sym
->value
)
6573 gfc_error ("Dimensions specified for %s at %L after its "
6574 "initialisation", sym
->name
, &var_locus
);
6579 if (current_attr
.codimension
&& m
== MATCH_NO
)
6581 gfc_error ("Missing array specification at %L in CODIMENSION "
6582 "statement", &var_locus
);
6587 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6588 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6590 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6596 /* Update symbol table. DIMENSION attribute is set in
6597 gfc_set_array_spec(). For CLASS variables, this must be applied
6598 to the first component, or '_data' field. */
6599 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6601 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6609 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6610 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6617 if (sym
->ts
.type
== BT_CLASS
6618 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
6624 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6630 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6632 /* Fix the array spec. */
6633 m
= gfc_mod_pointee_as (sym
->as
);
6634 if (m
== MATCH_ERROR
)
6638 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6644 if ((current_attr
.external
|| current_attr
.intrinsic
)
6645 && sym
->attr
.flavor
!= FL_PROCEDURE
6646 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6652 add_hidden_procptr_result (sym
);
6657 gfc_free_array_spec (as
);
6662 /* Generic attribute declaration subroutine. Used for attributes that
6663 just have a list of names. */
6670 /* Gobble the optional double colon, by simply ignoring the result
6680 if (gfc_match_eos () == MATCH_YES
)
6686 if (gfc_match_char (',') != MATCH_YES
)
6688 gfc_error ("Unexpected character in variable list at %C");
6698 /* This routine matches Cray Pointer declarations of the form:
6699 pointer ( <pointer>, <pointee> )
6701 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6702 The pointer, if already declared, should be an integer. Otherwise, we
6703 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6704 be either a scalar, or an array declaration. No space is allocated for
6705 the pointee. For the statement
6706 pointer (ipt, ar(10))
6707 any subsequent uses of ar will be translated (in C-notation) as
6708 ar(i) => ((<type> *) ipt)(i)
6709 After gimplification, pointee variable will disappear in the code. */
6712 cray_pointer_decl (void)
6715 gfc_array_spec
*as
= NULL
;
6716 gfc_symbol
*cptr
; /* Pointer symbol. */
6717 gfc_symbol
*cpte
; /* Pointee symbol. */
6723 if (gfc_match_char ('(') != MATCH_YES
)
6725 gfc_error ("Expected %<(%> at %C");
6729 /* Match pointer. */
6730 var_locus
= gfc_current_locus
;
6731 gfc_clear_attr (¤t_attr
);
6732 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6733 current_ts
.type
= BT_INTEGER
;
6734 current_ts
.kind
= gfc_index_integer_kind
;
6736 m
= gfc_match_symbol (&cptr
, 0);
6739 gfc_error ("Expected variable name at %C");
6743 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6746 gfc_set_sym_referenced (cptr
);
6748 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6750 cptr
->ts
.type
= BT_INTEGER
;
6751 cptr
->ts
.kind
= gfc_index_integer_kind
;
6753 else if (cptr
->ts
.type
!= BT_INTEGER
)
6755 gfc_error ("Cray pointer at %C must be an integer");
6758 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6759 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
6760 " memory addresses require %d bytes",
6761 cptr
->ts
.kind
, gfc_index_integer_kind
);
6763 if (gfc_match_char (',') != MATCH_YES
)
6765 gfc_error ("Expected \",\" at %C");
6769 /* Match Pointee. */
6770 var_locus
= gfc_current_locus
;
6771 gfc_clear_attr (¤t_attr
);
6772 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6773 current_ts
.type
= BT_UNKNOWN
;
6774 current_ts
.kind
= 0;
6776 m
= gfc_match_symbol (&cpte
, 0);
6779 gfc_error ("Expected variable name at %C");
6783 /* Check for an optional array spec. */
6784 m
= gfc_match_array_spec (&as
, true, false);
6785 if (m
== MATCH_ERROR
)
6787 gfc_free_array_spec (as
);
6790 else if (m
== MATCH_NO
)
6792 gfc_free_array_spec (as
);
6796 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6799 gfc_set_sym_referenced (cpte
);
6801 if (cpte
->as
== NULL
)
6803 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6804 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6806 else if (as
!= NULL
)
6808 gfc_error ("Duplicate array spec for Cray pointee at %C");
6809 gfc_free_array_spec (as
);
6815 if (cpte
->as
!= NULL
)
6817 /* Fix array spec. */
6818 m
= gfc_mod_pointee_as (cpte
->as
);
6819 if (m
== MATCH_ERROR
)
6823 /* Point the Pointee at the Pointer. */
6824 cpte
->cp_pointer
= cptr
;
6826 if (gfc_match_char (')') != MATCH_YES
)
6828 gfc_error ("Expected \")\" at %C");
6831 m
= gfc_match_char (',');
6833 done
= true; /* Stop searching for more declarations. */
6837 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6838 || gfc_match_eos () != MATCH_YES
)
6840 gfc_error ("Expected %<,%> or end of statement at %C");
6848 gfc_match_external (void)
6851 gfc_clear_attr (¤t_attr
);
6852 current_attr
.external
= 1;
6854 return attr_decl ();
6859 gfc_match_intent (void)
6863 /* This is not allowed within a BLOCK construct! */
6864 if (gfc_current_state () == COMP_BLOCK
)
6866 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6870 intent
= match_intent_spec ();
6871 if (intent
== INTENT_UNKNOWN
)
6874 gfc_clear_attr (¤t_attr
);
6875 current_attr
.intent
= intent
;
6877 return attr_decl ();
6882 gfc_match_intrinsic (void)
6885 gfc_clear_attr (¤t_attr
);
6886 current_attr
.intrinsic
= 1;
6888 return attr_decl ();
6893 gfc_match_optional (void)
6895 /* This is not allowed within a BLOCK construct! */
6896 if (gfc_current_state () == COMP_BLOCK
)
6898 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6902 gfc_clear_attr (¤t_attr
);
6903 current_attr
.optional
= 1;
6905 return attr_decl ();
6910 gfc_match_pointer (void)
6912 gfc_gobble_whitespace ();
6913 if (gfc_peek_ascii_char () == '(')
6915 if (!flag_cray_pointer
)
6917 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6921 return cray_pointer_decl ();
6925 gfc_clear_attr (¤t_attr
);
6926 current_attr
.pointer
= 1;
6928 return attr_decl ();
6934 gfc_match_allocatable (void)
6936 gfc_clear_attr (¤t_attr
);
6937 current_attr
.allocatable
= 1;
6939 return attr_decl ();
6944 gfc_match_codimension (void)
6946 gfc_clear_attr (¤t_attr
);
6947 current_attr
.codimension
= 1;
6949 return attr_decl ();
6954 gfc_match_contiguous (void)
6956 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6959 gfc_clear_attr (¤t_attr
);
6960 current_attr
.contiguous
= 1;
6962 return attr_decl ();
6967 gfc_match_dimension (void)
6969 gfc_clear_attr (¤t_attr
);
6970 current_attr
.dimension
= 1;
6972 return attr_decl ();
6977 gfc_match_target (void)
6979 gfc_clear_attr (¤t_attr
);
6980 current_attr
.target
= 1;
6982 return attr_decl ();
6986 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6990 access_attr_decl (gfc_statement st
)
6992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6993 interface_type type
;
6995 gfc_symbol
*sym
, *dt_sym
;
6996 gfc_intrinsic_op op
;
6999 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7004 m
= gfc_match_generic_spec (&type
, name
, &op
);
7007 if (m
== MATCH_ERROR
)
7012 case INTERFACE_NAMELESS
:
7013 case INTERFACE_ABSTRACT
:
7016 case INTERFACE_GENERIC
:
7017 if (gfc_get_symbol (name
, NULL
, &sym
))
7020 if (!gfc_add_access (&sym
->attr
,
7022 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7026 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7027 && !gfc_add_access (&dt_sym
->attr
,
7029 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7035 case INTERFACE_INTRINSIC_OP
:
7036 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7038 gfc_intrinsic_op other_op
;
7040 gfc_current_ns
->operator_access
[op
] =
7041 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7043 /* Handle the case if there is another op with the same
7044 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7045 other_op
= gfc_equivalent_op (op
);
7047 if (other_op
!= INTRINSIC_NONE
)
7048 gfc_current_ns
->operator_access
[other_op
] =
7049 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7054 gfc_error ("Access specification of the %s operator at %C has "
7055 "already been specified", gfc_op2string (op
));
7061 case INTERFACE_USER_OP
:
7062 uop
= gfc_get_uop (name
);
7064 if (uop
->access
== ACCESS_UNKNOWN
)
7066 uop
->access
= (st
== ST_PUBLIC
)
7067 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7071 gfc_error ("Access specification of the .%s. operator at %C "
7072 "has already been specified", sym
->name
);
7079 if (gfc_match_char (',') == MATCH_NO
)
7083 if (gfc_match_eos () != MATCH_YES
)
7088 gfc_syntax_error (st
);
7096 gfc_match_protected (void)
7101 if (!gfc_current_ns
->proc_name
7102 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7104 gfc_error ("PROTECTED at %C only allowed in specification "
7105 "part of a module");
7110 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7113 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7118 if (gfc_match_eos () == MATCH_YES
)
7123 m
= gfc_match_symbol (&sym
, 0);
7127 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7139 if (gfc_match_eos () == MATCH_YES
)
7141 if (gfc_match_char (',') != MATCH_YES
)
7148 gfc_error ("Syntax error in PROTECTED statement at %C");
7153 /* The PRIVATE statement is a bit weird in that it can be an attribute
7154 declaration, but also works as a standalone statement inside of a
7155 type declaration or a module. */
7158 gfc_match_private (gfc_statement
*st
)
7161 if (gfc_match ("private") != MATCH_YES
)
7164 if (gfc_current_state () != COMP_MODULE
7165 && !(gfc_current_state () == COMP_DERIVED
7166 && gfc_state_stack
->previous
7167 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7168 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7169 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7170 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7172 gfc_error ("PRIVATE statement at %C is only allowed in the "
7173 "specification part of a module");
7177 if (gfc_current_state () == COMP_DERIVED
)
7179 if (gfc_match_eos () == MATCH_YES
)
7185 gfc_syntax_error (ST_PRIVATE
);
7189 if (gfc_match_eos () == MATCH_YES
)
7196 return access_attr_decl (ST_PRIVATE
);
7201 gfc_match_public (gfc_statement
*st
)
7204 if (gfc_match ("public") != MATCH_YES
)
7207 if (gfc_current_state () != COMP_MODULE
)
7209 gfc_error ("PUBLIC statement at %C is only allowed in the "
7210 "specification part of a module");
7214 if (gfc_match_eos () == MATCH_YES
)
7221 return access_attr_decl (ST_PUBLIC
);
7225 /* Workhorse for gfc_match_parameter. */
7235 m
= gfc_match_symbol (&sym
, 0);
7237 gfc_error ("Expected variable name at %C in PARAMETER statement");
7242 if (gfc_match_char ('=') == MATCH_NO
)
7244 gfc_error ("Expected = sign in PARAMETER statement at %C");
7248 m
= gfc_match_init_expr (&init
);
7250 gfc_error ("Expected expression at %C in PARAMETER statement");
7254 if (sym
->ts
.type
== BT_UNKNOWN
7255 && !gfc_set_default_type (sym
, 1, NULL
))
7261 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7262 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7270 gfc_error ("Initializing already initialized variable at %C");
7275 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7276 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7279 gfc_free_expr (init
);
7284 /* Match a parameter statement, with the weird syntax that these have. */
7287 gfc_match_parameter (void)
7291 if (gfc_match_char ('(') == MATCH_NO
)
7300 if (gfc_match (" )%t") == MATCH_YES
)
7303 if (gfc_match_char (',') != MATCH_YES
)
7305 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7315 /* Save statements have a special syntax. */
7318 gfc_match_save (void)
7320 char n
[GFC_MAX_SYMBOL_LEN
+1];
7325 if (gfc_match_eos () == MATCH_YES
)
7327 if (gfc_current_ns
->seen_save
)
7329 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7330 "follows previous SAVE statement"))
7334 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7338 if (gfc_current_ns
->save_all
)
7340 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7341 "blanket SAVE statement"))
7349 m
= gfc_match_symbol (&sym
, 0);
7353 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7354 &gfc_current_locus
))
7365 m
= gfc_match (" / %n /", &n
);
7366 if (m
== MATCH_ERROR
)
7371 c
= gfc_get_common (n
, 0);
7374 gfc_current_ns
->seen_save
= 1;
7377 if (gfc_match_eos () == MATCH_YES
)
7379 if (gfc_match_char (',') != MATCH_YES
)
7386 gfc_error ("Syntax error in SAVE statement at %C");
7392 gfc_match_value (void)
7397 /* This is not allowed within a BLOCK construct! */
7398 if (gfc_current_state () == COMP_BLOCK
)
7400 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7404 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7407 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7412 if (gfc_match_eos () == MATCH_YES
)
7417 m
= gfc_match_symbol (&sym
, 0);
7421 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7433 if (gfc_match_eos () == MATCH_YES
)
7435 if (gfc_match_char (',') != MATCH_YES
)
7442 gfc_error ("Syntax error in VALUE statement at %C");
7448 gfc_match_volatile (void)
7453 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7456 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7461 if (gfc_match_eos () == MATCH_YES
)
7466 /* VOLATILE is special because it can be added to host-associated
7467 symbols locally. Except for coarrays. */
7468 m
= gfc_match_symbol (&sym
, 1);
7472 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7473 for variable in a BLOCK which is defined outside of the BLOCK. */
7474 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7476 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7477 "%C, which is use-/host-associated", sym
->name
);
7480 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7492 if (gfc_match_eos () == MATCH_YES
)
7494 if (gfc_match_char (',') != MATCH_YES
)
7501 gfc_error ("Syntax error in VOLATILE statement at %C");
7507 gfc_match_asynchronous (void)
7512 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7515 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7520 if (gfc_match_eos () == MATCH_YES
)
7525 /* ASYNCHRONOUS is special because it can be added to host-associated
7527 m
= gfc_match_symbol (&sym
, 1);
7531 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7543 if (gfc_match_eos () == MATCH_YES
)
7545 if (gfc_match_char (',') != MATCH_YES
)
7552 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7557 /* Match a module procedure statement in a submodule. */
7560 gfc_match_submod_proc (void)
7562 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7563 gfc_symbol
*sym
, *fsym
;
7565 gfc_formal_arglist
*formal
, *head
, *tail
;
7567 if (gfc_current_state () != COMP_CONTAINS
7568 || !(gfc_state_stack
->previous
7569 && gfc_state_stack
->previous
->state
== COMP_SUBMODULE
))
7572 m
= gfc_match (" module% procedure% %n", name
);
7576 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
7580 if (get_proc_name (name
, &sym
, false))
7583 /* Make sure that the result field is appropriately filled, even though
7584 the result symbol will be replaced later on. */
7585 if (sym
->ts
.interface
->attr
.function
)
7587 if (sym
->ts
.interface
->result
7588 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
7589 sym
->result
= sym
->ts
.interface
->result
;
7594 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7595 the symbol existed before. */
7596 sym
->declared_at
= gfc_current_locus
;
7598 if (!sym
->attr
.module_procedure
)
7601 /* Signal match_end to expect "end procedure". */
7602 sym
->abr_modproc_decl
= 1;
7604 /* Change from IFSRC_IFBODY coming from the interface declaration. */
7605 sym
->attr
.if_source
= IFSRC_DECL
;
7607 gfc_new_block
= sym
;
7609 /* Make a new formal arglist with the symbols in the procedure
7612 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
7614 if (formal
== sym
->formal
)
7615 head
= tail
= gfc_get_formal_arglist ();
7618 tail
->next
= gfc_get_formal_arglist ();
7622 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
7626 gfc_set_sym_referenced (fsym
);
7629 /* The dummy symbols get cleaned up, when the formal_namespace of the
7630 interface declaration is cleared. This allows us to add the
7631 explicit interface as is done for other type of procedure. */
7632 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
7633 &gfc_current_locus
))
7636 if (gfc_match_eos () != MATCH_YES
)
7638 gfc_syntax_error (ST_MODULE_PROC
);
7645 gfc_free_formal_arglist (head
);
7650 /* Match a module procedure statement. Note that we have to modify
7651 symbols in the parent's namespace because the current one was there
7652 to receive symbols that are in an interface's formal argument list. */
7655 gfc_match_modproc (void)
7657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7661 gfc_namespace
*module_ns
;
7662 gfc_interface
*old_interface_head
, *interface
;
7664 if (gfc_state_stack
->state
!= COMP_INTERFACE
7665 || gfc_state_stack
->previous
== NULL
7666 || current_interface
.type
== INTERFACE_NAMELESS
7667 || current_interface
.type
== INTERFACE_ABSTRACT
)
7669 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7674 module_ns
= gfc_current_ns
->parent
;
7675 for (; module_ns
; module_ns
= module_ns
->parent
)
7676 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7677 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7678 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7679 && !module_ns
->proc_name
->attr
.contained
))
7682 if (module_ns
== NULL
)
7685 /* Store the current state of the interface. We will need it if we
7686 end up with a syntax error and need to recover. */
7687 old_interface_head
= gfc_current_interface_head ();
7689 /* Check if the F2008 optional double colon appears. */
7690 gfc_gobble_whitespace ();
7691 old_locus
= gfc_current_locus
;
7692 if (gfc_match ("::") == MATCH_YES
)
7694 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7695 "MODULE PROCEDURE statement at %L", &old_locus
))
7699 gfc_current_locus
= old_locus
;
7704 old_locus
= gfc_current_locus
;
7706 m
= gfc_match_name (name
);
7712 /* Check for syntax error before starting to add symbols to the
7713 current namespace. */
7714 if (gfc_match_eos () == MATCH_YES
)
7717 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7720 /* Now we're sure the syntax is valid, we process this item
7722 if (gfc_get_symbol (name
, module_ns
, &sym
))
7725 if (sym
->attr
.intrinsic
)
7727 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7728 "PROCEDURE", &old_locus
);
7732 if (sym
->attr
.proc
!= PROC_MODULE
7733 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7736 if (!gfc_add_interface (sym
))
7739 sym
->attr
.mod_proc
= 1;
7740 sym
->declared_at
= old_locus
;
7749 /* Restore the previous state of the interface. */
7750 interface
= gfc_current_interface_head ();
7751 gfc_set_current_interface_head (old_interface_head
);
7753 /* Free the new interfaces. */
7754 while (interface
!= old_interface_head
)
7756 gfc_interface
*i
= interface
->next
;
7761 /* And issue a syntax error. */
7762 gfc_syntax_error (ST_MODULE_PROC
);
7767 /* Check a derived type that is being extended. */
7770 check_extended_derived_type (char *name
)
7772 gfc_symbol
*extended
;
7774 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7776 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7780 extended
= gfc_find_dt_in_generic (extended
);
7785 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
7789 if (extended
->attr
.flavor
!= FL_DERIVED
)
7791 gfc_error ("%qs in EXTENDS expression at %C is not a "
7792 "derived type", name
);
7796 if (extended
->attr
.is_bind_c
)
7798 gfc_error ("%qs cannot be extended at %C because it "
7799 "is BIND(C)", extended
->name
);
7803 if (extended
->attr
.sequence
)
7805 gfc_error ("%qs cannot be extended at %C because it "
7806 "is a SEQUENCE type", extended
->name
);
7814 /* Match the optional attribute specifiers for a type declaration.
7815 Return MATCH_ERROR if an error is encountered in one of the handled
7816 attributes (public, private, bind(c)), MATCH_NO if what's found is
7817 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7818 checking on attribute conflicts needs to be done. */
7821 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7823 /* See if the derived type is marked as private. */
7824 if (gfc_match (" , private") == MATCH_YES
)
7826 if (gfc_current_state () != COMP_MODULE
)
7828 gfc_error ("Derived type at %C can only be PRIVATE in the "
7829 "specification part of a module");
7833 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7836 else if (gfc_match (" , public") == MATCH_YES
)
7838 if (gfc_current_state () != COMP_MODULE
)
7840 gfc_error ("Derived type at %C can only be PUBLIC in the "
7841 "specification part of a module");
7845 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7848 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7850 /* If the type is defined to be bind(c) it then needs to make
7851 sure that all fields are interoperable. This will
7852 need to be a semantic check on the finished derived type.
7853 See 15.2.3 (lines 9-12) of F2003 draft. */
7854 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7857 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7859 else if (gfc_match (" , abstract") == MATCH_YES
)
7861 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7864 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7867 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7869 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7875 /* If we get here, something matched. */
7880 /* Match the beginning of a derived type declaration. If a type name
7881 was the result of a function, then it is possible to have a symbol
7882 already to be known as a derived type yet have no components. */
7885 gfc_match_derived_decl (void)
7887 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7888 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7889 symbol_attribute attr
;
7890 gfc_symbol
*sym
, *gensym
;
7891 gfc_symbol
*extended
;
7893 match is_type_attr_spec
= MATCH_NO
;
7894 bool seen_attr
= false;
7895 gfc_interface
*intr
= NULL
, *head
;
7897 if (gfc_current_state () == COMP_DERIVED
)
7902 gfc_clear_attr (&attr
);
7907 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7908 if (is_type_attr_spec
== MATCH_ERROR
)
7910 if (is_type_attr_spec
== MATCH_YES
)
7912 } while (is_type_attr_spec
== MATCH_YES
);
7914 /* Deal with derived type extensions. The extension attribute has
7915 been added to 'attr' but now the parent type must be found and
7918 extended
= check_extended_derived_type (parent
);
7920 if (parent
[0] && !extended
)
7923 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7925 gfc_error ("Expected :: in TYPE definition at %C");
7929 m
= gfc_match (" %n%t", name
);
7933 /* Make sure the name is not the name of an intrinsic type. */
7934 if (gfc_is_intrinsic_typename (name
))
7936 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
7941 if (gfc_get_symbol (name
, NULL
, &gensym
))
7944 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7946 gfc_error ("Derived type name %qs at %C already has a basic type "
7947 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7951 if (!gensym
->attr
.generic
7952 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7955 if (!gensym
->attr
.function
7956 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7959 sym
= gfc_find_dt_in_generic (gensym
);
7961 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7963 gfc_error ("Derived type definition of %qs at %C has already been "
7964 "defined", sym
->name
);
7970 /* Use upper case to save the actual derived-type symbol. */
7971 gfc_get_symbol (gfc_get_string ("%c%s",
7972 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7973 &gensym
->name
[1]), NULL
, &sym
);
7974 sym
->name
= gfc_get_string (gensym
->name
);
7975 head
= gensym
->generic
;
7976 intr
= gfc_get_interface ();
7978 intr
->where
= gfc_current_locus
;
7979 intr
->sym
->declared_at
= gfc_current_locus
;
7981 gensym
->generic
= intr
;
7982 gensym
->attr
.if_source
= IFSRC_DECL
;
7985 /* The symbol may already have the derived attribute without the
7986 components. The ways this can happen is via a function
7987 definition, an INTRINSIC statement or a subtype in another
7988 derived type that is a pointer. The first part of the AND clause
7989 is true if the symbol is not the return value of a function. */
7990 if (sym
->attr
.flavor
!= FL_DERIVED
7991 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
7994 if (attr
.access
!= ACCESS_UNKNOWN
7995 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
7997 else if (sym
->attr
.access
== ACCESS_UNKNOWN
7998 && gensym
->attr
.access
!= ACCESS_UNKNOWN
7999 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8003 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8004 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8005 gensym
->attr
.access
= sym
->attr
.access
;
8007 /* See if the derived type was labeled as bind(c). */
8008 if (attr
.is_bind_c
!= 0)
8009 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8011 /* Construct the f2k_derived namespace if it is not yet there. */
8012 if (!sym
->f2k_derived
)
8013 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8015 if (extended
&& !sym
->components
)
8019 /* Add the extended derived type as the first component. */
8020 gfc_add_component (sym
, parent
, &p
);
8022 gfc_set_sym_referenced (extended
);
8024 p
->ts
.type
= BT_DERIVED
;
8025 p
->ts
.u
.derived
= extended
;
8026 p
->initializer
= gfc_default_initializer (&p
->ts
);
8028 /* Set extension level. */
8029 if (extended
->attr
.extension
== 255)
8031 /* Since the extension field is 8 bit wide, we can only have
8032 up to 255 extension levels. */
8033 gfc_error ("Maximum extension level reached with type %qs at %L",
8034 extended
->name
, &extended
->declared_at
);
8037 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8039 /* Provide the links between the extended type and its extension. */
8040 if (!extended
->f2k_derived
)
8041 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8044 if (!sym
->hash_value
)
8045 /* Set the hash for the compound name for this type. */
8046 sym
->hash_value
= gfc_hash_value (sym
);
8048 /* Take over the ABSTRACT attribute. */
8049 sym
->attr
.abstract
= attr
.abstract
;
8051 gfc_new_block
= sym
;
8057 /* Cray Pointees can be declared as:
8058 pointer (ipt, a (n,m,...,*)) */
8061 gfc_mod_pointee_as (gfc_array_spec
*as
)
8063 as
->cray_pointee
= true; /* This will be useful to know later. */
8064 if (as
->type
== AS_ASSUMED_SIZE
)
8065 as
->cp_was_assumed
= true;
8066 else if (as
->type
== AS_ASSUMED_SHAPE
)
8068 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8075 /* Match the enum definition statement, here we are trying to match
8076 the first line of enum definition statement.
8077 Returns MATCH_YES if match is found. */
8080 gfc_match_enum (void)
8084 m
= gfc_match_eos ();
8088 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8095 /* Returns an initializer whose value is one higher than the value of the
8096 LAST_INITIALIZER argument. If the argument is NULL, the
8097 initializers value will be set to zero. The initializer's kind
8098 will be set to gfc_c_int_kind.
8100 If -fshort-enums is given, the appropriate kind will be selected
8101 later after all enumerators have been parsed. A warning is issued
8102 here if an initializer exceeds gfc_c_int_kind. */
8105 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8108 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8110 mpz_init (result
->value
.integer
);
8112 if (last_initializer
!= NULL
)
8114 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8115 result
->where
= last_initializer
->where
;
8117 if (gfc_check_integer_range (result
->value
.integer
,
8118 gfc_c_int_kind
) != ARITH_OK
)
8120 gfc_error ("Enumerator exceeds the C integer type at %C");
8126 /* Control comes here, if it's the very first enumerator and no
8127 initializer has been given. It will be initialized to zero. */
8128 mpz_set_si (result
->value
.integer
, 0);
8135 /* Match a variable name with an optional initializer. When this
8136 subroutine is called, a variable is expected to be parsed next.
8137 Depending on what is happening at the moment, updates either the
8138 symbol table or the current interface. */
8141 enumerator_decl (void)
8143 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8144 gfc_expr
*initializer
;
8145 gfc_array_spec
*as
= NULL
;
8153 old_locus
= gfc_current_locus
;
8155 /* When we get here, we've just matched a list of attributes and
8156 maybe a type and a double colon. The next thing we expect to see
8157 is the name of the symbol. */
8158 m
= gfc_match_name (name
);
8162 var_locus
= gfc_current_locus
;
8164 /* OK, we've successfully matched the declaration. Now put the
8165 symbol in the current namespace. If we fail to create the symbol,
8167 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8173 /* The double colon must be present in order to have initializers.
8174 Otherwise the statement is ambiguous with an assignment statement. */
8177 if (gfc_match_char ('=') == MATCH_YES
)
8179 m
= gfc_match_init_expr (&initializer
);
8182 gfc_error ("Expected an initialization expression at %C");
8191 /* If we do not have an initializer, the initialization value of the
8192 previous enumerator (stored in last_initializer) is incremented
8193 by 1 and is used to initialize the current enumerator. */
8194 if (initializer
== NULL
)
8195 initializer
= enum_initializer (last_initializer
, old_locus
);
8197 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8199 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8205 /* Store this current initializer, for the next enumerator variable
8206 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8207 use last_initializer below. */
8208 last_initializer
= initializer
;
8209 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8211 /* Maintain enumerator history. */
8212 gfc_find_symbol (name
, NULL
, 0, &sym
);
8213 create_enum_history (sym
, last_initializer
);
8215 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8218 /* Free stuff up and return. */
8219 gfc_free_expr (initializer
);
8225 /* Match the enumerator definition statement. */
8228 gfc_match_enumerator_def (void)
8233 gfc_clear_ts (¤t_ts
);
8235 m
= gfc_match (" enumerator");
8239 m
= gfc_match (" :: ");
8240 if (m
== MATCH_ERROR
)
8243 colon_seen
= (m
== MATCH_YES
);
8245 if (gfc_current_state () != COMP_ENUM
)
8247 gfc_error ("ENUM definition statement expected before %C");
8248 gfc_free_enum_history ();
8252 (¤t_ts
)->type
= BT_INTEGER
;
8253 (¤t_ts
)->kind
= gfc_c_int_kind
;
8255 gfc_clear_attr (¤t_attr
);
8256 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8265 m
= enumerator_decl ();
8266 if (m
== MATCH_ERROR
)
8268 gfc_free_enum_history ();
8274 if (gfc_match_eos () == MATCH_YES
)
8276 if (gfc_match_char (',') != MATCH_YES
)
8280 if (gfc_current_state () == COMP_ENUM
)
8282 gfc_free_enum_history ();
8283 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8288 gfc_free_array_spec (current_as
);
8295 /* Match binding attributes. */
8298 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8300 bool found_passing
= false;
8301 bool seen_ptr
= false;
8302 match m
= MATCH_YES
;
8304 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8305 this case the defaults are in there. */
8306 ba
->access
= ACCESS_UNKNOWN
;
8307 ba
->pass_arg
= NULL
;
8308 ba
->pass_arg_num
= 0;
8310 ba
->non_overridable
= 0;
8314 /* If we find a comma, we believe there are binding attributes. */
8315 m
= gfc_match_char (',');
8321 /* Access specifier. */
8323 m
= gfc_match (" public");
8324 if (m
== MATCH_ERROR
)
8328 if (ba
->access
!= ACCESS_UNKNOWN
)
8330 gfc_error ("Duplicate access-specifier at %C");
8334 ba
->access
= ACCESS_PUBLIC
;
8338 m
= gfc_match (" private");
8339 if (m
== MATCH_ERROR
)
8343 if (ba
->access
!= ACCESS_UNKNOWN
)
8345 gfc_error ("Duplicate access-specifier at %C");
8349 ba
->access
= ACCESS_PRIVATE
;
8353 /* If inside GENERIC, the following is not allowed. */
8358 m
= gfc_match (" nopass");
8359 if (m
== MATCH_ERROR
)
8365 gfc_error ("Binding attributes already specify passing,"
8366 " illegal NOPASS at %C");
8370 found_passing
= true;
8375 /* PASS possibly including argument. */
8376 m
= gfc_match (" pass");
8377 if (m
== MATCH_ERROR
)
8381 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
8385 gfc_error ("Binding attributes already specify passing,"
8386 " illegal PASS at %C");
8390 m
= gfc_match (" ( %n )", arg
);
8391 if (m
== MATCH_ERROR
)
8394 ba
->pass_arg
= gfc_get_string (arg
);
8395 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
8397 found_passing
= true;
8405 m
= gfc_match (" pointer");
8406 if (m
== MATCH_ERROR
)
8412 gfc_error ("Duplicate POINTER attribute at %C");
8422 /* NON_OVERRIDABLE flag. */
8423 m
= gfc_match (" non_overridable");
8424 if (m
== MATCH_ERROR
)
8428 if (ba
->non_overridable
)
8430 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8434 ba
->non_overridable
= 1;
8438 /* DEFERRED flag. */
8439 m
= gfc_match (" deferred");
8440 if (m
== MATCH_ERROR
)
8446 gfc_error ("Duplicate DEFERRED at %C");
8457 /* Nothing matching found. */
8459 gfc_error ("Expected access-specifier at %C");
8461 gfc_error ("Expected binding attribute at %C");
8464 while (gfc_match_char (',') == MATCH_YES
);
8466 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8467 if (ba
->non_overridable
&& ba
->deferred
)
8469 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8476 if (ba
->access
== ACCESS_UNKNOWN
)
8477 ba
->access
= gfc_typebound_default_access
;
8479 if (ppc
&& !seen_ptr
)
8481 gfc_error ("POINTER attribute is required for procedure pointer component"
8493 /* Match a PROCEDURE specific binding inside a derived type. */
8496 match_procedure_in_type (void)
8498 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8499 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8500 char* target
= NULL
, *ifc
= NULL
;
8501 gfc_typebound_proc tb
;
8510 /* Check current state. */
8511 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8512 block
= gfc_state_stack
->previous
->sym
;
8515 /* Try to match PROCEDURE(interface). */
8516 if (gfc_match (" (") == MATCH_YES
)
8518 m
= gfc_match_name (target_buf
);
8519 if (m
== MATCH_ERROR
)
8523 gfc_error ("Interface-name expected after %<(%> at %C");
8527 if (gfc_match (" )") != MATCH_YES
)
8529 gfc_error ("%<)%> expected at %C");
8536 /* Construct the data structure. */
8537 memset (&tb
, 0, sizeof (tb
));
8538 tb
.where
= gfc_current_locus
;
8540 /* Match binding attributes. */
8541 m
= match_binding_attributes (&tb
, false, false);
8542 if (m
== MATCH_ERROR
)
8544 seen_attrs
= (m
== MATCH_YES
);
8546 /* Check that attribute DEFERRED is given if an interface is specified. */
8547 if (tb
.deferred
&& !ifc
)
8549 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8552 if (ifc
&& !tb
.deferred
)
8554 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8558 /* Match the colons. */
8559 m
= gfc_match (" ::");
8560 if (m
== MATCH_ERROR
)
8562 seen_colons
= (m
== MATCH_YES
);
8563 if (seen_attrs
&& !seen_colons
)
8565 gfc_error ("Expected %<::%> after binding-attributes at %C");
8569 /* Match the binding names. */
8572 m
= gfc_match_name (name
);
8573 if (m
== MATCH_ERROR
)
8577 gfc_error ("Expected binding name at %C");
8581 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8584 /* Try to match the '=> target', if it's there. */
8586 m
= gfc_match (" =>");
8587 if (m
== MATCH_ERROR
)
8593 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
8599 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
8604 m
= gfc_match_name (target_buf
);
8605 if (m
== MATCH_ERROR
)
8609 gfc_error ("Expected binding target after %<=>%> at %C");
8612 target
= target_buf
;
8615 /* If no target was found, it has the same name as the binding. */
8619 /* Get the namespace to insert the symbols into. */
8620 ns
= block
->f2k_derived
;
8623 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8624 if (tb
.deferred
&& !block
->attr
.abstract
)
8626 gfc_error ("Type %qs containing DEFERRED binding at %C "
8627 "is not ABSTRACT", block
->name
);
8631 /* See if we already have a binding with this name in the symtree which
8632 would be an error. If a GENERIC already targeted this binding, it may
8633 be already there but then typebound is still NULL. */
8634 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8635 if (stree
&& stree
->n
.tb
)
8637 gfc_error ("There is already a procedure with binding name %qs for "
8638 "the derived type %qs at %C", name
, block
->name
);
8642 /* Insert it and set attributes. */
8646 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8649 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8651 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8654 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8656 if (gfc_match_eos () == MATCH_YES
)
8658 if (gfc_match_char (',') != MATCH_YES
)
8663 gfc_error ("Syntax error in PROCEDURE statement at %C");
8668 /* Match a GENERIC procedure binding inside a derived type. */
8671 gfc_match_generic (void)
8673 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8674 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8676 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8677 gfc_typebound_proc
* tb
;
8679 interface_type op_type
;
8680 gfc_intrinsic_op op
;
8683 /* Check current state. */
8684 if (gfc_current_state () == COMP_DERIVED
)
8686 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8689 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8691 block
= gfc_state_stack
->previous
->sym
;
8692 ns
= block
->f2k_derived
;
8693 gcc_assert (block
&& ns
);
8695 memset (&tbattr
, 0, sizeof (tbattr
));
8696 tbattr
.where
= gfc_current_locus
;
8698 /* See if we get an access-specifier. */
8699 m
= match_binding_attributes (&tbattr
, true, false);
8700 if (m
== MATCH_ERROR
)
8703 /* Now the colons, those are required. */
8704 if (gfc_match (" ::") != MATCH_YES
)
8706 gfc_error ("Expected %<::%> at %C");
8710 /* Match the binding name; depending on type (operator / generic) format
8711 it for future error messages into bind_name. */
8713 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8714 if (m
== MATCH_ERROR
)
8718 gfc_error ("Expected generic name or operator descriptor at %C");
8724 case INTERFACE_GENERIC
:
8725 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8728 case INTERFACE_USER_OP
:
8729 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8732 case INTERFACE_INTRINSIC_OP
:
8733 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8734 gfc_op2string (op
));
8737 case INTERFACE_NAMELESS
:
8738 gfc_error ("Malformed GENERIC statement at %C");
8746 /* Match the required =>. */
8747 if (gfc_match (" =>") != MATCH_YES
)
8749 gfc_error ("Expected %<=>%> at %C");
8753 /* Try to find existing GENERIC binding with this name / for this operator;
8754 if there is something, check that it is another GENERIC and then extend
8755 it rather than building a new node. Otherwise, create it and put it
8756 at the right position. */
8760 case INTERFACE_USER_OP
:
8761 case INTERFACE_GENERIC
:
8763 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8766 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8778 case INTERFACE_INTRINSIC_OP
:
8788 if (!tb
->is_generic
)
8790 gcc_assert (op_type
== INTERFACE_GENERIC
);
8791 gfc_error ("There's already a non-generic procedure with binding name"
8792 " %qs for the derived type %qs at %C",
8793 bind_name
, block
->name
);
8797 if (tb
->access
!= tbattr
.access
)
8799 gfc_error ("Binding at %C must have the same access as already"
8800 " defined binding %qs", bind_name
);
8806 tb
= gfc_get_typebound_proc (NULL
);
8807 tb
->where
= gfc_current_locus
;
8808 tb
->access
= tbattr
.access
;
8810 tb
->u
.generic
= NULL
;
8814 case INTERFACE_GENERIC
:
8815 case INTERFACE_USER_OP
:
8817 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8820 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8828 case INTERFACE_INTRINSIC_OP
:
8837 /* Now, match all following names as specific targets. */
8840 gfc_symtree
* target_st
;
8841 gfc_tbp_generic
* target
;
8843 m
= gfc_match_name (name
);
8844 if (m
== MATCH_ERROR
)
8848 gfc_error ("Expected specific binding name at %C");
8852 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8854 /* See if this is a duplicate specification. */
8855 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8856 if (target_st
== target
->specific_st
)
8858 gfc_error ("%qs already defined as specific binding for the"
8859 " generic %qs at %C", name
, bind_name
);
8863 target
= gfc_get_tbp_generic ();
8864 target
->specific_st
= target_st
;
8865 target
->specific
= NULL
;
8866 target
->next
= tb
->u
.generic
;
8867 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8868 || (op_type
== INTERFACE_INTRINSIC_OP
));
8869 tb
->u
.generic
= target
;
8871 while (gfc_match (" ,") == MATCH_YES
);
8873 /* Here should be the end. */
8874 if (gfc_match_eos () != MATCH_YES
)
8876 gfc_error ("Junk after GENERIC binding at %C");
8887 /* Match a FINAL declaration inside a derived type. */
8890 gfc_match_final_decl (void)
8892 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8895 gfc_namespace
* module_ns
;
8899 if (gfc_current_form
== FORM_FREE
)
8901 char c
= gfc_peek_ascii_char ();
8902 if (!gfc_is_whitespace (c
) && c
!= ':')
8906 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8908 if (gfc_current_form
== FORM_FIXED
)
8911 gfc_error ("FINAL declaration at %C must be inside a derived type "
8912 "CONTAINS section");
8916 block
= gfc_state_stack
->previous
->sym
;
8919 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8920 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8922 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8923 " specification part of a MODULE");
8927 module_ns
= gfc_current_ns
;
8928 gcc_assert (module_ns
);
8929 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8931 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8932 if (gfc_match (" ::") == MATCH_ERROR
)
8935 /* Match the sequence of procedure names. */
8942 if (first
&& gfc_match_eos () == MATCH_YES
)
8944 gfc_error ("Empty FINAL at %C");
8948 m
= gfc_match_name (name
);
8951 gfc_error ("Expected module procedure name at %C");
8954 else if (m
!= MATCH_YES
)
8957 if (gfc_match_eos () == MATCH_YES
)
8959 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8961 gfc_error ("Expected %<,%> at %C");
8965 if (gfc_get_symbol (name
, module_ns
, &sym
))
8967 gfc_error ("Unknown procedure name %qs at %C", name
);
8971 /* Mark the symbol as module procedure. */
8972 if (sym
->attr
.proc
!= PROC_MODULE
8973 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8976 /* Check if we already have this symbol in the list, this is an error. */
8977 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8978 if (f
->proc_sym
== sym
)
8980 gfc_error ("%qs at %C is already defined as FINAL procedure!",
8985 /* Add this symbol to the list of finalizers. */
8986 gcc_assert (block
->f2k_derived
);
8988 f
= XCNEW (gfc_finalizer
);
8990 f
->proc_tree
= NULL
;
8991 f
->where
= gfc_current_locus
;
8992 f
->next
= block
->f2k_derived
->finalizers
;
8993 block
->f2k_derived
->finalizers
= f
;
9003 const ext_attr_t ext_attr_list
[] = {
9004 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9005 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9006 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9007 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9008 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9009 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9010 { NULL
, EXT_ATTR_LAST
, NULL
}
9013 /* Match a !GCC$ ATTRIBUTES statement of the form:
9014 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9015 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9017 TODO: We should support all GCC attributes using the same syntax for
9018 the attribute list, i.e. the list in C
9019 __attributes(( attribute-list ))
9021 !GCC$ ATTRIBUTES attribute-list ::
9022 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9025 As there is absolutely no risk of confusion, we should never return
9028 gfc_match_gcc_attributes (void)
9030 symbol_attribute attr
;
9031 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9036 gfc_clear_attr (&attr
);
9041 if (gfc_match_name (name
) != MATCH_YES
)
9044 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9045 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9048 if (id
== EXT_ATTR_LAST
)
9050 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9054 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9057 gfc_gobble_whitespace ();
9058 ch
= gfc_next_ascii_char ();
9061 /* This is the successful exit condition for the loop. */
9062 if (gfc_next_ascii_char () == ':')
9072 if (gfc_match_eos () == MATCH_YES
)
9077 m
= gfc_match_name (name
);
9081 if (find_special (name
, &sym
, true))
9084 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9086 if (gfc_match_eos () == MATCH_YES
)
9089 if (gfc_match_char (',') != MATCH_YES
)
9096 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");