1 /* Declaration statement matcher
2 Copyright (C) 2002-2013 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 /* Macros to access allocate memory for gfc_data_variable,
32 gfc_data_value and gfc_data. */
33 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
34 #define gfc_get_data_value() XCNEW (gfc_data_value)
35 #define gfc_get_data() XCNEW (gfc_data)
38 static bool set_binding_label (const char **, const char *, int);
41 /* This flag is set if an old-style length selector is matched
42 during a type-declaration statement. */
44 static int old_char_selector
;
46 /* When variables acquire types and attributes from a declaration
47 statement, they get them from the following static variables. The
48 first part of a declaration sets these variables and the second
49 part copies these into symbol structures. */
51 static gfc_typespec current_ts
;
53 static symbol_attribute current_attr
;
54 static gfc_array_spec
*current_as
;
55 static int colon_seen
;
57 /* The current binding label (if any). */
58 static const char* curr_binding_label
;
59 /* Need to know how many identifiers are on the current data declaration
60 line in case we're given the BIND(C) attribute with a NAME= specifier. */
61 static int num_idents_on_line
;
62 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
63 can supply a name if the curr_binding_label is nil and NAME= was not. */
64 static int has_name_equals
= 0;
66 /* Initializer of the previous enumerator. */
68 static gfc_expr
*last_initializer
;
70 /* History of all the enumerators is maintained, so that
71 kind values of all the enumerators could be updated depending
72 upon the maximum initialized value. */
74 typedef struct enumerator_history
77 gfc_expr
*initializer
;
78 struct enumerator_history
*next
;
82 /* Header of enum history chain. */
84 static enumerator_history
*enum_history
= NULL
;
86 /* Pointer of enum history node containing largest initializer. */
88 static enumerator_history
*max_enum
= NULL
;
90 /* gfc_new_block points to the symbol of a newly matched block. */
92 gfc_symbol
*gfc_new_block
;
94 bool gfc_matching_function
;
97 /********************* DATA statement subroutines *********************/
99 static bool in_match_data
= false;
102 gfc_in_match_data (void)
104 return in_match_data
;
108 set_in_match_data (bool set_value
)
110 in_match_data
= set_value
;
113 /* Free a gfc_data_variable structure and everything beneath it. */
116 free_variable (gfc_data_variable
*p
)
118 gfc_data_variable
*q
;
123 gfc_free_expr (p
->expr
);
124 gfc_free_iterator (&p
->iter
, 0);
125 free_variable (p
->list
);
131 /* Free a gfc_data_value structure and everything beneath it. */
134 free_value (gfc_data_value
*p
)
141 mpz_clear (p
->repeat
);
142 gfc_free_expr (p
->expr
);
148 /* Free a list of gfc_data structures. */
151 gfc_free_data (gfc_data
*p
)
158 free_variable (p
->var
);
159 free_value (p
->value
);
165 /* Free all data in a namespace. */
168 gfc_free_data_all (gfc_namespace
*ns
)
181 static match
var_element (gfc_data_variable
*);
183 /* Match a list of variables terminated by an iterator and a right
187 var_list (gfc_data_variable
*parent
)
189 gfc_data_variable
*tail
, var
;
192 m
= var_element (&var
);
193 if (m
== MATCH_ERROR
)
198 tail
= gfc_get_data_variable ();
205 if (gfc_match_char (',') != MATCH_YES
)
208 m
= gfc_match_iterator (&parent
->iter
, 1);
211 if (m
== MATCH_ERROR
)
214 m
= var_element (&var
);
215 if (m
== MATCH_ERROR
)
220 tail
->next
= gfc_get_data_variable ();
226 if (gfc_match_char (')') != MATCH_YES
)
231 gfc_syntax_error (ST_DATA
);
236 /* Match a single element in a data variable list, which can be a
237 variable-iterator list. */
240 var_element (gfc_data_variable
*new_var
)
245 memset (new_var
, 0, sizeof (gfc_data_variable
));
247 if (gfc_match_char ('(') == MATCH_YES
)
248 return var_list (new_var
);
250 m
= gfc_match_variable (&new_var
->expr
, 0);
254 sym
= new_var
->expr
->symtree
->n
.sym
;
256 /* Symbol should already have an associated type. */
257 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
260 if (!sym
->attr
.function
&& gfc_current_ns
->parent
261 && gfc_current_ns
->parent
== sym
->ns
)
263 gfc_error ("Host associated variable '%s' may not be in the DATA "
264 "statement at %C", sym
->name
);
268 if (gfc_current_state () != COMP_BLOCK_DATA
269 && sym
->attr
.in_common
270 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
271 "common block variable '%s' in DATA statement at %C",
275 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
282 /* Match the top-level list of data variables. */
285 top_var_list (gfc_data
*d
)
287 gfc_data_variable var
, *tail
, *new_var
;
294 m
= var_element (&var
);
297 if (m
== MATCH_ERROR
)
300 new_var
= gfc_get_data_variable ();
306 tail
->next
= new_var
;
310 if (gfc_match_char ('/') == MATCH_YES
)
312 if (gfc_match_char (',') != MATCH_YES
)
319 gfc_syntax_error (ST_DATA
);
320 gfc_free_data_all (gfc_current_ns
);
326 match_data_constant (gfc_expr
**result
)
328 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
329 gfc_symbol
*sym
, *dt_sym
= NULL
;
334 m
= gfc_match_literal_constant (&expr
, 1);
341 if (m
== MATCH_ERROR
)
344 m
= gfc_match_null (result
);
348 old_loc
= gfc_current_locus
;
350 /* Should this be a structure component, try to match it
351 before matching a name. */
352 m
= gfc_match_rvalue (result
);
353 if (m
== MATCH_ERROR
)
356 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
358 if (!gfc_simplify_expr (*result
, 0))
362 else if (m
== MATCH_YES
)
363 gfc_free_expr (*result
);
365 gfc_current_locus
= old_loc
;
367 m
= gfc_match_name (name
);
371 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
374 if (sym
&& sym
->attr
.generic
)
375 dt_sym
= gfc_find_dt_in_generic (sym
);
378 || (sym
->attr
.flavor
!= FL_PARAMETER
379 && (!dt_sym
|| dt_sym
->attr
.flavor
!= FL_DERIVED
)))
381 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
385 else if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
)
386 return gfc_match_structure_constructor (dt_sym
, result
);
388 /* Check to see if the value is an initialization array expression. */
389 if (sym
->value
->expr_type
== EXPR_ARRAY
)
391 gfc_current_locus
= old_loc
;
393 m
= gfc_match_init_expr (result
);
394 if (m
== MATCH_ERROR
)
399 if (!gfc_simplify_expr (*result
, 0))
402 if ((*result
)->expr_type
== EXPR_CONSTANT
)
406 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
412 *result
= gfc_copy_expr (sym
->value
);
417 /* Match a list of values in a DATA statement. The leading '/' has
418 already been seen at this point. */
421 top_val_list (gfc_data
*data
)
423 gfc_data_value
*new_val
, *tail
;
431 m
= match_data_constant (&expr
);
434 if (m
== MATCH_ERROR
)
437 new_val
= gfc_get_data_value ();
438 mpz_init (new_val
->repeat
);
441 data
->value
= new_val
;
443 tail
->next
= new_val
;
447 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
450 mpz_set_ui (tail
->repeat
, 1);
454 mpz_set (tail
->repeat
, expr
->value
.integer
);
455 gfc_free_expr (expr
);
457 m
= match_data_constant (&tail
->expr
);
460 if (m
== MATCH_ERROR
)
464 if (gfc_match_char ('/') == MATCH_YES
)
466 if (gfc_match_char (',') == MATCH_NO
)
473 gfc_syntax_error (ST_DATA
);
474 gfc_free_data_all (gfc_current_ns
);
479 /* Matches an old style initialization. */
482 match_old_style_init (const char *name
)
489 /* Set up data structure to hold initializers. */
490 gfc_find_sym_tree (name
, NULL
, 0, &st
);
493 newdata
= gfc_get_data ();
494 newdata
->var
= gfc_get_data_variable ();
495 newdata
->var
->expr
= gfc_get_variable_expr (st
);
496 newdata
->where
= gfc_current_locus
;
498 /* Match initial value list. This also eats the terminal '/'. */
499 m
= top_val_list (newdata
);
508 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
513 if (gfc_implicit_pure (NULL
))
514 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
516 /* Mark the variable as having appeared in a data statement. */
517 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
523 /* Chain in namespace list of DATA initializers. */
524 newdata
->next
= gfc_current_ns
->data
;
525 gfc_current_ns
->data
= newdata
;
531 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
532 we are matching a DATA statement and are therefore issuing an error
533 if we encounter something unexpected, if not, we're trying to match
534 an old-style initialization expression of the form INTEGER I /2/. */
537 gfc_match_data (void)
542 set_in_match_data (true);
546 new_data
= gfc_get_data ();
547 new_data
->where
= gfc_current_locus
;
549 m
= top_var_list (new_data
);
553 m
= top_val_list (new_data
);
557 new_data
->next
= gfc_current_ns
->data
;
558 gfc_current_ns
->data
= new_data
;
560 if (gfc_match_eos () == MATCH_YES
)
563 gfc_match_char (','); /* Optional comma */
566 set_in_match_data (false);
570 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
574 if (gfc_implicit_pure (NULL
))
575 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
580 set_in_match_data (false);
581 gfc_free_data (new_data
);
586 /************************ Declaration statements *********************/
589 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
592 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
596 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
597 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
599 gfc_error ("The assumed-rank array at %C shall not have a codimension");
603 if (to
->rank
== 0 && from
->rank
> 0)
605 to
->rank
= from
->rank
;
606 to
->type
= from
->type
;
607 to
->cray_pointee
= from
->cray_pointee
;
608 to
->cp_was_assumed
= from
->cp_was_assumed
;
610 for (i
= 0; i
< to
->corank
; i
++)
612 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
613 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
615 for (i
= 0; i
< from
->rank
; i
++)
619 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
620 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
624 to
->lower
[i
] = from
->lower
[i
];
625 to
->upper
[i
] = from
->upper
[i
];
629 else if (to
->corank
== 0 && from
->corank
> 0)
631 to
->corank
= from
->corank
;
632 to
->cotype
= from
->cotype
;
634 for (i
= 0; i
< from
->corank
; i
++)
638 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
639 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
643 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
644 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
653 /* Match an intent specification. Since this can only happen after an
654 INTENT word, a legal intent-spec must follow. */
657 match_intent_spec (void)
660 if (gfc_match (" ( in out )") == MATCH_YES
)
662 if (gfc_match (" ( in )") == MATCH_YES
)
664 if (gfc_match (" ( out )") == MATCH_YES
)
667 gfc_error ("Bad INTENT specification at %C");
668 return INTENT_UNKNOWN
;
672 /* Matches a character length specification, which is either a
673 specification expression, '*', or ':'. */
676 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
683 if (gfc_match_char ('*') == MATCH_YES
)
686 if (gfc_match_char (':') == MATCH_YES
)
688 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type "
697 m
= gfc_match_expr (expr
);
700 && !gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
703 if (m
== MATCH_YES
&& (*expr
)->expr_type
== EXPR_FUNCTION
)
705 if ((*expr
)->value
.function
.actual
706 && (*expr
)->value
.function
.actual
->expr
->symtree
)
709 e
= (*expr
)->value
.function
.actual
->expr
;
710 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
711 && e
->expr_type
== EXPR_VARIABLE
)
713 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
715 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
716 && e
->symtree
->n
.sym
->ts
.u
.cl
717 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->ts
.type
== BT_UNKNOWN
)
725 gfc_error ("Conflict in attributes of function argument at %C");
730 /* A character length is a '*' followed by a literal integer or a
731 char_len_param_value in parenthesis. */
734 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
740 m
= gfc_match_char ('*');
744 m
= gfc_match_small_literal_int (&length
, NULL
);
745 if (m
== MATCH_ERROR
)
750 if (obsolescent_check
751 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
753 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
757 if (gfc_match_char ('(') == MATCH_NO
)
760 m
= char_len_param_value (expr
, deferred
);
761 if (m
!= MATCH_YES
&& gfc_matching_function
)
767 if (m
== MATCH_ERROR
)
772 if (gfc_match_char (')') == MATCH_NO
)
774 gfc_free_expr (*expr
);
782 gfc_error ("Syntax error in character length specification at %C");
787 /* Special subroutine for finding a symbol. Check if the name is found
788 in the current name space. If not, and we're compiling a function or
789 subroutine and the parent compilation unit is an interface, then check
790 to see if the name we've been given is the name of the interface
791 (located in another namespace). */
794 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
800 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
803 *result
= st
? st
->n
.sym
: NULL
;
807 if (gfc_current_state () != COMP_SUBROUTINE
808 && gfc_current_state () != COMP_FUNCTION
)
811 s
= gfc_state_stack
->previous
;
815 if (s
->state
!= COMP_INTERFACE
)
818 goto end
; /* Nameless interface. */
820 if (strcmp (name
, s
->sym
->name
) == 0)
831 /* Special subroutine for getting a symbol node associated with a
832 procedure name, used in SUBROUTINE and FUNCTION statements. The
833 symbol is created in the parent using with symtree node in the
834 child unit pointing to the symbol. If the current namespace has no
835 parent, then the symbol is just created in the current unit. */
838 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
844 /* Module functions have to be left in their own namespace because
845 they have potentially (almost certainly!) already been referenced.
846 In this sense, they are rather like external functions. This is
847 fixed up in resolve.c(resolve_entries), where the symbol name-
848 space is set to point to the master function, so that the fake
849 result mechanism can work. */
850 if (module_fcn_entry
)
852 /* Present if entry is declared to be a module procedure. */
853 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
856 rc
= gfc_get_symbol (name
, NULL
, result
);
857 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
858 && (*result
)->ts
.type
== BT_UNKNOWN
859 && sym
->attr
.flavor
== FL_UNKNOWN
)
860 /* Pick up the typespec for the entry, if declared in the function
861 body. Note that this symbol is FL_UNKNOWN because it will
862 only have appeared in a type declaration. The local symtree
863 is set to point to the module symbol and a unique symtree
864 to the local version. This latter ensures a correct clearing
867 /* If the ENTRY proceeds its specification, we need to ensure
868 that this does not raise a "has no IMPLICIT type" error. */
869 if (sym
->ts
.type
== BT_UNKNOWN
)
870 sym
->attr
.untyped
= 1;
872 (*result
)->ts
= sym
->ts
;
874 /* Put the symbol in the procedure namespace so that, should
875 the ENTRY precede its specification, the specification
877 (*result
)->ns
= gfc_current_ns
;
879 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
881 st
= gfc_get_unique_symtree (gfc_current_ns
);
886 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
893 if (sym
&& !sym
->gfc_new
&& gfc_current_state () != COMP_INTERFACE
)
895 /* Trap another encompassed procedure with the same name. All
896 these conditions are necessary to avoid picking up an entry
897 whose name clashes with that of the encompassing procedure;
898 this is handled using gsymbols to register unique,globally
900 if (sym
->attr
.flavor
!= 0
901 && sym
->attr
.proc
!= 0
902 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
903 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
904 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
905 name
, &sym
->declared_at
);
907 /* Trap a procedure with a name the same as interface in the
908 encompassing scope. */
909 if (sym
->attr
.generic
!= 0
910 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
911 && !sym
->attr
.mod_proc
)
912 gfc_error_now ("Name '%s' at %C is already defined"
913 " as a generic interface at %L",
914 name
, &sym
->declared_at
);
916 /* Trap declarations of attributes in encompassing scope. The
917 signature for this is that ts.kind is set. Legitimate
918 references only set ts.type. */
919 if (sym
->ts
.kind
!= 0
920 && !sym
->attr
.implicit_type
921 && sym
->attr
.proc
== 0
922 && gfc_current_ns
->parent
!= NULL
923 && sym
->attr
.access
== 0
924 && !module_fcn_entry
)
925 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
926 "and must not have attributes declared at %L",
927 name
, &sym
->declared_at
);
930 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
933 /* Module function entries will already have a symtree in
934 the current namespace but will need one at module level. */
935 if (module_fcn_entry
)
937 /* Present if entry is declared to be a module procedure. */
938 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
940 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
943 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
948 /* See if the procedure should be a module procedure. */
950 if (((sym
->ns
->proc_name
!= NULL
951 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
952 && sym
->attr
.proc
!= PROC_MODULE
)
953 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
954 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
961 /* Verify that the given symbol representing a parameter is C
962 interoperable, by checking to see if it was marked as such after
963 its declaration. If the given symbol is not interoperable, a
964 warning is reported, thus removing the need to return the status to
965 the calling function. The standard does not require the user use
966 one of the iso_c_binding named constants to declare an
967 interoperable parameter, but we can't be sure if the param is C
968 interop or not if the user doesn't. For example, integer(4) may be
969 legal Fortran, but doesn't have meaning in C. It may interop with
970 a number of the C types, which causes a problem because the
971 compiler can't know which one. This code is almost certainly not
972 portable, and the user will get what they deserve if the C type
973 across platforms isn't always interoperable with integer(4). If
974 the user had used something like integer(c_int) or integer(c_long),
975 the compiler could have automatically handled the varying sizes
979 gfc_verify_c_interop_param (gfc_symbol
*sym
)
981 int is_c_interop
= 0;
984 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
985 Don't repeat the checks here. */
986 if (sym
->attr
.implicit_type
)
989 /* For subroutines or functions that are passed to a BIND(C) procedure,
990 they're interoperable if they're BIND(C) and their params are all
992 if (sym
->attr
.flavor
== FL_PROCEDURE
)
994 if (sym
->attr
.is_bind_c
== 0)
996 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
997 "attribute to be C interoperable", sym
->name
,
998 &(sym
->declared_at
));
1004 if (sym
->attr
.is_c_interop
== 1)
1005 /* We've already checked this procedure; don't check it again. */
1008 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1013 /* See if we've stored a reference to a procedure that owns sym. */
1014 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1016 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1018 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1020 if (is_c_interop
!= 1)
1022 /* Make personalized messages to give better feedback. */
1023 if (sym
->ts
.type
== BT_DERIVED
)
1024 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1025 "BIND(C) procedure '%s' but is not C interoperable "
1026 "because derived type '%s' is not C interoperable",
1027 sym
->name
, &(sym
->declared_at
),
1028 sym
->ns
->proc_name
->name
,
1029 sym
->ts
.u
.derived
->name
);
1030 else if (sym
->ts
.type
== BT_CLASS
)
1031 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1032 "BIND(C) procedure '%s' but is not C interoperable "
1033 "because it is polymorphic",
1034 sym
->name
, &(sym
->declared_at
),
1035 sym
->ns
->proc_name
->name
);
1036 else if (gfc_option
.warn_c_binding_type
)
1037 gfc_warning ("Variable '%s' at %L is a dummy argument of the "
1038 "BIND(C) procedure '%s' but may not be C "
1040 sym
->name
, &(sym
->declared_at
),
1041 sym
->ns
->proc_name
->name
);
1044 /* Character strings are only C interoperable if they have a
1046 if (sym
->ts
.type
== BT_CHARACTER
)
1048 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1049 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1050 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1052 gfc_error ("Character argument '%s' at %L "
1053 "must be length 1 because "
1054 "procedure '%s' is BIND(C)",
1055 sym
->name
, &sym
->declared_at
,
1056 sym
->ns
->proc_name
->name
);
1061 /* We have to make sure that any param to a bind(c) routine does
1062 not have the allocatable, pointer, or optional attributes,
1063 according to J3/04-007, section 5.1. */
1064 if (sym
->attr
.allocatable
== 1)
1066 gfc_error ("Variable '%s' at %L cannot have the "
1067 "ALLOCATABLE attribute because procedure '%s'"
1068 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
1069 sym
->ns
->proc_name
->name
);
1073 if (sym
->attr
.pointer
== 1)
1075 gfc_error ("Variable '%s' at %L cannot have the "
1076 "POINTER attribute because procedure '%s'"
1077 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
1078 sym
->ns
->proc_name
->name
);
1082 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1084 gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
1085 "and the VALUE attribute because procedure '%s' "
1086 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1087 sym
->ns
->proc_name
->name
);
1090 else if (sym
->attr
.optional
== 1
1091 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable '%s' "
1092 "at %L with OPTIONAL attribute in "
1093 "procedure '%s' which is BIND(C)",
1094 sym
->name
, &(sym
->declared_at
),
1095 sym
->ns
->proc_name
->name
))
1098 /* Make sure that if it has the dimension attribute, that it is
1099 either assumed size or explicit shape. Deferred shape is already
1100 covered by the pointer/allocatable attribute. */
1101 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1102 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array '%s' "
1103 "at %L as dummy argument to the BIND(C) "
1104 "procedure '%s' at %L", sym
->name
,
1105 &(sym
->declared_at
),
1106 sym
->ns
->proc_name
->name
,
1107 &(sym
->ns
->proc_name
->declared_at
)))
1117 /* Function called by variable_decl() that adds a name to the symbol table. */
1120 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1121 gfc_array_spec
**as
, locus
*var_locus
)
1123 symbol_attribute attr
;
1126 if (gfc_get_symbol (name
, NULL
, &sym
))
1129 /* Start updating the symbol table. Add basic type attribute if present. */
1130 if (current_ts
.type
!= BT_UNKNOWN
1131 && (sym
->attr
.implicit_type
== 0
1132 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1133 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1136 if (sym
->ts
.type
== BT_CHARACTER
)
1139 sym
->ts
.deferred
= cl_deferred
;
1142 /* Add dimension attribute if present. */
1143 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1147 /* Add attribute to symbol. The copy is so that we can reset the
1148 dimension attribute. */
1149 attr
= current_attr
;
1151 attr
.codimension
= 0;
1153 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1156 /* Finish any work that may need to be done for the binding label,
1157 if it's a bind(c). The bind(c) attr is found before the symbol
1158 is made, and before the symbol name (for data decls), so the
1159 current_ts is holding the binding label, or nothing if the
1160 name= attr wasn't given. Therefore, test here if we're dealing
1161 with a bind(c) and make sure the binding label is set correctly. */
1162 if (sym
->attr
.is_bind_c
== 1)
1164 if (!sym
->binding_label
)
1166 /* Set the binding label and verify that if a NAME= was specified
1167 then only one identifier was in the entity-decl-list. */
1168 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1169 num_idents_on_line
))
1174 /* See if we know we're in a common block, and if it's a bind(c)
1175 common then we need to make sure we're an interoperable type. */
1176 if (sym
->attr
.in_common
== 1)
1178 /* Test the common block object. */
1179 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1180 && sym
->ts
.is_c_interop
!= 1)
1182 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1183 "must be declared with a C interoperable "
1184 "kind since common block '%s' is BIND(C)",
1185 sym
->name
, sym
->common_block
->name
,
1186 sym
->common_block
->name
);
1191 sym
->attr
.implied_index
= 0;
1193 if (sym
->ts
.type
== BT_CLASS
)
1194 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
, false);
1200 /* Set character constant to the given length. The constant will be padded or
1201 truncated. If we're inside an array constructor without a typespec, we
1202 additionally check that all elements have the same length; check_len -1
1203 means no checking. */
1206 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1211 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1212 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1214 slen
= expr
->value
.character
.length
;
1217 s
= gfc_get_wide_string (len
+ 1);
1218 memcpy (s
, expr
->value
.character
.string
,
1219 MIN (len
, slen
) * sizeof (gfc_char_t
));
1221 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1223 if (gfc_option
.warn_character_truncation
&& slen
> len
)
1224 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1225 "(%d/%d)", &expr
->where
, slen
, len
);
1227 /* Apply the standard by 'hand' otherwise it gets cleared for
1229 if (check_len
!= -1 && slen
!= check_len
1230 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1231 gfc_error_now ("The CHARACTER elements of the array constructor "
1232 "at %L must have the same length (%d/%d)",
1233 &expr
->where
, slen
, check_len
);
1236 free (expr
->value
.character
.string
);
1237 expr
->value
.character
.string
= s
;
1238 expr
->value
.character
.length
= len
;
1243 /* Function to create and update the enumerator history
1244 using the information passed as arguments.
1245 Pointer "max_enum" is also updated, to point to
1246 enum history node containing largest initializer.
1248 SYM points to the symbol node of enumerator.
1249 INIT points to its enumerator value. */
1252 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1254 enumerator_history
*new_enum_history
;
1255 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1257 new_enum_history
= XCNEW (enumerator_history
);
1259 new_enum_history
->sym
= sym
;
1260 new_enum_history
->initializer
= init
;
1261 new_enum_history
->next
= NULL
;
1263 if (enum_history
== NULL
)
1265 enum_history
= new_enum_history
;
1266 max_enum
= enum_history
;
1270 new_enum_history
->next
= enum_history
;
1271 enum_history
= new_enum_history
;
1273 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1274 new_enum_history
->initializer
->value
.integer
) < 0)
1275 max_enum
= new_enum_history
;
1280 /* Function to free enum kind history. */
1283 gfc_free_enum_history (void)
1285 enumerator_history
*current
= enum_history
;
1286 enumerator_history
*next
;
1288 while (current
!= NULL
)
1290 next
= current
->next
;
1295 enum_history
= NULL
;
1299 /* Function called by variable_decl() that adds an initialization
1300 expression to a symbol. */
1303 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1305 symbol_attribute attr
;
1310 if (find_special (name
, &sym
, false))
1315 /* If this symbol is confirming an implicit parameter type,
1316 then an initialization expression is not allowed. */
1317 if (attr
.flavor
== FL_PARAMETER
1318 && sym
->value
!= NULL
1321 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1328 /* An initializer is required for PARAMETER declarations. */
1329 if (attr
.flavor
== FL_PARAMETER
)
1331 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1337 /* If a variable appears in a DATA block, it cannot have an
1341 gfc_error ("Variable '%s' at %C with an initializer already "
1342 "appears in a DATA statement", sym
->name
);
1346 /* Check if the assignment can happen. This has to be put off
1347 until later for derived type variables and procedure pointers. */
1348 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1349 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1350 && !sym
->attr
.proc_pointer
1351 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1354 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1355 && init
->ts
.type
== BT_CHARACTER
)
1357 /* Update symbol character length according initializer. */
1358 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1361 if (sym
->ts
.u
.cl
->length
== NULL
)
1364 /* If there are multiple CHARACTER variables declared on the
1365 same line, we don't want them to share the same length. */
1366 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1368 if (sym
->attr
.flavor
== FL_PARAMETER
)
1370 if (init
->expr_type
== EXPR_CONSTANT
)
1372 clen
= init
->value
.character
.length
;
1373 sym
->ts
.u
.cl
->length
1374 = gfc_get_int_expr (gfc_default_integer_kind
,
1377 else if (init
->expr_type
== EXPR_ARRAY
)
1380 c
= gfc_constructor_first (init
->value
.constructor
);
1381 clen
= c
->expr
->value
.character
.length
;
1382 sym
->ts
.u
.cl
->length
1383 = gfc_get_int_expr (gfc_default_integer_kind
,
1386 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1387 sym
->ts
.u
.cl
->length
=
1388 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1391 /* Update initializer character length according symbol. */
1392 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1394 int len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1396 if (init
->expr_type
== EXPR_CONSTANT
)
1397 gfc_set_constant_character_len (len
, init
, -1);
1398 else if (init
->expr_type
== EXPR_ARRAY
)
1402 /* Build a new charlen to prevent simplification from
1403 deleting the length before it is resolved. */
1404 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1405 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1407 for (c
= gfc_constructor_first (init
->value
.constructor
);
1408 c
; c
= gfc_constructor_next (c
))
1409 gfc_set_constant_character_len (len
, c
->expr
, -1);
1414 /* If sym is implied-shape, set its upper bounds from init. */
1415 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1416 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1420 if (init
->rank
== 0)
1422 gfc_error ("Can't initialize implied-shape array at %L"
1423 " with scalar", &sym
->declared_at
);
1426 gcc_assert (sym
->as
->rank
== init
->rank
);
1428 /* Shape should be present, we get an initialization expression. */
1429 gcc_assert (init
->shape
);
1431 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1437 lower
= sym
->as
->lower
[dim
];
1438 if (lower
->expr_type
!= EXPR_CONSTANT
)
1440 gfc_error ("Non-constant lower bound in implied-shape"
1441 " declaration at %L", &lower
->where
);
1445 /* All dimensions must be without upper bound. */
1446 gcc_assert (!sym
->as
->upper
[dim
]);
1449 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1450 mpz_add (e
->value
.integer
,
1451 lower
->value
.integer
, init
->shape
[dim
]);
1452 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1453 sym
->as
->upper
[dim
] = e
;
1456 sym
->as
->type
= AS_EXPLICIT
;
1459 /* Need to check if the expression we initialized this
1460 to was one of the iso_c_binding named constants. If so,
1461 and we're a parameter (constant), let it be iso_c.
1463 integer(c_int), parameter :: my_int = c_int
1464 integer(my_int) :: my_int_2
1465 If we mark my_int as iso_c (since we can see it's value
1466 is equal to one of the named constants), then my_int_2
1467 will be considered C interoperable. */
1468 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1470 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1471 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1472 /* attr bits needed for module files. */
1473 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1474 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1475 if (init
->ts
.is_iso_c
)
1476 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1479 /* Add initializer. Make sure we keep the ranks sane. */
1480 if (sym
->attr
.dimension
&& init
->rank
== 0)
1485 if (sym
->attr
.flavor
== FL_PARAMETER
1486 && init
->expr_type
== EXPR_CONSTANT
1487 && spec_size (sym
->as
, &size
)
1488 && mpz_cmp_si (size
, 0) > 0)
1490 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1492 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1493 gfc_constructor_append_expr (&array
->value
.constructor
,
1496 : gfc_copy_expr (init
),
1499 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1500 for (n
= 0; n
< sym
->as
->rank
; n
++)
1501 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1506 init
->rank
= sym
->as
->rank
;
1510 if (sym
->attr
.save
== SAVE_NONE
)
1511 sym
->attr
.save
= SAVE_IMPLICIT
;
1519 /* Function called by variable_decl() that adds a name to a structure
1523 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1524 gfc_array_spec
**as
)
1529 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1530 constructing, it must have the pointer attribute. */
1531 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1532 && current_ts
.u
.derived
== gfc_current_block ()
1533 && current_attr
.pointer
== 0)
1535 gfc_error ("Component at %C must have the POINTER attribute");
1539 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1541 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1543 gfc_error ("Array component of structure at %C must have explicit "
1544 "or deferred shape");
1549 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1553 if (c
->ts
.type
== BT_CHARACTER
)
1555 c
->attr
= current_attr
;
1557 c
->initializer
= *init
;
1564 c
->attr
.codimension
= 1;
1566 c
->attr
.dimension
= 1;
1570 /* Should this ever get more complicated, combine with similar section
1571 in add_init_expr_to_sym into a separate function. */
1572 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1574 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1578 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1579 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1580 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1582 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1584 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1585 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1586 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1587 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1589 gfc_constructor
*ctor
;
1590 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1595 bool has_ts
= (c
->initializer
->ts
.u
.cl
1596 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1598 /* Remember the length of the first element for checking
1599 that all elements *in the constructor* have the same
1600 length. This need not be the length of the LHS! */
1601 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1602 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1603 first_len
= ctor
->expr
->value
.character
.length
;
1605 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1606 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1608 gfc_set_constant_character_len (len
, ctor
->expr
,
1609 has_ts
? -1 : first_len
);
1610 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1616 /* Check array components. */
1617 if (!c
->attr
.dimension
)
1620 if (c
->attr
.pointer
)
1622 if (c
->as
->type
!= AS_DEFERRED
)
1624 gfc_error ("Pointer array component of structure at %C must have a "
1629 else if (c
->attr
.allocatable
)
1631 if (c
->as
->type
!= AS_DEFERRED
)
1633 gfc_error ("Allocatable component of structure at %C must have a "
1640 if (c
->as
->type
!= AS_EXPLICIT
)
1642 gfc_error ("Array component of structure at %C must have an "
1649 if (c
->ts
.type
== BT_CLASS
)
1651 bool delayed
= (gfc_state_stack
->sym
== c
->ts
.u
.derived
)
1652 || (!c
->ts
.u
.derived
->components
1653 && !c
->ts
.u
.derived
->attr
.zero_comp
);
1654 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
, delayed
);
1664 /* Match a 'NULL()', and possibly take care of some side effects. */
1667 gfc_match_null (gfc_expr
**result
)
1670 match m
, m2
= MATCH_NO
;
1672 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
1678 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1680 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
1683 old_loc
= gfc_current_locus
;
1684 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
1687 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
1691 gfc_current_locus
= old_loc
;
1696 /* The NULL symbol now has to be/become an intrinsic function. */
1697 if (gfc_get_symbol ("null", NULL
, &sym
))
1699 gfc_error ("NULL() initialization at %C is ambiguous");
1703 gfc_intrinsic_symbol (sym
);
1705 if (sym
->attr
.proc
!= PROC_INTRINSIC
1706 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
1707 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
1710 *result
= gfc_get_null_expr (&gfc_current_locus
);
1712 /* Invalid per F2008, C512. */
1713 if (m2
== MATCH_YES
)
1715 gfc_error ("NULL() initialization at %C may not have MOLD");
1723 /* Match the initialization expr for a data pointer or procedure pointer. */
1726 match_pointer_init (gfc_expr
**init
, int procptr
)
1730 if (gfc_pure (NULL
) && gfc_state_stack
->state
!= COMP_DERIVED
)
1732 gfc_error ("Initialization of pointer at %C is not allowed in "
1733 "a PURE procedure");
1737 /* Match NULL() initialization. */
1738 m
= gfc_match_null (init
);
1742 /* Match non-NULL initialization. */
1743 gfc_matching_ptr_assignment
= !procptr
;
1744 gfc_matching_procptr_assignment
= procptr
;
1745 m
= gfc_match_rvalue (init
);
1746 gfc_matching_ptr_assignment
= 0;
1747 gfc_matching_procptr_assignment
= 0;
1748 if (m
== MATCH_ERROR
)
1750 else if (m
== MATCH_NO
)
1752 gfc_error ("Error in pointer initialization at %C");
1757 gfc_resolve_expr (*init
);
1759 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
1760 "initialization at %C"))
1768 check_function_name (char *name
)
1770 /* In functions that have a RESULT variable defined, the function name always
1771 refers to function calls. Therefore, the name is not allowed to appear in
1772 specification statements. When checking this, be careful about
1773 'hidden' procedure pointer results ('ppr@'). */
1775 if (gfc_current_state () == COMP_FUNCTION
)
1777 gfc_symbol
*block
= gfc_current_block ();
1778 if (block
&& block
->result
&& block
->result
!= block
1779 && strcmp (block
->result
->name
, "ppr@") != 0
1780 && strcmp (block
->name
, name
) == 0)
1782 gfc_error ("Function name '%s' not allowed at %C", name
);
1791 /* Match a variable name with an optional initializer. When this
1792 subroutine is called, a variable is expected to be parsed next.
1793 Depending on what is happening at the moment, updates either the
1794 symbol table or the current interface. */
1797 variable_decl (int elem
)
1799 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1800 gfc_expr
*initializer
, *char_len
;
1802 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1814 /* When we get here, we've just matched a list of attributes and
1815 maybe a type and a double colon. The next thing we expect to see
1816 is the name of the symbol. */
1817 m
= gfc_match_name (name
);
1821 var_locus
= gfc_current_locus
;
1823 /* Now we could see the optional array spec. or character length. */
1824 m
= gfc_match_array_spec (&as
, true, true);
1825 if (m
== MATCH_ERROR
)
1829 as
= gfc_copy_array_spec (current_as
);
1831 && !merge_array_spec (current_as
, as
, true))
1837 if (gfc_option
.flag_cray_pointer
)
1838 cp_as
= gfc_copy_array_spec (as
);
1840 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1841 determine (and check) whether it can be implied-shape. If it
1842 was parsed as assumed-size, change it because PARAMETERs can not
1846 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
1849 gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
1854 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
1855 && current_attr
.flavor
== FL_PARAMETER
)
1856 as
->type
= AS_IMPLIED_SHAPE
;
1858 if (as
->type
== AS_IMPLIED_SHAPE
1859 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
1869 cl_deferred
= false;
1871 if (current_ts
.type
== BT_CHARACTER
)
1873 switch (match_char_length (&char_len
, &cl_deferred
, false))
1876 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1878 cl
->length
= char_len
;
1881 /* Non-constant lengths need to be copied after the first
1882 element. Also copy assumed lengths. */
1885 && (current_ts
.u
.cl
->length
== NULL
1886 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1888 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1889 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
1892 cl
= current_ts
.u
.cl
;
1894 cl_deferred
= current_ts
.deferred
;
1903 /* If this symbol has already shown up in a Cray Pointer declaration,
1904 then we want to set the type & bail out. */
1905 if (gfc_option
.flag_cray_pointer
)
1907 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1908 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1910 sym
->ts
.type
= current_ts
.type
;
1911 sym
->ts
.kind
= current_ts
.kind
;
1913 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
1914 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1915 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1918 /* Check to see if we have an array specification. */
1921 if (sym
->as
!= NULL
)
1923 gfc_error ("Duplicate array spec for Cray pointee at %C");
1924 gfc_free_array_spec (cp_as
);
1930 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
1931 gfc_internal_error ("Couldn't set pointee array spec.");
1933 /* Fix the array spec. */
1934 m
= gfc_mod_pointee_as (sym
->as
);
1935 if (m
== MATCH_ERROR
)
1943 gfc_free_array_spec (cp_as
);
1947 /* Procedure pointer as function result. */
1948 if (gfc_current_state () == COMP_FUNCTION
1949 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
1950 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
1951 strcpy (name
, "ppr@");
1953 if (gfc_current_state () == COMP_FUNCTION
1954 && strcmp (name
, gfc_current_block ()->name
) == 0
1955 && gfc_current_block ()->result
1956 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
1957 strcpy (name
, "ppr@");
1959 /* OK, we've successfully matched the declaration. Now put the
1960 symbol in the current namespace, because it might be used in the
1961 optional initialization expression for this symbol, e.g. this is
1964 integer, parameter :: i = huge(i)
1966 This is only true for parameters or variables of a basic type.
1967 For components of derived types, it is not true, so we don't
1968 create a symbol for those yet. If we fail to create the symbol,
1970 if (gfc_current_state () != COMP_DERIVED
1971 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
1977 if (!check_function_name (name
))
1983 /* We allow old-style initializations of the form
1984 integer i /2/, j(4) /3*3, 1/
1985 (if no colon has been seen). These are different from data
1986 statements in that initializers are only allowed to apply to the
1987 variable immediately preceding, i.e.
1989 is not allowed. Therefore we have to do some work manually, that
1990 could otherwise be left to the matchers for DATA statements. */
1992 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1994 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
1995 "initialization at %C"))
1998 return match_old_style_init (name
);
2001 /* The double colon must be present in order to have initializers.
2002 Otherwise the statement is ambiguous with an assignment statement. */
2005 if (gfc_match (" =>") == MATCH_YES
)
2007 if (!current_attr
.pointer
)
2009 gfc_error ("Initialization at %C isn't for a pointer variable");
2014 m
= match_pointer_init (&initializer
, 0);
2018 else if (gfc_match_char ('=') == MATCH_YES
)
2020 if (current_attr
.pointer
)
2022 gfc_error ("Pointer initialization at %C requires '=>', "
2028 m
= gfc_match_init_expr (&initializer
);
2031 gfc_error ("Expected an initialization expression at %C");
2035 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2036 && gfc_state_stack
->state
!= COMP_DERIVED
)
2038 gfc_error ("Initialization of variable at %C is not allowed in "
2039 "a PURE procedure");
2048 if (initializer
!= NULL
&& current_attr
.allocatable
2049 && gfc_current_state () == COMP_DERIVED
)
2051 gfc_error ("Initialization of allocatable component at %C is not "
2057 /* Add the initializer. Note that it is fine if initializer is
2058 NULL here, because we sometimes also need to check if a
2059 declaration *must* have an initialization expression. */
2060 if (gfc_current_state () != COMP_DERIVED
)
2061 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2064 if (current_ts
.type
== BT_DERIVED
2065 && !current_attr
.pointer
&& !initializer
)
2066 initializer
= gfc_default_initializer (¤t_ts
);
2067 t
= build_struct (name
, cl
, &initializer
, &as
);
2070 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2073 /* Free stuff up and return. */
2074 gfc_free_expr (initializer
);
2075 gfc_free_array_spec (as
);
2081 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2082 This assumes that the byte size is equal to the kind number for
2083 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2086 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2091 if (gfc_match_char ('*') != MATCH_YES
)
2094 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2098 original_kind
= ts
->kind
;
2100 /* Massage the kind numbers for complex types. */
2101 if (ts
->type
== BT_COMPLEX
)
2105 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2106 gfc_basic_typename (ts
->type
), original_kind
);
2113 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2116 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2120 if (gfc_option
.flag_real4_kind
== 8)
2122 if (gfc_option
.flag_real4_kind
== 10)
2124 if (gfc_option
.flag_real4_kind
== 16)
2130 if (gfc_option
.flag_real8_kind
== 4)
2132 if (gfc_option
.flag_real8_kind
== 10)
2134 if (gfc_option
.flag_real8_kind
== 16)
2139 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2141 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2142 gfc_basic_typename (ts
->type
), original_kind
);
2146 if (!gfc_notify_std (GFC_STD_GNU
,
2147 "Nonstandard type declaration %s*%d at %C",
2148 gfc_basic_typename(ts
->type
), original_kind
))
2155 /* Match a kind specification. Since kinds are generally optional, we
2156 usually return MATCH_NO if something goes wrong. If a "kind="
2157 string is found, then we know we have an error. */
2160 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2172 where
= loc
= gfc_current_locus
;
2177 if (gfc_match_char ('(') == MATCH_NO
)
2180 /* Also gobbles optional text. */
2181 if (gfc_match (" kind = ") == MATCH_YES
)
2184 loc
= gfc_current_locus
;
2187 n
= gfc_match_init_expr (&e
);
2191 if (gfc_matching_function
)
2193 /* The function kind expression might include use associated or
2194 imported parameters and try again after the specification
2196 if (gfc_match_char (')') != MATCH_YES
)
2198 gfc_error ("Missing right parenthesis at %C");
2204 gfc_undo_symbols ();
2209 /* ....or else, the match is real. */
2211 gfc_error ("Expected initialization expression at %C");
2219 gfc_error ("Expected scalar initialization expression at %C");
2224 msg
= gfc_extract_int (e
, &ts
->kind
);
2233 /* Before throwing away the expression, let's see if we had a
2234 C interoperable kind (and store the fact). */
2235 if (e
->ts
.is_c_interop
== 1)
2237 /* Mark this as C interoperable if being declared with one
2238 of the named constants from iso_c_binding. */
2239 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2240 ts
->f90_type
= e
->ts
.f90_type
;
2246 /* Ignore errors to this point, if we've gotten here. This means
2247 we ignore the m=MATCH_ERROR from above. */
2248 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2250 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2251 gfc_basic_typename (ts
->type
));
2252 gfc_current_locus
= where
;
2256 /* Warn if, e.g., c_int is used for a REAL variable, but not
2257 if, e.g., c_double is used for COMPLEX as the standard
2258 explicitly says that the kind type parameter for complex and real
2259 variable is the same, i.e. c_float == c_float_complex. */
2260 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2261 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2262 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2263 gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2264 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2265 gfc_basic_typename (ts
->type
));
2267 gfc_gobble_whitespace ();
2268 if ((c
= gfc_next_ascii_char ()) != ')'
2269 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2271 if (ts
->type
== BT_CHARACTER
)
2272 gfc_error ("Missing right parenthesis or comma at %C");
2274 gfc_error ("Missing right parenthesis at %C");
2278 /* All tests passed. */
2281 if(m
== MATCH_ERROR
)
2282 gfc_current_locus
= where
;
2284 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
2287 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2291 if (gfc_option
.flag_real4_kind
== 8)
2293 if (gfc_option
.flag_real4_kind
== 10)
2295 if (gfc_option
.flag_real4_kind
== 16)
2301 if (gfc_option
.flag_real8_kind
== 4)
2303 if (gfc_option
.flag_real8_kind
== 10)
2305 if (gfc_option
.flag_real8_kind
== 16)
2310 /* Return what we know from the test(s). */
2315 gfc_current_locus
= where
;
2321 match_char_kind (int * kind
, int * is_iso_c
)
2330 where
= gfc_current_locus
;
2332 n
= gfc_match_init_expr (&e
);
2334 if (n
!= MATCH_YES
&& gfc_matching_function
)
2336 /* The expression might include use-associated or imported
2337 parameters and try again after the specification
2340 gfc_undo_symbols ();
2345 gfc_error ("Expected initialization expression at %C");
2351 gfc_error ("Expected scalar initialization expression at %C");
2356 msg
= gfc_extract_int (e
, kind
);
2357 *is_iso_c
= e
->ts
.is_iso_c
;
2367 /* Ignore errors to this point, if we've gotten here. This means
2368 we ignore the m=MATCH_ERROR from above. */
2369 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2371 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2375 /* All tests passed. */
2378 if (m
== MATCH_ERROR
)
2379 gfc_current_locus
= where
;
2381 /* Return what we know from the test(s). */
2386 gfc_current_locus
= where
;
2391 /* Match the various kind/length specifications in a CHARACTER
2392 declaration. We don't return MATCH_NO. */
2395 gfc_match_char_spec (gfc_typespec
*ts
)
2397 int kind
, seen_length
, is_iso_c
;
2409 /* Try the old-style specification first. */
2410 old_char_selector
= 0;
2412 m
= match_char_length (&len
, &deferred
, true);
2416 old_char_selector
= 1;
2421 m
= gfc_match_char ('(');
2424 m
= MATCH_YES
; /* Character without length is a single char. */
2428 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2429 if (gfc_match (" kind =") == MATCH_YES
)
2431 m
= match_char_kind (&kind
, &is_iso_c
);
2433 if (m
== MATCH_ERROR
)
2438 if (gfc_match (" , len =") == MATCH_NO
)
2441 m
= char_len_param_value (&len
, &deferred
);
2444 if (m
== MATCH_ERROR
)
2451 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2452 if (gfc_match (" len =") == MATCH_YES
)
2454 m
= char_len_param_value (&len
, &deferred
);
2457 if (m
== MATCH_ERROR
)
2461 if (gfc_match_char (')') == MATCH_YES
)
2464 if (gfc_match (" , kind =") != MATCH_YES
)
2467 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2473 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2474 m
= char_len_param_value (&len
, &deferred
);
2477 if (m
== MATCH_ERROR
)
2481 m
= gfc_match_char (')');
2485 if (gfc_match_char (',') != MATCH_YES
)
2488 gfc_match (" kind ="); /* Gobble optional text. */
2490 m
= match_char_kind (&kind
, &is_iso_c
);
2491 if (m
== MATCH_ERROR
)
2497 /* Require a right-paren at this point. */
2498 m
= gfc_match_char (')');
2503 gfc_error ("Syntax error in CHARACTER declaration at %C");
2505 gfc_free_expr (len
);
2509 /* Deal with character functions after USE and IMPORT statements. */
2510 if (gfc_matching_function
)
2512 gfc_free_expr (len
);
2513 gfc_undo_symbols ();
2519 gfc_free_expr (len
);
2523 /* Do some final massaging of the length values. */
2524 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2526 if (seen_length
== 0)
2527 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2532 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2533 ts
->deferred
= deferred
;
2535 /* We have to know if it was a C interoperable kind so we can
2536 do accurate type checking of bind(c) procs, etc. */
2538 /* Mark this as C interoperable if being declared with one
2539 of the named constants from iso_c_binding. */
2540 ts
->is_c_interop
= is_iso_c
;
2541 else if (len
!= NULL
)
2542 /* Here, we might have parsed something such as: character(c_char)
2543 In this case, the parsing code above grabs the c_char when
2544 looking for the length (line 1690, roughly). it's the last
2545 testcase for parsing the kind params of a character variable.
2546 However, it's not actually the length. this seems like it
2548 To see if the user used a C interop kind, test the expr
2549 of the so called length, and see if it's C interoperable. */
2550 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2556 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2557 structure to the matched specification. This is necessary for FUNCTION and
2558 IMPLICIT statements.
2560 If implicit_flag is nonzero, then we don't check for the optional
2561 kind specification. Not doing so is needed for matching an IMPLICIT
2562 statement correctly. */
2565 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2567 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2568 gfc_symbol
*sym
, *dt_sym
;
2571 bool seen_deferred_kind
, matched_type
;
2572 const char *dt_name
;
2574 /* A belt and braces check that the typespec is correctly being treated
2575 as a deferred characteristic association. */
2576 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2577 && (gfc_current_block ()->result
->ts
.kind
== -1)
2578 && (ts
->kind
== -1);
2580 if (seen_deferred_kind
)
2583 /* Clear the current binding label, in case one is given. */
2584 curr_binding_label
= NULL
;
2586 if (gfc_match (" byte") == MATCH_YES
)
2588 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
2591 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2593 gfc_error ("BYTE type used at %C "
2594 "is not available on the target machine");
2598 ts
->type
= BT_INTEGER
;
2604 m
= gfc_match (" type (");
2605 matched_type
= (m
== MATCH_YES
);
2608 gfc_gobble_whitespace ();
2609 if (gfc_peek_ascii_char () == '*')
2611 if ((m
= gfc_match ("*)")) != MATCH_YES
)
2613 if (gfc_current_state () == COMP_DERIVED
)
2615 gfc_error ("Assumed type at %C is not allowed for components");
2618 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
2621 ts
->type
= BT_ASSUMED
;
2625 m
= gfc_match ("%n", name
);
2626 matched_type
= (m
== MATCH_YES
);
2629 if ((matched_type
&& strcmp ("integer", name
) == 0)
2630 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
2632 ts
->type
= BT_INTEGER
;
2633 ts
->kind
= gfc_default_integer_kind
;
2637 if ((matched_type
&& strcmp ("character", name
) == 0)
2638 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
2641 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2642 "intrinsic-type-spec at %C"))
2645 ts
->type
= BT_CHARACTER
;
2646 if (implicit_flag
== 0)
2647 m
= gfc_match_char_spec (ts
);
2651 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
2657 if ((matched_type
&& strcmp ("real", name
) == 0)
2658 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
2661 ts
->kind
= gfc_default_real_kind
;
2666 && (strcmp ("doubleprecision", name
) == 0
2667 || (strcmp ("double", name
) == 0
2668 && gfc_match (" precision") == MATCH_YES
)))
2669 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
2672 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2673 "intrinsic-type-spec at %C"))
2675 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2679 ts
->kind
= gfc_default_double_kind
;
2683 if ((matched_type
&& strcmp ("complex", name
) == 0)
2684 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
2686 ts
->type
= BT_COMPLEX
;
2687 ts
->kind
= gfc_default_complex_kind
;
2692 && (strcmp ("doublecomplex", name
) == 0
2693 || (strcmp ("double", name
) == 0
2694 && gfc_match (" complex") == MATCH_YES
)))
2695 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
2697 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
2701 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2702 "intrinsic-type-spec at %C"))
2705 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2708 ts
->type
= BT_COMPLEX
;
2709 ts
->kind
= gfc_default_double_kind
;
2713 if ((matched_type
&& strcmp ("logical", name
) == 0)
2714 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
2716 ts
->type
= BT_LOGICAL
;
2717 ts
->kind
= gfc_default_logical_kind
;
2722 m
= gfc_match_char (')');
2725 ts
->type
= BT_DERIVED
;
2728 /* Match CLASS declarations. */
2729 m
= gfc_match (" class ( * )");
2730 if (m
== MATCH_ERROR
)
2732 else if (m
== MATCH_YES
)
2736 ts
->type
= BT_CLASS
;
2737 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
2740 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
2741 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2743 gfc_set_sym_referenced (upe
);
2745 upe
->ts
.type
= BT_VOID
;
2746 upe
->attr
.unlimited_polymorphic
= 1;
2747 /* This is essential to force the construction of
2748 unlimited polymorphic component class containers. */
2749 upe
->attr
.zero_comp
= 1;
2750 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
2751 &gfc_current_locus
))
2756 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
2758 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
2762 ts
->u
.derived
= upe
;
2766 m
= gfc_match (" class ( %n )", name
);
2769 ts
->type
= BT_CLASS
;
2771 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
2775 /* Defer association of the derived type until the end of the
2776 specification block. However, if the derived type can be
2777 found, add it to the typespec. */
2778 if (gfc_matching_function
)
2780 ts
->u
.derived
= NULL
;
2781 if (gfc_current_state () != COMP_INTERFACE
2782 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
2784 sym
= gfc_find_dt_in_generic (sym
);
2785 ts
->u
.derived
= sym
;
2790 /* Search for the name but allow the components to be defined later. If
2791 type = -1, this typespec has been seen in a function declaration but
2792 the type could not be accessed at that point. The actual derived type is
2793 stored in a symtree with the first letter of the name capitalized; the
2794 symtree with the all lower-case name contains the associated
2795 generic function. */
2796 dt_name
= gfc_get_string ("%c%s",
2797 (char) TOUPPER ((unsigned char) name
[0]),
2798 (const char*)&name
[1]);
2803 gfc_get_ha_symbol (name
, &sym
);
2804 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
2806 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2809 if (sym
->generic
&& !dt_sym
)
2810 dt_sym
= gfc_find_dt_in_generic (sym
);
2812 else if (ts
->kind
== -1)
2814 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
2815 || gfc_current_ns
->has_import_set
;
2816 gfc_find_symbol (name
, NULL
, iface
, &sym
);
2817 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
2819 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2822 if (sym
&& sym
->generic
&& !dt_sym
)
2823 dt_sym
= gfc_find_dt_in_generic (sym
);
2830 if ((sym
->attr
.flavor
!= FL_UNKNOWN
2831 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
2832 || sym
->attr
.subroutine
)
2834 gfc_error ("Type name '%s' at %C conflicts with previously declared "
2835 "entity at %L, which has the same name", name
,
2840 gfc_set_sym_referenced (sym
);
2841 if (!sym
->attr
.generic
2842 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
2845 if (!sym
->attr
.function
2846 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2851 gfc_interface
*intr
, *head
;
2853 /* Use upper case to save the actual derived-type symbol. */
2854 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
2855 dt_sym
->name
= gfc_get_string (sym
->name
);
2856 head
= sym
->generic
;
2857 intr
= gfc_get_interface ();
2859 intr
->where
= gfc_current_locus
;
2861 sym
->generic
= intr
;
2862 sym
->attr
.if_source
= IFSRC_DECL
;
2865 gfc_set_sym_referenced (dt_sym
);
2867 if (dt_sym
->attr
.flavor
!= FL_DERIVED
2868 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
2871 ts
->u
.derived
= dt_sym
;
2877 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
2878 "intrinsic-type-spec at %C"))
2881 /* For all types except double, derived and character, look for an
2882 optional kind specifier. MATCH_NO is actually OK at this point. */
2883 if (implicit_flag
== 1)
2885 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2891 if (gfc_current_form
== FORM_FREE
)
2893 c
= gfc_peek_ascii_char ();
2894 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
2895 && c
!= ':' && c
!= ',')
2897 if (matched_type
&& c
== ')')
2899 gfc_next_ascii_char ();
2906 m
= gfc_match_kind_spec (ts
, false);
2907 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2908 m
= gfc_match_old_kind_spec (ts
);
2910 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
2913 /* Defer association of the KIND expression of function results
2914 until after USE and IMPORT statements. */
2915 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
2916 || gfc_matching_function
)
2920 m
= MATCH_YES
; /* No kind specifier found. */
2926 /* Match an IMPLICIT NONE statement. Actually, this statement is
2927 already matched in parse.c, or we would not end up here in the
2928 first place. So the only thing we need to check, is if there is
2929 trailing garbage. If not, the match is successful. */
2932 gfc_match_implicit_none (void)
2934 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
2938 /* Match the letter range(s) of an IMPLICIT statement. */
2941 match_implicit_range (void)
2947 cur_loc
= gfc_current_locus
;
2949 gfc_gobble_whitespace ();
2950 c
= gfc_next_ascii_char ();
2953 gfc_error ("Missing character range in IMPLICIT at %C");
2960 gfc_gobble_whitespace ();
2961 c1
= gfc_next_ascii_char ();
2965 gfc_gobble_whitespace ();
2966 c
= gfc_next_ascii_char ();
2971 inner
= 0; /* Fall through. */
2978 gfc_gobble_whitespace ();
2979 c2
= gfc_next_ascii_char ();
2983 gfc_gobble_whitespace ();
2984 c
= gfc_next_ascii_char ();
2986 if ((c
!= ',') && (c
!= ')'))
2999 gfc_error ("Letters must be in alphabetic order in "
3000 "IMPLICIT statement at %C");
3004 /* See if we can add the newly matched range to the pending
3005 implicits from this IMPLICIT statement. We do not check for
3006 conflicts with whatever earlier IMPLICIT statements may have
3007 set. This is done when we've successfully finished matching
3009 if (!gfc_add_new_implicit_range (c1
, c2
))
3016 gfc_syntax_error (ST_IMPLICIT
);
3018 gfc_current_locus
= cur_loc
;
3023 /* Match an IMPLICIT statement, storing the types for
3024 gfc_set_implicit() if the statement is accepted by the parser.
3025 There is a strange looking, but legal syntactic construction
3026 possible. It looks like:
3028 IMPLICIT INTEGER (a-b) (c-d)
3030 This is legal if "a-b" is a constant expression that happens to
3031 equal one of the legal kinds for integers. The real problem
3032 happens with an implicit specification that looks like:
3034 IMPLICIT INTEGER (a-b)
3036 In this case, a typespec matcher that is "greedy" (as most of the
3037 matchers are) gobbles the character range as a kindspec, leaving
3038 nothing left. We therefore have to go a bit more slowly in the
3039 matching process by inhibiting the kindspec checking during
3040 typespec matching and checking for a kind later. */
3043 gfc_match_implicit (void)
3052 /* We don't allow empty implicit statements. */
3053 if (gfc_match_eos () == MATCH_YES
)
3055 gfc_error ("Empty IMPLICIT statement at %C");
3061 /* First cleanup. */
3062 gfc_clear_new_implicit ();
3064 /* A basic type is mandatory here. */
3065 m
= gfc_match_decl_type_spec (&ts
, 1);
3066 if (m
== MATCH_ERROR
)
3071 cur_loc
= gfc_current_locus
;
3072 m
= match_implicit_range ();
3076 /* We may have <TYPE> (<RANGE>). */
3077 gfc_gobble_whitespace ();
3078 c
= gfc_next_ascii_char ();
3079 if ((c
== '\n') || (c
== ','))
3081 /* Check for CHARACTER with no length parameter. */
3082 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3084 ts
.kind
= gfc_default_character_kind
;
3085 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3086 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3090 /* Record the Successful match. */
3091 if (!gfc_merge_new_implicit (&ts
))
3096 gfc_current_locus
= cur_loc
;
3099 /* Discard the (incorrectly) matched range. */
3100 gfc_clear_new_implicit ();
3102 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3103 if (ts
.type
== BT_CHARACTER
)
3104 m
= gfc_match_char_spec (&ts
);
3107 m
= gfc_match_kind_spec (&ts
, false);
3110 m
= gfc_match_old_kind_spec (&ts
);
3111 if (m
== MATCH_ERROR
)
3117 if (m
== MATCH_ERROR
)
3120 m
= match_implicit_range ();
3121 if (m
== MATCH_ERROR
)
3126 gfc_gobble_whitespace ();
3127 c
= gfc_next_ascii_char ();
3128 if ((c
!= '\n') && (c
!= ','))
3131 if (!gfc_merge_new_implicit (&ts
))
3139 gfc_syntax_error (ST_IMPLICIT
);
3147 gfc_match_import (void)
3149 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3154 if (gfc_current_ns
->proc_name
== NULL
3155 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3157 gfc_error ("IMPORT statement at %C only permitted in "
3158 "an INTERFACE body");
3162 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3165 if (gfc_match_eos () == MATCH_YES
)
3167 /* All host variables should be imported. */
3168 gfc_current_ns
->has_import_set
= 1;
3172 if (gfc_match (" ::") == MATCH_YES
)
3174 if (gfc_match_eos () == MATCH_YES
)
3176 gfc_error ("Expecting list of named entities at %C");
3184 m
= gfc_match (" %n", name
);
3188 if (gfc_current_ns
->parent
!= NULL
3189 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3191 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3194 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3195 && gfc_find_symbol (name
,
3196 gfc_current_ns
->proc_name
->ns
->parent
,
3199 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3205 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
3206 "at %C - does not exist.", name
);
3210 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3212 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
3217 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3220 sym
->attr
.imported
= 1;
3222 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3224 /* The actual derived type is stored in a symtree with the first
3225 letter of the name capitalized; the symtree with the all
3226 lower-case name contains the associated generic function. */
3227 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3228 gfc_get_string ("%c%s",
3229 (char) TOUPPER ((unsigned char) name
[0]),
3233 sym
->attr
.imported
= 1;
3246 if (gfc_match_eos () == MATCH_YES
)
3248 if (gfc_match_char (',') != MATCH_YES
)
3255 gfc_error ("Syntax error in IMPORT statement at %C");
3260 /* A minimal implementation of gfc_match without whitespace, escape
3261 characters or variable arguments. Returns true if the next
3262 characters match the TARGET template exactly. */
3265 match_string_p (const char *target
)
3269 for (p
= target
; *p
; p
++)
3270 if ((char) gfc_next_ascii_char () != *p
)
3275 /* Matches an attribute specification including array specs. If
3276 successful, leaves the variables current_attr and current_as
3277 holding the specification. Also sets the colon_seen variable for
3278 later use by matchers associated with initializations.
3280 This subroutine is a little tricky in the sense that we don't know
3281 if we really have an attr-spec until we hit the double colon.
3282 Until that time, we can only return MATCH_NO. This forces us to
3283 check for duplicate specification at this level. */
3286 match_attr_spec (void)
3288 /* Modifiers that can exist in a type statement. */
3290 { GFC_DECL_BEGIN
= 0,
3291 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3292 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3293 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3294 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3295 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3296 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3299 /* GFC_DECL_END is the sentinel, index starts at 0. */
3300 #define NUM_DECL GFC_DECL_END
3302 locus start
, seen_at
[NUM_DECL
];
3309 gfc_clear_attr (¤t_attr
);
3310 start
= gfc_current_locus
;
3315 /* See if we get all of the keywords up to the final double colon. */
3316 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3324 gfc_gobble_whitespace ();
3326 ch
= gfc_next_ascii_char ();
3329 /* This is the successful exit condition for the loop. */
3330 if (gfc_next_ascii_char () == ':')
3335 gfc_gobble_whitespace ();
3336 switch (gfc_peek_ascii_char ())
3339 gfc_next_ascii_char ();
3340 switch (gfc_next_ascii_char ())
3343 if (match_string_p ("locatable"))
3345 /* Matched "allocatable". */
3346 d
= DECL_ALLOCATABLE
;
3351 if (match_string_p ("ynchronous"))
3353 /* Matched "asynchronous". */
3354 d
= DECL_ASYNCHRONOUS
;
3361 /* Try and match the bind(c). */
3362 m
= gfc_match_bind_c (NULL
, true);
3365 else if (m
== MATCH_ERROR
)
3370 gfc_next_ascii_char ();
3371 if ('o' != gfc_next_ascii_char ())
3373 switch (gfc_next_ascii_char ())
3376 if (match_string_p ("imension"))
3378 d
= DECL_CODIMENSION
;
3382 if (match_string_p ("tiguous"))
3384 d
= DECL_CONTIGUOUS
;
3391 if (match_string_p ("dimension"))
3396 if (match_string_p ("external"))
3401 if (match_string_p ("int"))
3403 ch
= gfc_next_ascii_char ();
3406 if (match_string_p ("nt"))
3408 /* Matched "intent". */
3409 /* TODO: Call match_intent_spec from here. */
3410 if (gfc_match (" ( in out )") == MATCH_YES
)
3412 else if (gfc_match (" ( in )") == MATCH_YES
)
3414 else if (gfc_match (" ( out )") == MATCH_YES
)
3420 if (match_string_p ("insic"))
3422 /* Matched "intrinsic". */
3430 if (match_string_p ("optional"))
3435 gfc_next_ascii_char ();
3436 switch (gfc_next_ascii_char ())
3439 if (match_string_p ("rameter"))
3441 /* Matched "parameter". */
3447 if (match_string_p ("inter"))
3449 /* Matched "pointer". */
3455 ch
= gfc_next_ascii_char ();
3458 if (match_string_p ("vate"))
3460 /* Matched "private". */
3466 if (match_string_p ("tected"))
3468 /* Matched "protected". */
3475 if (match_string_p ("blic"))
3477 /* Matched "public". */
3485 if (match_string_p ("save"))
3490 if (match_string_p ("target"))
3495 gfc_next_ascii_char ();
3496 ch
= gfc_next_ascii_char ();
3499 if (match_string_p ("lue"))
3501 /* Matched "value". */
3507 if (match_string_p ("latile"))
3509 /* Matched "volatile". */
3517 /* No double colon and no recognizable decl_type, so assume that
3518 we've been looking at something else the whole time. */
3525 /* Check to make sure any parens are paired up correctly. */
3526 if (gfc_match_parens () == MATCH_ERROR
)
3533 seen_at
[d
] = gfc_current_locus
;
3535 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
3537 gfc_array_spec
*as
= NULL
;
3539 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
3540 d
== DECL_CODIMENSION
);
3542 if (current_as
== NULL
)
3544 else if (m
== MATCH_YES
)
3546 if (!merge_array_spec (as
, current_as
, false))
3553 if (d
== DECL_CODIMENSION
)
3554 gfc_error ("Missing codimension specification at %C");
3556 gfc_error ("Missing dimension specification at %C");
3560 if (m
== MATCH_ERROR
)
3565 /* Since we've seen a double colon, we have to be looking at an
3566 attr-spec. This means that we can now issue errors. */
3567 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3572 case DECL_ALLOCATABLE
:
3573 attr
= "ALLOCATABLE";
3575 case DECL_ASYNCHRONOUS
:
3576 attr
= "ASYNCHRONOUS";
3578 case DECL_CODIMENSION
:
3579 attr
= "CODIMENSION";
3581 case DECL_CONTIGUOUS
:
3582 attr
= "CONTIGUOUS";
3584 case DECL_DIMENSION
:
3591 attr
= "INTENT (IN)";
3594 attr
= "INTENT (OUT)";
3597 attr
= "INTENT (IN OUT)";
3599 case DECL_INTRINSIC
:
3605 case DECL_PARAMETER
:
3611 case DECL_PROTECTED
:
3626 case DECL_IS_BIND_C
:
3636 attr
= NULL
; /* This shouldn't happen. */
3639 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
3644 /* Now that we've dealt with duplicate attributes, add the attributes
3645 to the current attribute. */
3646 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3651 if (gfc_current_state () == COMP_DERIVED
3652 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
3653 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
3654 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
3656 if (d
== DECL_ALLOCATABLE
)
3658 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
3659 "attribute at %C in a TYPE definition"))
3667 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3674 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
3675 && gfc_current_state () != COMP_MODULE
)
3677 if (d
== DECL_PRIVATE
)
3681 if (gfc_current_state () == COMP_DERIVED
3682 && gfc_state_stack
->previous
3683 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
3685 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
3686 "at %L in a TYPE definition", attr
,
3695 gfc_error ("%s attribute at %L is not allowed outside of the "
3696 "specification part of a module", attr
, &seen_at
[d
]);
3704 case DECL_ALLOCATABLE
:
3705 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
3708 case DECL_ASYNCHRONOUS
:
3709 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
3712 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
3715 case DECL_CODIMENSION
:
3716 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
3719 case DECL_CONTIGUOUS
:
3720 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
3723 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
3726 case DECL_DIMENSION
:
3727 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
3731 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
3735 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
3739 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
3743 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
3746 case DECL_INTRINSIC
:
3747 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
3751 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
3754 case DECL_PARAMETER
:
3755 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
3759 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
3762 case DECL_PROTECTED
:
3763 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3765 gfc_error ("PROTECTED at %C only allowed in specification "
3766 "part of a module");
3771 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
3774 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
3778 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
3783 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
3788 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
3792 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
3795 case DECL_IS_BIND_C
:
3796 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
3800 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
3803 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
3807 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
3810 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
3814 gfc_internal_error ("match_attr_spec(): Bad attribute");
3824 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
3825 if (gfc_current_state () == COMP_MODULE
&& !current_attr
.save
3826 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
3827 current_attr
.save
= SAVE_IMPLICIT
;
3833 gfc_current_locus
= start
;
3834 gfc_free_array_spec (current_as
);
3840 /* Set the binding label, dest_label, either with the binding label
3841 stored in the given gfc_typespec, ts, or if none was provided, it
3842 will be the symbol name in all lower case, as required by the draft
3843 (J3/04-007, section 15.4.1). If a binding label was given and
3844 there is more than one argument (num_idents), it is an error. */
3847 set_binding_label (const char **dest_label
, const char *sym_name
,
3850 if (num_idents
> 1 && has_name_equals
)
3852 gfc_error ("Multiple identifiers provided with "
3853 "single NAME= specifier at %C");
3857 if (curr_binding_label
)
3858 /* Binding label given; store in temp holder till have sym. */
3859 *dest_label
= curr_binding_label
;
3862 /* No binding label given, and the NAME= specifier did not exist,
3863 which means there was no NAME="". */
3864 if (sym_name
!= NULL
&& has_name_equals
== 0)
3865 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
3872 /* Set the status of the given common block as being BIND(C) or not,
3873 depending on the given parameter, is_bind_c. */
3876 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
3878 com_block
->is_bind_c
= is_bind_c
;
3883 /* Verify that the given gfc_typespec is for a C interoperable type. */
3886 gfc_verify_c_interop (gfc_typespec
*ts
)
3888 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
3889 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
3891 else if (ts
->type
== BT_CLASS
)
3893 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
3900 /* Verify that the variables of a given common block, which has been
3901 defined with the attribute specifier bind(c), to be of a C
3902 interoperable type. Errors will be reported here, if
3906 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
3908 gfc_symbol
*curr_sym
= NULL
;
3911 curr_sym
= com_block
->head
;
3913 /* Make sure we have at least one symbol. */
3914 if (curr_sym
== NULL
)
3917 /* Here we know we have a symbol, so we'll execute this loop
3921 /* The second to last param, 1, says this is in a common block. */
3922 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
3923 curr_sym
= curr_sym
->common_next
;
3924 } while (curr_sym
!= NULL
);
3930 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3931 an appropriate error message is reported. */
3934 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
3935 int is_in_common
, gfc_common_head
*com_block
)
3937 bool bind_c_function
= false;
3940 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
3941 bind_c_function
= true;
3943 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
3945 tmp_sym
= tmp_sym
->result
;
3946 /* Make sure it wasn't an implicitly typed result. */
3947 if (tmp_sym
->attr
.implicit_type
&& gfc_option
.warn_c_binding_type
)
3949 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3950 "%L may not be C interoperable", tmp_sym
->name
,
3951 &tmp_sym
->declared_at
);
3952 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
3953 /* Mark it as C interoperable to prevent duplicate warnings. */
3954 tmp_sym
->ts
.is_c_interop
= 1;
3955 tmp_sym
->attr
.is_c_interop
= 1;
3959 /* Here, we know we have the bind(c) attribute, so if we have
3960 enough type info, then verify that it's a C interop kind.
3961 The info could be in the symbol already, or possibly still in
3962 the given ts (current_ts), so look in both. */
3963 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
3965 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
3967 /* See if we're dealing with a sym in a common block or not. */
3968 if (is_in_common
== 1 && gfc_option
.warn_c_binding_type
)
3970 gfc_warning ("Variable '%s' in common block '%s' at %L "
3971 "may not be a C interoperable "
3972 "kind though common block '%s' is BIND(C)",
3973 tmp_sym
->name
, com_block
->name
,
3974 &(tmp_sym
->declared_at
), com_block
->name
);
3978 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
3979 gfc_error ("Type declaration '%s' at %L is not C "
3980 "interoperable but it is BIND(C)",
3981 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3982 else if (gfc_option
.warn_c_binding_type
)
3983 gfc_warning ("Variable '%s' at %L "
3984 "may not be a C interoperable "
3985 "kind but it is bind(c)",
3986 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3990 /* Variables declared w/in a common block can't be bind(c)
3991 since there's no way for C to see these variables, so there's
3992 semantically no reason for the attribute. */
3993 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
3995 gfc_error ("Variable '%s' in common block '%s' at "
3996 "%L cannot be declared with BIND(C) "
3997 "since it is not a global",
3998 tmp_sym
->name
, com_block
->name
,
3999 &(tmp_sym
->declared_at
));
4003 /* Scalar variables that are bind(c) can not have the pointer
4004 or allocatable attributes. */
4005 if (tmp_sym
->attr
.is_bind_c
== 1)
4007 if (tmp_sym
->attr
.pointer
== 1)
4009 gfc_error ("Variable '%s' at %L cannot have both the "
4010 "POINTER and BIND(C) attributes",
4011 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4015 if (tmp_sym
->attr
.allocatable
== 1)
4017 gfc_error ("Variable '%s' at %L cannot have both the "
4018 "ALLOCATABLE and BIND(C) attributes",
4019 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4025 /* If it is a BIND(C) function, make sure the return value is a
4026 scalar value. The previous tests in this function made sure
4027 the type is interoperable. */
4028 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4029 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4030 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4032 /* BIND(C) functions can not return a character string. */
4033 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4034 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4035 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4036 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4037 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
4038 "be a character string", tmp_sym
->name
,
4039 &(tmp_sym
->declared_at
));
4042 /* See if the symbol has been marked as private. If it has, make sure
4043 there is no binding label and warn the user if there is one. */
4044 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4045 && tmp_sym
->binding_label
)
4046 /* Use gfc_warning_now because we won't say that the symbol fails
4047 just because of this. */
4048 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
4049 "given the binding label '%s'", tmp_sym
->name
,
4050 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4056 /* Set the appropriate fields for a symbol that's been declared as
4057 BIND(C) (the is_bind_c flag and the binding label), and verify that
4058 the type is C interoperable. Errors are reported by the functions
4059 used to set/test these fields. */
4062 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4066 /* TODO: Do we need to make sure the vars aren't marked private? */
4068 /* Set the is_bind_c bit in symbol_attribute. */
4069 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4071 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4078 /* Set the fields marking the given common block as BIND(C), including
4079 a binding label, and report any errors encountered. */
4082 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4086 /* destLabel, common name, typespec (which may have binding label). */
4087 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4091 /* Set the given common block (com_block) to being bind(c) (1). */
4092 set_com_block_bind_c (com_block
, 1);
4098 /* Retrieve the list of one or more identifiers that the given bind(c)
4099 attribute applies to. */
4102 get_bind_c_idents (void)
4104 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4106 gfc_symbol
*tmp_sym
= NULL
;
4108 gfc_common_head
*com_block
= NULL
;
4110 if (gfc_match_name (name
) == MATCH_YES
)
4112 found_id
= MATCH_YES
;
4113 gfc_get_ha_symbol (name
, &tmp_sym
);
4115 else if (match_common_name (name
) == MATCH_YES
)
4117 found_id
= MATCH_YES
;
4118 com_block
= gfc_get_common (name
, 0);
4122 gfc_error ("Need either entity or common block name for "
4123 "attribute specification statement at %C");
4127 /* Save the current identifier and look for more. */
4130 /* Increment the number of identifiers found for this spec stmt. */
4133 /* Make sure we have a sym or com block, and verify that it can
4134 be bind(c). Set the appropriate field(s) and look for more
4136 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4138 if (tmp_sym
!= NULL
)
4140 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4145 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4149 /* Look to see if we have another identifier. */
4151 if (gfc_match_eos () == MATCH_YES
)
4152 found_id
= MATCH_NO
;
4153 else if (gfc_match_char (',') != MATCH_YES
)
4154 found_id
= MATCH_NO
;
4155 else if (gfc_match_name (name
) == MATCH_YES
)
4157 found_id
= MATCH_YES
;
4158 gfc_get_ha_symbol (name
, &tmp_sym
);
4160 else if (match_common_name (name
) == MATCH_YES
)
4162 found_id
= MATCH_YES
;
4163 com_block
= gfc_get_common (name
, 0);
4167 gfc_error ("Missing entity or common block name for "
4168 "attribute specification statement at %C");
4174 gfc_internal_error ("Missing symbol");
4176 } while (found_id
== MATCH_YES
);
4178 /* if we get here we were successful */
4183 /* Try and match a BIND(C) attribute specification statement. */
4186 gfc_match_bind_c_stmt (void)
4188 match found_match
= MATCH_NO
;
4193 /* This may not be necessary. */
4195 /* Clear the temporary binding label holder. */
4196 curr_binding_label
= NULL
;
4198 /* Look for the bind(c). */
4199 found_match
= gfc_match_bind_c (NULL
, true);
4201 if (found_match
== MATCH_YES
)
4203 /* Look for the :: now, but it is not required. */
4206 /* Get the identifier(s) that needs to be updated. This may need to
4207 change to hand the flag(s) for the attr specified so all identifiers
4208 found can have all appropriate parts updated (assuming that the same
4209 spec stmt can have multiple attrs, such as both bind(c) and
4211 if (!get_bind_c_idents ())
4212 /* Error message should have printed already. */
4220 /* Match a data declaration statement. */
4223 gfc_match_data_decl (void)
4229 num_idents_on_line
= 0;
4231 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4235 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4236 && gfc_current_state () != COMP_DERIVED
)
4238 sym
= gfc_use_derived (current_ts
.u
.derived
);
4246 current_ts
.u
.derived
= sym
;
4249 m
= match_attr_spec ();
4250 if (m
== MATCH_ERROR
)
4256 if (current_ts
.type
== BT_CLASS
4257 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4260 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4261 && current_ts
.u
.derived
->components
== NULL
4262 && !current_ts
.u
.derived
->attr
.zero_comp
)
4265 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
4268 gfc_find_symbol (current_ts
.u
.derived
->name
,
4269 current_ts
.u
.derived
->ns
, 1, &sym
);
4271 /* Any symbol that we find had better be a type definition
4272 which has its components defined. */
4273 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
4274 && (current_ts
.u
.derived
->components
!= NULL
4275 || current_ts
.u
.derived
->attr
.zero_comp
))
4278 /* Now we have an error, which we signal, and then fix up
4279 because the knock-on is plain and simple confusing. */
4280 gfc_error_now ("Derived type at %C has not been previously defined "
4281 "and so cannot appear in a derived type definition");
4282 current_attr
.pointer
= 1;
4287 /* If we have an old-style character declaration, and no new-style
4288 attribute specifications, then there a comma is optional between
4289 the type specification and the variable list. */
4290 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4291 gfc_match_char (',');
4293 /* Give the types/attributes to symbols that follow. Give the element
4294 a number so that repeat character length expressions can be copied. */
4298 num_idents_on_line
++;
4299 m
= variable_decl (elem
++);
4300 if (m
== MATCH_ERROR
)
4305 if (gfc_match_eos () == MATCH_YES
)
4307 if (gfc_match_char (',') != MATCH_YES
)
4311 if (gfc_error_flag_test () == 0)
4312 gfc_error ("Syntax error in data declaration at %C");
4315 gfc_free_data_all (gfc_current_ns
);
4318 gfc_free_array_spec (current_as
);
4324 /* Match a prefix associated with a function or subroutine
4325 declaration. If the typespec pointer is nonnull, then a typespec
4326 can be matched. Note that if nothing matches, MATCH_YES is
4327 returned (the null string was matched). */
4330 gfc_match_prefix (gfc_typespec
*ts
)
4336 gfc_clear_attr (¤t_attr
);
4338 seen_impure
= false;
4340 gcc_assert (!gfc_matching_prefix
);
4341 gfc_matching_prefix
= true;
4345 found_prefix
= false;
4347 if (!seen_type
&& ts
!= NULL
4348 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4349 && gfc_match_space () == MATCH_YES
)
4353 found_prefix
= true;
4356 if (gfc_match ("elemental% ") == MATCH_YES
)
4358 if (!gfc_add_elemental (¤t_attr
, NULL
))
4361 found_prefix
= true;
4364 if (gfc_match ("pure% ") == MATCH_YES
)
4366 if (!gfc_add_pure (¤t_attr
, NULL
))
4369 found_prefix
= true;
4372 if (gfc_match ("recursive% ") == MATCH_YES
)
4374 if (!gfc_add_recursive (¤t_attr
, NULL
))
4377 found_prefix
= true;
4380 /* IMPURE is a somewhat special case, as it needs not set an actual
4381 attribute but rather only prevents ELEMENTAL routines from being
4382 automatically PURE. */
4383 if (gfc_match ("impure% ") == MATCH_YES
)
4385 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4389 found_prefix
= true;
4392 while (found_prefix
);
4394 /* IMPURE and PURE must not both appear, of course. */
4395 if (seen_impure
&& current_attr
.pure
)
4397 gfc_error ("PURE and IMPURE must not appear both at %C");
4401 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4402 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4404 if (!gfc_add_pure (¤t_attr
, NULL
))
4408 /* At this point, the next item is not a prefix. */
4409 gcc_assert (gfc_matching_prefix
);
4410 gfc_matching_prefix
= false;
4414 gcc_assert (gfc_matching_prefix
);
4415 gfc_matching_prefix
= false;
4420 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4423 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4425 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4428 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4431 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4438 /* Match a formal argument list. */
4441 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4443 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
4444 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4450 if (gfc_match_char ('(') != MATCH_YES
)
4457 if (gfc_match_char (')') == MATCH_YES
)
4462 if (gfc_match_char ('*') == MATCH_YES
)
4465 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
4474 m
= gfc_match_name (name
);
4478 if (gfc_get_symbol (name
, NULL
, &sym
))
4482 p
= gfc_get_formal_arglist ();
4494 /* We don't add the VARIABLE flavor because the name could be a
4495 dummy procedure. We don't apply these attributes to formal
4496 arguments of statement functions. */
4497 if (sym
!= NULL
&& !st_flag
4498 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
4499 || !gfc_missing_attr (&sym
->attr
, NULL
)))
4505 /* The name of a program unit can be in a different namespace,
4506 so check for it explicitly. After the statement is accepted,
4507 the name is checked for especially in gfc_get_symbol(). */
4508 if (gfc_new_block
!= NULL
&& sym
!= NULL
4509 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
4511 gfc_error ("Name '%s' at %C is the name of the procedure",
4517 if (gfc_match_char (')') == MATCH_YES
)
4520 m
= gfc_match_char (',');
4523 gfc_error ("Unexpected junk in formal argument list at %C");
4529 /* Check for duplicate symbols in the formal argument list. */
4532 for (p
= head
; p
->next
; p
= p
->next
)
4537 for (q
= p
->next
; q
; q
= q
->next
)
4538 if (p
->sym
== q
->sym
)
4540 gfc_error ("Duplicate symbol '%s' in formal argument list "
4541 "at %C", p
->sym
->name
);
4549 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
4558 gfc_free_formal_arglist (head
);
4563 /* Match a RESULT specification following a function declaration or
4564 ENTRY statement. Also matches the end-of-statement. */
4567 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
4569 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4573 if (gfc_match (" result (") != MATCH_YES
)
4576 m
= gfc_match_name (name
);
4580 /* Get the right paren, and that's it because there could be the
4581 bind(c) attribute after the result clause. */
4582 if (gfc_match_char (')') != MATCH_YES
)
4584 /* TODO: should report the missing right paren here. */
4588 if (strcmp (function
->name
, name
) == 0)
4590 gfc_error ("RESULT variable at %C must be different than function name");
4594 if (gfc_get_symbol (name
, NULL
, &r
))
4597 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
4606 /* Match a function suffix, which could be a combination of a result
4607 clause and BIND(C), either one, or neither. The draft does not
4608 require them to come in a specific order. */
4611 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
4613 match is_bind_c
; /* Found bind(c). */
4614 match is_result
; /* Found result clause. */
4615 match found_match
; /* Status of whether we've found a good match. */
4616 char peek_char
; /* Character we're going to peek at. */
4617 bool allow_binding_name
;
4619 /* Initialize to having found nothing. */
4620 found_match
= MATCH_NO
;
4621 is_bind_c
= MATCH_NO
;
4622 is_result
= MATCH_NO
;
4624 /* Get the next char to narrow between result and bind(c). */
4625 gfc_gobble_whitespace ();
4626 peek_char
= gfc_peek_ascii_char ();
4628 /* C binding names are not allowed for internal procedures. */
4629 if (gfc_current_state () == COMP_CONTAINS
4630 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4631 allow_binding_name
= false;
4633 allow_binding_name
= true;
4638 /* Look for result clause. */
4639 is_result
= match_result (sym
, result
);
4640 if (is_result
== MATCH_YES
)
4642 /* Now see if there is a bind(c) after it. */
4643 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4644 /* We've found the result clause and possibly bind(c). */
4645 found_match
= MATCH_YES
;
4648 /* This should only be MATCH_ERROR. */
4649 found_match
= is_result
;
4652 /* Look for bind(c) first. */
4653 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
4654 if (is_bind_c
== MATCH_YES
)
4656 /* Now see if a result clause followed it. */
4657 is_result
= match_result (sym
, result
);
4658 found_match
= MATCH_YES
;
4662 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4663 found_match
= MATCH_ERROR
;
4667 gfc_error ("Unexpected junk after function declaration at %C");
4668 found_match
= MATCH_ERROR
;
4672 if (is_bind_c
== MATCH_YES
)
4674 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4675 if (gfc_current_state () == COMP_CONTAINS
4676 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
4677 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
4678 "at %L may not be specified for an internal "
4679 "procedure", &gfc_current_locus
))
4682 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
4690 /* Procedure pointer return value without RESULT statement:
4691 Add "hidden" result variable named "ppr@". */
4694 add_hidden_procptr_result (gfc_symbol
*sym
)
4698 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
4701 /* First usage case: PROCEDURE and EXTERNAL statements. */
4702 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
4703 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
4704 && sym
->attr
.external
;
4705 /* Second usage case: INTERFACE statements. */
4706 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
4707 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
4708 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
4714 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
4718 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
4719 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
4720 st2
->n
.sym
= stree
->n
.sym
;
4722 sym
->result
= stree
->n
.sym
;
4724 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
4725 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
4726 sym
->result
->attr
.external
= sym
->attr
.external
;
4727 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
4728 sym
->result
->ts
= sym
->ts
;
4729 sym
->attr
.proc_pointer
= 0;
4730 sym
->attr
.pointer
= 0;
4731 sym
->attr
.external
= 0;
4732 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
4734 sym
->result
->attr
.pointer
= 0;
4735 sym
->result
->attr
.proc_pointer
= 1;
4738 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
4740 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
4741 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
4742 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
4743 && sym
== gfc_current_ns
->proc_name
4744 && sym
== sym
->result
->ns
->proc_name
4745 && strcmp ("ppr@", sym
->result
->name
) == 0)
4747 sym
->result
->attr
.proc_pointer
= 1;
4748 sym
->attr
.pointer
= 0;
4756 /* Match the interface for a PROCEDURE declaration,
4757 including brackets (R1212). */
4760 match_procedure_interface (gfc_symbol
**proc_if
)
4764 locus old_loc
, entry_loc
;
4765 gfc_namespace
*old_ns
= gfc_current_ns
;
4766 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4768 old_loc
= entry_loc
= gfc_current_locus
;
4769 gfc_clear_ts (¤t_ts
);
4771 if (gfc_match (" (") != MATCH_YES
)
4773 gfc_current_locus
= entry_loc
;
4777 /* Get the type spec. for the procedure interface. */
4778 old_loc
= gfc_current_locus
;
4779 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4780 gfc_gobble_whitespace ();
4781 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
4784 if (m
== MATCH_ERROR
)
4787 /* Procedure interface is itself a procedure. */
4788 gfc_current_locus
= old_loc
;
4789 m
= gfc_match_name (name
);
4791 /* First look to see if it is already accessible in the current
4792 namespace because it is use associated or contained. */
4794 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
4797 /* If it is still not found, then try the parent namespace, if it
4798 exists and create the symbol there if it is still not found. */
4799 if (gfc_current_ns
->parent
)
4800 gfc_current_ns
= gfc_current_ns
->parent
;
4801 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
4804 gfc_current_ns
= old_ns
;
4805 *proc_if
= st
->n
.sym
;
4810 /* Resolve interface if possible. That way, attr.procedure is only set
4811 if it is declared by a later procedure-declaration-stmt, which is
4812 invalid per F08:C1216 (cf. resolve_procedure_interface). */
4813 while ((*proc_if
)->ts
.interface
)
4814 *proc_if
= (*proc_if
)->ts
.interface
;
4816 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
4817 && (*proc_if
)->ts
.type
== BT_UNKNOWN
4818 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
4819 (*proc_if
)->name
, NULL
))
4824 if (gfc_match (" )") != MATCH_YES
)
4826 gfc_current_locus
= entry_loc
;
4834 /* Match a PROCEDURE declaration (R1211). */
4837 match_procedure_decl (void)
4840 gfc_symbol
*sym
, *proc_if
= NULL
;
4842 gfc_expr
*initializer
= NULL
;
4844 /* Parse interface (with brackets). */
4845 m
= match_procedure_interface (&proc_if
);
4849 /* Parse attributes (with colons). */
4850 m
= match_attr_spec();
4851 if (m
== MATCH_ERROR
)
4854 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
4856 current_attr
.is_bind_c
= 1;
4857 has_name_equals
= 0;
4858 curr_binding_label
= NULL
;
4861 /* Get procedure symbols. */
4864 m
= gfc_match_symbol (&sym
, 0);
4867 else if (m
== MATCH_ERROR
)
4870 /* Add current_attr to the symbol attributes. */
4871 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
4874 if (sym
->attr
.is_bind_c
)
4876 /* Check for C1218. */
4877 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
4879 gfc_error ("BIND(C) attribute at %C requires "
4880 "an interface with BIND(C)");
4883 /* Check for C1217. */
4884 if (has_name_equals
&& sym
->attr
.pointer
)
4886 gfc_error ("BIND(C) procedure with NAME may not have "
4887 "POINTER attribute at %C");
4890 if (has_name_equals
&& sym
->attr
.dummy
)
4892 gfc_error ("Dummy procedure at %C may not have "
4893 "BIND(C) attribute with NAME");
4896 /* Set binding label for BIND(C). */
4897 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
4901 if (!gfc_add_external (&sym
->attr
, NULL
))
4904 if (add_hidden_procptr_result (sym
))
4907 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
4910 /* Set interface. */
4911 if (proc_if
!= NULL
)
4913 if (sym
->ts
.type
!= BT_UNKNOWN
)
4915 gfc_error ("Procedure '%s' at %L already has basic type of %s",
4916 sym
->name
, &gfc_current_locus
,
4917 gfc_basic_typename (sym
->ts
.type
));
4920 sym
->ts
.interface
= proc_if
;
4921 sym
->attr
.untyped
= 1;
4922 sym
->attr
.if_source
= IFSRC_IFBODY
;
4924 else if (current_ts
.type
!= BT_UNKNOWN
)
4926 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
4928 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
4929 sym
->ts
.interface
->ts
= current_ts
;
4930 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
4931 sym
->ts
.interface
->attr
.function
= 1;
4932 sym
->attr
.function
= 1;
4933 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
4936 if (gfc_match (" =>") == MATCH_YES
)
4938 if (!current_attr
.pointer
)
4940 gfc_error ("Initialization at %C isn't for a pointer variable");
4945 m
= match_pointer_init (&initializer
, 1);
4949 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
4954 if (gfc_match_eos () == MATCH_YES
)
4956 if (gfc_match_char (',') != MATCH_YES
)
4961 gfc_error ("Syntax error in PROCEDURE statement at %C");
4965 /* Free stuff up and return. */
4966 gfc_free_expr (initializer
);
4972 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
4975 /* Match a procedure pointer component declaration (R445). */
4978 match_ppc_decl (void)
4981 gfc_symbol
*proc_if
= NULL
;
4985 gfc_expr
*initializer
= NULL
;
4986 gfc_typebound_proc
* tb
;
4987 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4989 /* Parse interface (with brackets). */
4990 m
= match_procedure_interface (&proc_if
);
4994 /* Parse attributes. */
4995 tb
= XCNEW (gfc_typebound_proc
);
4996 tb
->where
= gfc_current_locus
;
4997 m
= match_binding_attributes (tb
, false, true);
4998 if (m
== MATCH_ERROR
)
5001 gfc_clear_attr (¤t_attr
);
5002 current_attr
.procedure
= 1;
5003 current_attr
.proc_pointer
= 1;
5004 current_attr
.access
= tb
->access
;
5005 current_attr
.flavor
= FL_PROCEDURE
;
5007 /* Match the colons (required). */
5008 if (gfc_match (" ::") != MATCH_YES
)
5010 gfc_error ("Expected '::' after binding-attributes at %C");
5014 /* Check for C450. */
5015 if (!tb
->nopass
&& proc_if
== NULL
)
5017 gfc_error("NOPASS or explicit interface required at %C");
5021 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5024 /* Match PPC names. */
5028 m
= gfc_match_name (name
);
5031 else if (m
== MATCH_ERROR
)
5034 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5037 /* Add current_attr to the symbol attributes. */
5038 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5041 if (!gfc_add_external (&c
->attr
, NULL
))
5044 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5049 /* Set interface. */
5050 if (proc_if
!= NULL
)
5052 c
->ts
.interface
= proc_if
;
5053 c
->attr
.untyped
= 1;
5054 c
->attr
.if_source
= IFSRC_IFBODY
;
5056 else if (ts
.type
!= BT_UNKNOWN
)
5059 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5060 c
->ts
.interface
->result
= c
->ts
.interface
;
5061 c
->ts
.interface
->ts
= ts
;
5062 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5063 c
->ts
.interface
->attr
.function
= 1;
5064 c
->attr
.function
= 1;
5065 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5068 if (gfc_match (" =>") == MATCH_YES
)
5070 m
= match_pointer_init (&initializer
, 1);
5073 gfc_free_expr (initializer
);
5076 c
->initializer
= initializer
;
5079 if (gfc_match_eos () == MATCH_YES
)
5081 if (gfc_match_char (',') != MATCH_YES
)
5086 gfc_error ("Syntax error in procedure pointer component at %C");
5091 /* Match a PROCEDURE declaration inside an interface (R1206). */
5094 match_procedure_in_interface (void)
5098 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5101 if (current_interface
.type
== INTERFACE_NAMELESS
5102 || current_interface
.type
== INTERFACE_ABSTRACT
)
5104 gfc_error ("PROCEDURE at %C must be in a generic interface");
5108 /* Check if the F2008 optional double colon appears. */
5109 gfc_gobble_whitespace ();
5110 old_locus
= gfc_current_locus
;
5111 if (gfc_match ("::") == MATCH_YES
)
5113 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5114 "MODULE PROCEDURE statement at %L", &old_locus
))
5118 gfc_current_locus
= old_locus
;
5122 m
= gfc_match_name (name
);
5125 else if (m
== MATCH_ERROR
)
5127 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5130 if (!gfc_add_interface (sym
))
5133 if (gfc_match_eos () == MATCH_YES
)
5135 if (gfc_match_char (',') != MATCH_YES
)
5142 gfc_error ("Syntax error in PROCEDURE statement at %C");
5147 /* General matcher for PROCEDURE declarations. */
5149 static match
match_procedure_in_type (void);
5152 gfc_match_procedure (void)
5156 switch (gfc_current_state ())
5161 case COMP_SUBROUTINE
:
5164 m
= match_procedure_decl ();
5166 case COMP_INTERFACE
:
5167 m
= match_procedure_in_interface ();
5170 m
= match_ppc_decl ();
5172 case COMP_DERIVED_CONTAINS
:
5173 m
= match_procedure_in_type ();
5182 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5189 /* Warn if a matched procedure has the same name as an intrinsic; this is
5190 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5191 parser-state-stack to find out whether we're in a module. */
5194 warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5198 in_module
= (gfc_state_stack
->previous
5199 && gfc_state_stack
->previous
->state
== COMP_MODULE
);
5201 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5205 /* Match a function declaration. */
5208 gfc_match_function_decl (void)
5210 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5211 gfc_symbol
*sym
, *result
;
5215 match found_match
; /* Status returned by match func. */
5217 if (gfc_current_state () != COMP_NONE
5218 && gfc_current_state () != COMP_INTERFACE
5219 && gfc_current_state () != COMP_CONTAINS
)
5222 gfc_clear_ts (¤t_ts
);
5224 old_loc
= gfc_current_locus
;
5226 m
= gfc_match_prefix (¤t_ts
);
5229 gfc_current_locus
= old_loc
;
5233 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5235 gfc_current_locus
= old_loc
;
5238 if (get_proc_name (name
, &sym
, false))
5241 if (add_hidden_procptr_result (sym
))
5244 gfc_new_block
= sym
;
5246 m
= gfc_match_formal_arglist (sym
, 0, 0);
5249 gfc_error ("Expected formal argument list in function "
5250 "definition at %C");
5254 else if (m
== MATCH_ERROR
)
5259 /* According to the draft, the bind(c) and result clause can
5260 come in either order after the formal_arg_list (i.e., either
5261 can be first, both can exist together or by themselves or neither
5262 one). Therefore, the match_result can't match the end of the
5263 string, and check for the bind(c) or result clause in either order. */
5264 found_match
= gfc_match_eos ();
5266 /* Make sure that it isn't already declared as BIND(C). If it is, it
5267 must have been marked BIND(C) with a BIND(C) attribute and that is
5268 not allowed for procedures. */
5269 if (sym
->attr
.is_bind_c
== 1)
5271 sym
->attr
.is_bind_c
= 0;
5272 if (sym
->old_symbol
!= NULL
)
5273 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5274 "variables or common blocks",
5275 &(sym
->old_symbol
->declared_at
));
5277 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5278 "variables or common blocks", &gfc_current_locus
);
5281 if (found_match
!= MATCH_YES
)
5283 /* If we haven't found the end-of-statement, look for a suffix. */
5284 suffix_match
= gfc_match_suffix (sym
, &result
);
5285 if (suffix_match
== MATCH_YES
)
5286 /* Need to get the eos now. */
5287 found_match
= gfc_match_eos ();
5289 found_match
= suffix_match
;
5292 if(found_match
!= MATCH_YES
)
5296 /* Make changes to the symbol. */
5299 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5302 if (!gfc_missing_attr (&sym
->attr
, NULL
)
5303 || !copy_prefix (&sym
->attr
, &sym
->declared_at
))
5306 /* Delay matching the function characteristics until after the
5307 specification block by signalling kind=-1. */
5308 sym
->declared_at
= old_loc
;
5309 if (current_ts
.type
!= BT_UNKNOWN
)
5310 current_ts
.kind
= -1;
5312 current_ts
.kind
= 0;
5316 if (current_ts
.type
!= BT_UNKNOWN
5317 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5323 if (current_ts
.type
!= BT_UNKNOWN
5324 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5326 sym
->result
= result
;
5329 /* Warn if this procedure has the same name as an intrinsic. */
5330 warn_intrinsic_shadow (sym
, true);
5336 gfc_current_locus
= old_loc
;
5341 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5342 pass the name of the entry, rather than the gfc_current_block name, and
5343 to return false upon finding an existing global entry. */
5346 add_global_entry (const char *name
, int sub
)
5349 enum gfc_symbol_type type
;
5351 s
= gfc_get_gsymbol(name
);
5352 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5355 || (s
->type
!= GSYM_UNKNOWN
5356 && s
->type
!= type
))
5357 gfc_global_used(s
, NULL
);
5361 s
->where
= gfc_current_locus
;
5363 s
->ns
= gfc_current_ns
;
5370 /* Match an ENTRY statement. */
5373 gfc_match_entry (void)
5378 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5379 gfc_compile_state state
;
5383 bool module_procedure
;
5387 m
= gfc_match_name (name
);
5391 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
5394 state
= gfc_current_state ();
5395 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
5400 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
5403 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
5405 case COMP_BLOCK_DATA
:
5406 gfc_error ("ENTRY statement at %C cannot appear within "
5409 case COMP_INTERFACE
:
5410 gfc_error ("ENTRY statement at %C cannot appear within "
5414 gfc_error ("ENTRY statement at %C cannot appear within "
5415 "a DERIVED TYPE block");
5418 gfc_error ("ENTRY statement at %C cannot appear within "
5419 "an IF-THEN block");
5422 case COMP_DO_CONCURRENT
:
5423 gfc_error ("ENTRY statement at %C cannot appear within "
5427 gfc_error ("ENTRY statement at %C cannot appear within "
5431 gfc_error ("ENTRY statement at %C cannot appear within "
5435 gfc_error ("ENTRY statement at %C cannot appear within "
5439 gfc_error ("ENTRY statement at %C cannot appear within "
5440 "a contained subprogram");
5443 gfc_internal_error ("gfc_match_entry(): Bad state");
5448 module_procedure
= gfc_current_ns
->parent
!= NULL
5449 && gfc_current_ns
->parent
->proc_name
5450 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
5453 if (gfc_current_ns
->parent
!= NULL
5454 && gfc_current_ns
->parent
->proc_name
5455 && !module_procedure
)
5457 gfc_error("ENTRY statement at %C cannot appear in a "
5458 "contained procedure");
5462 /* Module function entries need special care in get_proc_name
5463 because previous references within the function will have
5464 created symbols attached to the current namespace. */
5465 if (get_proc_name (name
, &entry
,
5466 gfc_current_ns
->parent
!= NULL
5467 && module_procedure
))
5470 proc
= gfc_current_block ();
5472 /* Make sure that it isn't already declared as BIND(C). If it is, it
5473 must have been marked BIND(C) with a BIND(C) attribute and that is
5474 not allowed for procedures. */
5475 if (entry
->attr
.is_bind_c
== 1)
5477 entry
->attr
.is_bind_c
= 0;
5478 if (entry
->old_symbol
!= NULL
)
5479 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5480 "variables or common blocks",
5481 &(entry
->old_symbol
->declared_at
));
5483 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5484 "variables or common blocks", &gfc_current_locus
);
5487 /* Check what next non-whitespace character is so we can tell if there
5488 is the required parens if we have a BIND(C). */
5489 gfc_gobble_whitespace ();
5490 peek_char
= gfc_peek_ascii_char ();
5492 if (state
== COMP_SUBROUTINE
)
5494 /* An entry in a subroutine. */
5495 if (!gfc_current_ns
->parent
&& !add_global_entry (name
, 1))
5498 m
= gfc_match_formal_arglist (entry
, 0, 1);
5502 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
5503 never be an internal procedure. */
5504 is_bind_c
= gfc_match_bind_c (entry
, true);
5505 if (is_bind_c
== MATCH_ERROR
)
5507 if (is_bind_c
== MATCH_YES
)
5509 if (peek_char
!= '(')
5511 gfc_error ("Missing required parentheses before BIND(C) at %C");
5514 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
5515 &(entry
->declared_at
), 1))
5519 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5520 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
5525 /* An entry in a function.
5526 We need to take special care because writing
5531 ENTRY f() RESULT (r)
5533 ENTRY f RESULT (r). */
5534 if (!gfc_current_ns
->parent
&& !add_global_entry (name
, 0))
5537 old_loc
= gfc_current_locus
;
5538 if (gfc_match_eos () == MATCH_YES
)
5540 gfc_current_locus
= old_loc
;
5541 /* Match the empty argument list, and add the interface to
5543 m
= gfc_match_formal_arglist (entry
, 0, 1);
5546 m
= gfc_match_formal_arglist (entry
, 0, 0);
5553 if (gfc_match_eos () == MATCH_YES
)
5555 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5556 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5559 entry
->result
= entry
;
5563 m
= gfc_match_suffix (entry
, &result
);
5565 gfc_syntax_error (ST_ENTRY
);
5571 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
5572 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
5573 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
5575 entry
->result
= result
;
5579 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
5580 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
5582 entry
->result
= entry
;
5587 if (gfc_match_eos () != MATCH_YES
)
5589 gfc_syntax_error (ST_ENTRY
);
5593 entry
->attr
.recursive
= proc
->attr
.recursive
;
5594 entry
->attr
.elemental
= proc
->attr
.elemental
;
5595 entry
->attr
.pure
= proc
->attr
.pure
;
5597 el
= gfc_get_entry_list ();
5599 el
->next
= gfc_current_ns
->entries
;
5600 gfc_current_ns
->entries
= el
;
5602 el
->id
= el
->next
->id
+ 1;
5606 new_st
.op
= EXEC_ENTRY
;
5607 new_st
.ext
.entry
= el
;
5613 /* Match a subroutine statement, including optional prefixes. */
5616 gfc_match_subroutine (void)
5618 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5623 bool allow_binding_name
;
5625 if (gfc_current_state () != COMP_NONE
5626 && gfc_current_state () != COMP_INTERFACE
5627 && gfc_current_state () != COMP_CONTAINS
)
5630 m
= gfc_match_prefix (NULL
);
5634 m
= gfc_match ("subroutine% %n", name
);
5638 if (get_proc_name (name
, &sym
, false))
5641 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
5642 the symbol existed before. */
5643 sym
->declared_at
= gfc_current_locus
;
5645 if (add_hidden_procptr_result (sym
))
5648 gfc_new_block
= sym
;
5650 /* Check what next non-whitespace character is so we can tell if there
5651 is the required parens if we have a BIND(C). */
5652 gfc_gobble_whitespace ();
5653 peek_char
= gfc_peek_ascii_char ();
5655 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5658 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
5661 /* Make sure that it isn't already declared as BIND(C). If it is, it
5662 must have been marked BIND(C) with a BIND(C) attribute and that is
5663 not allowed for procedures. */
5664 if (sym
->attr
.is_bind_c
== 1)
5666 sym
->attr
.is_bind_c
= 0;
5667 if (sym
->old_symbol
!= NULL
)
5668 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5669 "variables or common blocks",
5670 &(sym
->old_symbol
->declared_at
));
5672 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5673 "variables or common blocks", &gfc_current_locus
);
5676 /* C binding names are not allowed for internal procedures. */
5677 if (gfc_current_state () == COMP_CONTAINS
5678 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5679 allow_binding_name
= false;
5681 allow_binding_name
= true;
5683 /* Here, we are just checking if it has the bind(c) attribute, and if
5684 so, then we need to make sure it's all correct. If it doesn't,
5685 we still need to continue matching the rest of the subroutine line. */
5686 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5687 if (is_bind_c
== MATCH_ERROR
)
5689 /* There was an attempt at the bind(c), but it was wrong. An
5690 error message should have been printed w/in the gfc_match_bind_c
5691 so here we'll just return the MATCH_ERROR. */
5695 if (is_bind_c
== MATCH_YES
)
5697 /* The following is allowed in the Fortran 2008 draft. */
5698 if (gfc_current_state () == COMP_CONTAINS
5699 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5700 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5701 "at %L may not be specified for an internal "
5702 "procedure", &gfc_current_locus
))
5705 if (peek_char
!= '(')
5707 gfc_error ("Missing required parentheses before BIND(C) at %C");
5710 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
5711 &(sym
->declared_at
), 1))
5715 if (gfc_match_eos () != MATCH_YES
)
5717 gfc_syntax_error (ST_SUBROUTINE
);
5721 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5724 /* Warn if it has the same name as an intrinsic. */
5725 warn_intrinsic_shadow (sym
, false);
5731 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
5732 given, and set the binding label in either the given symbol (if not
5733 NULL), or in the current_ts. The symbol may be NULL because we may
5734 encounter the BIND(C) before the declaration itself. Return
5735 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
5736 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
5737 or MATCH_YES if the specifier was correct and the binding label and
5738 bind(c) fields were set correctly for the given symbol or the
5739 current_ts. If allow_binding_name is false, no binding name may be
5743 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
5745 /* binding label, if exists */
5746 const char* binding_label
= NULL
;
5750 /* Initialize the flag that specifies whether we encountered a NAME=
5751 specifier or not. */
5752 has_name_equals
= 0;
5754 /* This much we have to be able to match, in this order, if
5755 there is a bind(c) label. */
5756 if (gfc_match (" bind ( c ") != MATCH_YES
)
5759 /* Now see if there is a binding label, or if we've reached the
5760 end of the bind(c) attribute without one. */
5761 if (gfc_match_char (',') == MATCH_YES
)
5763 if (gfc_match (" name = ") != MATCH_YES
)
5765 gfc_error ("Syntax error in NAME= specifier for binding label "
5767 /* should give an error message here */
5771 has_name_equals
= 1;
5773 /* Get the opening quote. */
5774 double_quote
= MATCH_YES
;
5775 single_quote
= MATCH_YES
;
5776 double_quote
= gfc_match_char ('"');
5777 if (double_quote
!= MATCH_YES
)
5778 single_quote
= gfc_match_char ('\'');
5779 if (double_quote
!= MATCH_YES
&& single_quote
!= MATCH_YES
)
5781 gfc_error ("Syntax error in NAME= specifier for binding label "
5786 /* Grab the binding label, using functions that will not lower
5787 case the names automatically. */
5788 if (gfc_match_name_C (&binding_label
) != MATCH_YES
)
5791 /* Get the closing quotation. */
5792 if (double_quote
== MATCH_YES
)
5794 if (gfc_match_char ('"') != MATCH_YES
)
5796 gfc_error ("Missing closing quote '\"' for binding label at %C");
5797 /* User started string with '"' so looked to match it. */
5803 if (gfc_match_char ('\'') != MATCH_YES
)
5805 gfc_error ("Missing closing quote '\'' for binding label at %C");
5806 /* User started string with "'" char. */
5812 /* Get the required right paren. */
5813 if (gfc_match_char (')') != MATCH_YES
)
5815 gfc_error ("Missing closing paren for binding label at %C");
5819 if (has_name_equals
&& !allow_binding_name
)
5821 gfc_error ("No binding name is allowed in BIND(C) at %C");
5825 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
5827 gfc_error ("For dummy procedure %s, no binding name is "
5828 "allowed in BIND(C) at %C", sym
->name
);
5833 /* Save the binding label to the symbol. If sym is null, we're
5834 probably matching the typespec attributes of a declaration and
5835 haven't gotten the name yet, and therefore, no symbol yet. */
5839 sym
->binding_label
= binding_label
;
5841 curr_binding_label
= binding_label
;
5843 else if (allow_binding_name
)
5845 /* No binding label, but if symbol isn't null, we
5846 can set the label for it here.
5847 If name="" or allow_binding_name is false, no C binding name is
5849 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
5850 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
5853 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
5854 && current_interface
.type
== INTERFACE_ABSTRACT
)
5856 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
5864 /* Return nonzero if we're currently compiling a contained procedure. */
5867 contained_procedure (void)
5869 gfc_state_data
*s
= gfc_state_stack
;
5871 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
5872 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
5878 /* Set the kind of each enumerator. The kind is selected such that it is
5879 interoperable with the corresponding C enumeration type, making
5880 sure that -fshort-enums is honored. */
5885 enumerator_history
*current_history
= NULL
;
5889 if (max_enum
== NULL
|| enum_history
== NULL
)
5892 if (!flag_short_enums
)
5898 kind
= gfc_integer_kinds
[i
++].kind
;
5900 while (kind
< gfc_c_int_kind
5901 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
5904 current_history
= enum_history
;
5905 while (current_history
!= NULL
)
5907 current_history
->sym
->ts
.kind
= kind
;
5908 current_history
= current_history
->next
;
5913 /* Match any of the various end-block statements. Returns the type of
5914 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
5915 and END BLOCK statements cannot be replaced by a single END statement. */
5918 gfc_match_end (gfc_statement
*st
)
5920 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5921 gfc_compile_state state
;
5923 const char *block_name
;
5927 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
5928 gfc_namespace
**nsp
;
5930 old_loc
= gfc_current_locus
;
5931 if (gfc_match ("end") != MATCH_YES
)
5934 state
= gfc_current_state ();
5935 block_name
= gfc_current_block () == NULL
5936 ? NULL
: gfc_current_block ()->name
;
5940 case COMP_ASSOCIATE
:
5942 if (!strncmp (block_name
, "block@", strlen("block@")))
5947 case COMP_DERIVED_CONTAINS
:
5948 state
= gfc_state_stack
->previous
->state
;
5949 block_name
= gfc_state_stack
->previous
->sym
== NULL
5950 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
5961 *st
= ST_END_PROGRAM
;
5962 target
= " program";
5966 case COMP_SUBROUTINE
:
5967 *st
= ST_END_SUBROUTINE
;
5968 target
= " subroutine";
5969 eos_ok
= !contained_procedure ();
5973 *st
= ST_END_FUNCTION
;
5974 target
= " function";
5975 eos_ok
= !contained_procedure ();
5978 case COMP_BLOCK_DATA
:
5979 *st
= ST_END_BLOCK_DATA
;
5980 target
= " block data";
5985 *st
= ST_END_MODULE
;
5990 case COMP_INTERFACE
:
5991 *st
= ST_END_INTERFACE
;
5992 target
= " interface";
5997 case COMP_DERIVED_CONTAINS
:
6003 case COMP_ASSOCIATE
:
6004 *st
= ST_END_ASSOCIATE
;
6005 target
= " associate";
6022 case COMP_DO_CONCURRENT
:
6029 *st
= ST_END_CRITICAL
;
6030 target
= " critical";
6035 case COMP_SELECT_TYPE
:
6036 *st
= ST_END_SELECT
;
6042 *st
= ST_END_FORALL
;
6057 last_initializer
= NULL
;
6059 gfc_free_enum_history ();
6063 gfc_error ("Unexpected END statement at %C");
6067 if (gfc_match_eos () == MATCH_YES
)
6069 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6071 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6072 "instead of %s statement at %L",
6073 gfc_ascii_statement(*st
), &old_loc
))
6078 /* We would have required END [something]. */
6079 gfc_error ("%s statement expected at %L",
6080 gfc_ascii_statement (*st
), &old_loc
);
6087 /* Verify that we've got the sort of end-block that we're expecting. */
6088 if (gfc_match (target
) != MATCH_YES
)
6090 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
6094 /* If we're at the end, make sure a block name wasn't required. */
6095 if (gfc_match_eos () == MATCH_YES
)
6098 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6099 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6100 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6106 gfc_error ("Expected block name of '%s' in %s statement at %C",
6107 block_name
, gfc_ascii_statement (*st
));
6112 /* END INTERFACE has a special handler for its several possible endings. */
6113 if (*st
== ST_END_INTERFACE
)
6114 return gfc_match_end_interface ();
6116 /* We haven't hit the end of statement, so what is left must be an
6118 m
= gfc_match_space ();
6120 m
= gfc_match_name (name
);
6123 gfc_error ("Expected terminating name at %C");
6127 if (block_name
== NULL
)
6130 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6132 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
6133 gfc_ascii_statement (*st
));
6136 /* Procedure pointer as function result. */
6137 else if (strcmp (block_name
, "ppr@") == 0
6138 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6140 gfc_error ("Expected label '%s' for %s statement at %C",
6141 gfc_current_block ()->ns
->proc_name
->name
,
6142 gfc_ascii_statement (*st
));
6146 if (gfc_match_eos () == MATCH_YES
)
6150 gfc_syntax_error (*st
);
6153 gfc_current_locus
= old_loc
;
6155 /* If we are missing an END BLOCK, we created a half-ready namespace.
6156 Remove it from the parent namespace's sibling list. */
6158 if (state
== COMP_BLOCK
)
6160 parent_ns
= gfc_current_ns
->parent
;
6162 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6168 if (ns
== gfc_current_ns
)
6170 if (prev_ns
== NULL
)
6173 prev_ns
->sibling
= ns
->sibling
;
6179 gfc_free_namespace (gfc_current_ns
);
6180 gfc_current_ns
= parent_ns
;
6188 /***************** Attribute declaration statements ****************/
6190 /* Set the attribute of a single variable. */
6195 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6203 m
= gfc_match_name (name
);
6207 if (find_special (name
, &sym
, false))
6210 if (!check_function_name (name
))
6216 var_locus
= gfc_current_locus
;
6218 /* Deal with possible array specification for certain attributes. */
6219 if (current_attr
.dimension
6220 || current_attr
.codimension
6221 || current_attr
.allocatable
6222 || current_attr
.pointer
6223 || current_attr
.target
)
6225 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
6226 !current_attr
.dimension
6227 && !current_attr
.pointer
6228 && !current_attr
.target
);
6229 if (m
== MATCH_ERROR
)
6232 if (current_attr
.dimension
&& m
== MATCH_NO
)
6234 gfc_error ("Missing array specification at %L in DIMENSION "
6235 "statement", &var_locus
);
6240 if (current_attr
.dimension
&& sym
->value
)
6242 gfc_error ("Dimensions specified for %s at %L after its "
6243 "initialisation", sym
->name
, &var_locus
);
6248 if (current_attr
.codimension
&& m
== MATCH_NO
)
6250 gfc_error ("Missing array specification at %L in CODIMENSION "
6251 "statement", &var_locus
);
6256 if ((current_attr
.allocatable
|| current_attr
.pointer
)
6257 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
6259 gfc_error ("Array specification must be deferred at %L", &var_locus
);
6265 /* Update symbol table. DIMENSION attribute is set in
6266 gfc_set_array_spec(). For CLASS variables, this must be applied
6267 to the first component, or '_data' field. */
6268 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
6270 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
6278 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
6279 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
6286 if (sym
->ts
.type
== BT_CLASS
6287 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
, false))
6293 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
6299 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
6301 /* Fix the array spec. */
6302 m
= gfc_mod_pointee_as (sym
->as
);
6303 if (m
== MATCH_ERROR
)
6307 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
6313 if ((current_attr
.external
|| current_attr
.intrinsic
)
6314 && sym
->attr
.flavor
!= FL_PROCEDURE
6315 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
6321 add_hidden_procptr_result (sym
);
6326 gfc_free_array_spec (as
);
6331 /* Generic attribute declaration subroutine. Used for attributes that
6332 just have a list of names. */
6339 /* Gobble the optional double colon, by simply ignoring the result
6349 if (gfc_match_eos () == MATCH_YES
)
6355 if (gfc_match_char (',') != MATCH_YES
)
6357 gfc_error ("Unexpected character in variable list at %C");
6367 /* This routine matches Cray Pointer declarations of the form:
6368 pointer ( <pointer>, <pointee> )
6370 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
6371 The pointer, if already declared, should be an integer. Otherwise, we
6372 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
6373 be either a scalar, or an array declaration. No space is allocated for
6374 the pointee. For the statement
6375 pointer (ipt, ar(10))
6376 any subsequent uses of ar will be translated (in C-notation) as
6377 ar(i) => ((<type> *) ipt)(i)
6378 After gimplification, pointee variable will disappear in the code. */
6381 cray_pointer_decl (void)
6384 gfc_array_spec
*as
= NULL
;
6385 gfc_symbol
*cptr
; /* Pointer symbol. */
6386 gfc_symbol
*cpte
; /* Pointee symbol. */
6392 if (gfc_match_char ('(') != MATCH_YES
)
6394 gfc_error ("Expected '(' at %C");
6398 /* Match pointer. */
6399 var_locus
= gfc_current_locus
;
6400 gfc_clear_attr (¤t_attr
);
6401 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
6402 current_ts
.type
= BT_INTEGER
;
6403 current_ts
.kind
= gfc_index_integer_kind
;
6405 m
= gfc_match_symbol (&cptr
, 0);
6408 gfc_error ("Expected variable name at %C");
6412 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
6415 gfc_set_sym_referenced (cptr
);
6417 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
6419 cptr
->ts
.type
= BT_INTEGER
;
6420 cptr
->ts
.kind
= gfc_index_integer_kind
;
6422 else if (cptr
->ts
.type
!= BT_INTEGER
)
6424 gfc_error ("Cray pointer at %C must be an integer");
6427 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
6428 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
6429 " memory addresses require %d bytes",
6430 cptr
->ts
.kind
, gfc_index_integer_kind
);
6432 if (gfc_match_char (',') != MATCH_YES
)
6434 gfc_error ("Expected \",\" at %C");
6438 /* Match Pointee. */
6439 var_locus
= gfc_current_locus
;
6440 gfc_clear_attr (¤t_attr
);
6441 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
6442 current_ts
.type
= BT_UNKNOWN
;
6443 current_ts
.kind
= 0;
6445 m
= gfc_match_symbol (&cpte
, 0);
6448 gfc_error ("Expected variable name at %C");
6452 /* Check for an optional array spec. */
6453 m
= gfc_match_array_spec (&as
, true, false);
6454 if (m
== MATCH_ERROR
)
6456 gfc_free_array_spec (as
);
6459 else if (m
== MATCH_NO
)
6461 gfc_free_array_spec (as
);
6465 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
6468 gfc_set_sym_referenced (cpte
);
6470 if (cpte
->as
== NULL
)
6472 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
6473 gfc_internal_error ("Couldn't set Cray pointee array spec.");
6475 else if (as
!= NULL
)
6477 gfc_error ("Duplicate array spec for Cray pointee at %C");
6478 gfc_free_array_spec (as
);
6484 if (cpte
->as
!= NULL
)
6486 /* Fix array spec. */
6487 m
= gfc_mod_pointee_as (cpte
->as
);
6488 if (m
== MATCH_ERROR
)
6492 /* Point the Pointee at the Pointer. */
6493 cpte
->cp_pointer
= cptr
;
6495 if (gfc_match_char (')') != MATCH_YES
)
6497 gfc_error ("Expected \")\" at %C");
6500 m
= gfc_match_char (',');
6502 done
= true; /* Stop searching for more declarations. */
6506 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
6507 || gfc_match_eos () != MATCH_YES
)
6509 gfc_error ("Expected \",\" or end of statement at %C");
6517 gfc_match_external (void)
6520 gfc_clear_attr (¤t_attr
);
6521 current_attr
.external
= 1;
6523 return attr_decl ();
6528 gfc_match_intent (void)
6532 /* This is not allowed within a BLOCK construct! */
6533 if (gfc_current_state () == COMP_BLOCK
)
6535 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
6539 intent
= match_intent_spec ();
6540 if (intent
== INTENT_UNKNOWN
)
6543 gfc_clear_attr (¤t_attr
);
6544 current_attr
.intent
= intent
;
6546 return attr_decl ();
6551 gfc_match_intrinsic (void)
6554 gfc_clear_attr (¤t_attr
);
6555 current_attr
.intrinsic
= 1;
6557 return attr_decl ();
6562 gfc_match_optional (void)
6564 /* This is not allowed within a BLOCK construct! */
6565 if (gfc_current_state () == COMP_BLOCK
)
6567 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
6571 gfc_clear_attr (¤t_attr
);
6572 current_attr
.optional
= 1;
6574 return attr_decl ();
6579 gfc_match_pointer (void)
6581 gfc_gobble_whitespace ();
6582 if (gfc_peek_ascii_char () == '(')
6584 if (!gfc_option
.flag_cray_pointer
)
6586 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
6590 return cray_pointer_decl ();
6594 gfc_clear_attr (¤t_attr
);
6595 current_attr
.pointer
= 1;
6597 return attr_decl ();
6603 gfc_match_allocatable (void)
6605 gfc_clear_attr (¤t_attr
);
6606 current_attr
.allocatable
= 1;
6608 return attr_decl ();
6613 gfc_match_codimension (void)
6615 gfc_clear_attr (¤t_attr
);
6616 current_attr
.codimension
= 1;
6618 return attr_decl ();
6623 gfc_match_contiguous (void)
6625 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
6628 gfc_clear_attr (¤t_attr
);
6629 current_attr
.contiguous
= 1;
6631 return attr_decl ();
6636 gfc_match_dimension (void)
6638 gfc_clear_attr (¤t_attr
);
6639 current_attr
.dimension
= 1;
6641 return attr_decl ();
6646 gfc_match_target (void)
6648 gfc_clear_attr (¤t_attr
);
6649 current_attr
.target
= 1;
6651 return attr_decl ();
6655 /* Match the list of entities being specified in a PUBLIC or PRIVATE
6659 access_attr_decl (gfc_statement st
)
6661 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6662 interface_type type
;
6664 gfc_symbol
*sym
, *dt_sym
;
6665 gfc_intrinsic_op op
;
6668 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6673 m
= gfc_match_generic_spec (&type
, name
, &op
);
6676 if (m
== MATCH_ERROR
)
6681 case INTERFACE_NAMELESS
:
6682 case INTERFACE_ABSTRACT
:
6685 case INTERFACE_GENERIC
:
6686 if (gfc_get_symbol (name
, NULL
, &sym
))
6689 if (!gfc_add_access (&sym
->attr
,
6691 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6695 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
6696 && !gfc_add_access (&dt_sym
->attr
,
6698 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
6704 case INTERFACE_INTRINSIC_OP
:
6705 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
6707 gfc_intrinsic_op other_op
;
6709 gfc_current_ns
->operator_access
[op
] =
6710 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6712 /* Handle the case if there is another op with the same
6713 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
6714 other_op
= gfc_equivalent_op (op
);
6716 if (other_op
!= INTRINSIC_NONE
)
6717 gfc_current_ns
->operator_access
[other_op
] =
6718 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6723 gfc_error ("Access specification of the %s operator at %C has "
6724 "already been specified", gfc_op2string (op
));
6730 case INTERFACE_USER_OP
:
6731 uop
= gfc_get_uop (name
);
6733 if (uop
->access
== ACCESS_UNKNOWN
)
6735 uop
->access
= (st
== ST_PUBLIC
)
6736 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
6740 gfc_error ("Access specification of the .%s. operator at %C "
6741 "has already been specified", sym
->name
);
6748 if (gfc_match_char (',') == MATCH_NO
)
6752 if (gfc_match_eos () != MATCH_YES
)
6757 gfc_syntax_error (st
);
6765 gfc_match_protected (void)
6770 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6772 gfc_error ("PROTECTED at %C only allowed in specification "
6773 "part of a module");
6778 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
6781 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
6786 if (gfc_match_eos () == MATCH_YES
)
6791 m
= gfc_match_symbol (&sym
, 0);
6795 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
6807 if (gfc_match_eos () == MATCH_YES
)
6809 if (gfc_match_char (',') != MATCH_YES
)
6816 gfc_error ("Syntax error in PROTECTED statement at %C");
6821 /* The PRIVATE statement is a bit weird in that it can be an attribute
6822 declaration, but also works as a standalone statement inside of a
6823 type declaration or a module. */
6826 gfc_match_private (gfc_statement
*st
)
6829 if (gfc_match ("private") != MATCH_YES
)
6832 if (gfc_current_state () != COMP_MODULE
6833 && !(gfc_current_state () == COMP_DERIVED
6834 && gfc_state_stack
->previous
6835 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
6836 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
6837 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
6838 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
6840 gfc_error ("PRIVATE statement at %C is only allowed in the "
6841 "specification part of a module");
6845 if (gfc_current_state () == COMP_DERIVED
)
6847 if (gfc_match_eos () == MATCH_YES
)
6853 gfc_syntax_error (ST_PRIVATE
);
6857 if (gfc_match_eos () == MATCH_YES
)
6864 return access_attr_decl (ST_PRIVATE
);
6869 gfc_match_public (gfc_statement
*st
)
6872 if (gfc_match ("public") != MATCH_YES
)
6875 if (gfc_current_state () != COMP_MODULE
)
6877 gfc_error ("PUBLIC statement at %C is only allowed in the "
6878 "specification part of a module");
6882 if (gfc_match_eos () == MATCH_YES
)
6889 return access_attr_decl (ST_PUBLIC
);
6893 /* Workhorse for gfc_match_parameter. */
6903 m
= gfc_match_symbol (&sym
, 0);
6905 gfc_error ("Expected variable name at %C in PARAMETER statement");
6910 if (gfc_match_char ('=') == MATCH_NO
)
6912 gfc_error ("Expected = sign in PARAMETER statement at %C");
6916 m
= gfc_match_init_expr (&init
);
6918 gfc_error ("Expected expression at %C in PARAMETER statement");
6922 if (sym
->ts
.type
== BT_UNKNOWN
6923 && !gfc_set_default_type (sym
, 1, NULL
))
6929 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
6930 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
6938 gfc_error ("Initializing already initialized variable at %C");
6943 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
6944 return (t
) ? MATCH_YES
: MATCH_ERROR
;
6947 gfc_free_expr (init
);
6952 /* Match a parameter statement, with the weird syntax that these have. */
6955 gfc_match_parameter (void)
6959 if (gfc_match_char ('(') == MATCH_NO
)
6968 if (gfc_match (" )%t") == MATCH_YES
)
6971 if (gfc_match_char (',') != MATCH_YES
)
6973 gfc_error ("Unexpected characters in PARAMETER statement at %C");
6983 /* Save statements have a special syntax. */
6986 gfc_match_save (void)
6988 char n
[GFC_MAX_SYMBOL_LEN
+1];
6993 if (gfc_match_eos () == MATCH_YES
)
6995 if (gfc_current_ns
->seen_save
)
6997 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
6998 "follows previous SAVE statement"))
7002 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7006 if (gfc_current_ns
->save_all
)
7008 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7009 "blanket SAVE statement"))
7017 m
= gfc_match_symbol (&sym
, 0);
7021 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7022 &gfc_current_locus
))
7033 m
= gfc_match (" / %n /", &n
);
7034 if (m
== MATCH_ERROR
)
7039 c
= gfc_get_common (n
, 0);
7042 gfc_current_ns
->seen_save
= 1;
7045 if (gfc_match_eos () == MATCH_YES
)
7047 if (gfc_match_char (',') != MATCH_YES
)
7054 gfc_error ("Syntax error in SAVE statement at %C");
7060 gfc_match_value (void)
7065 /* This is not allowed within a BLOCK construct! */
7066 if (gfc_current_state () == COMP_BLOCK
)
7068 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7072 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7075 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7080 if (gfc_match_eos () == MATCH_YES
)
7085 m
= gfc_match_symbol (&sym
, 0);
7089 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7101 if (gfc_match_eos () == MATCH_YES
)
7103 if (gfc_match_char (',') != MATCH_YES
)
7110 gfc_error ("Syntax error in VALUE statement at %C");
7116 gfc_match_volatile (void)
7121 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7124 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7129 if (gfc_match_eos () == MATCH_YES
)
7134 /* VOLATILE is special because it can be added to host-associated
7135 symbols locally. Except for coarrays. */
7136 m
= gfc_match_symbol (&sym
, 1);
7140 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7141 for variable in a BLOCK which is defined outside of the BLOCK. */
7142 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7144 gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
7145 "%C, which is use-/host-associated", sym
->name
);
7148 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7160 if (gfc_match_eos () == MATCH_YES
)
7162 if (gfc_match_char (',') != MATCH_YES
)
7169 gfc_error ("Syntax error in VOLATILE statement at %C");
7175 gfc_match_asynchronous (void)
7180 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7183 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7188 if (gfc_match_eos () == MATCH_YES
)
7193 /* ASYNCHRONOUS is special because it can be added to host-associated
7195 m
= gfc_match_symbol (&sym
, 1);
7199 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7211 if (gfc_match_eos () == MATCH_YES
)
7213 if (gfc_match_char (',') != MATCH_YES
)
7220 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
7225 /* Match a module procedure statement. Note that we have to modify
7226 symbols in the parent's namespace because the current one was there
7227 to receive symbols that are in an interface's formal argument list. */
7230 gfc_match_modproc (void)
7232 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7236 gfc_namespace
*module_ns
;
7237 gfc_interface
*old_interface_head
, *interface
;
7239 if (gfc_state_stack
->state
!= COMP_INTERFACE
7240 || gfc_state_stack
->previous
== NULL
7241 || current_interface
.type
== INTERFACE_NAMELESS
7242 || current_interface
.type
== INTERFACE_ABSTRACT
)
7244 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
7249 module_ns
= gfc_current_ns
->parent
;
7250 for (; module_ns
; module_ns
= module_ns
->parent
)
7251 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
7252 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7253 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
7254 && !module_ns
->proc_name
->attr
.contained
))
7257 if (module_ns
== NULL
)
7260 /* Store the current state of the interface. We will need it if we
7261 end up with a syntax error and need to recover. */
7262 old_interface_head
= gfc_current_interface_head ();
7264 /* Check if the F2008 optional double colon appears. */
7265 gfc_gobble_whitespace ();
7266 old_locus
= gfc_current_locus
;
7267 if (gfc_match ("::") == MATCH_YES
)
7269 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7270 "MODULE PROCEDURE statement at %L", &old_locus
))
7274 gfc_current_locus
= old_locus
;
7279 old_locus
= gfc_current_locus
;
7281 m
= gfc_match_name (name
);
7287 /* Check for syntax error before starting to add symbols to the
7288 current namespace. */
7289 if (gfc_match_eos () == MATCH_YES
)
7292 if (!last
&& gfc_match_char (',') != MATCH_YES
)
7295 /* Now we're sure the syntax is valid, we process this item
7297 if (gfc_get_symbol (name
, module_ns
, &sym
))
7300 if (sym
->attr
.intrinsic
)
7302 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
7303 "PROCEDURE", &old_locus
);
7307 if (sym
->attr
.proc
!= PROC_MODULE
7308 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
7311 if (!gfc_add_interface (sym
))
7314 sym
->attr
.mod_proc
= 1;
7315 sym
->declared_at
= old_locus
;
7324 /* Restore the previous state of the interface. */
7325 interface
= gfc_current_interface_head ();
7326 gfc_set_current_interface_head (old_interface_head
);
7328 /* Free the new interfaces. */
7329 while (interface
!= old_interface_head
)
7331 gfc_interface
*i
= interface
->next
;
7336 /* And issue a syntax error. */
7337 gfc_syntax_error (ST_MODULE_PROC
);
7342 /* Check a derived type that is being extended. */
7344 check_extended_derived_type (char *name
)
7346 gfc_symbol
*extended
;
7348 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
7350 gfc_error ("Ambiguous symbol in TYPE definition at %C");
7356 gfc_error ("No such symbol in TYPE definition at %C");
7360 extended
= gfc_find_dt_in_generic (extended
);
7362 if (extended
->attr
.flavor
!= FL_DERIVED
)
7364 gfc_error ("'%s' in EXTENDS expression at %C is not a "
7365 "derived type", name
);
7369 if (extended
->attr
.is_bind_c
)
7371 gfc_error ("'%s' cannot be extended at %C because it "
7372 "is BIND(C)", extended
->name
);
7376 if (extended
->attr
.sequence
)
7378 gfc_error ("'%s' cannot be extended at %C because it "
7379 "is a SEQUENCE type", extended
->name
);
7387 /* Match the optional attribute specifiers for a type declaration.
7388 Return MATCH_ERROR if an error is encountered in one of the handled
7389 attributes (public, private, bind(c)), MATCH_NO if what's found is
7390 not a handled attribute, and MATCH_YES otherwise. TODO: More error
7391 checking on attribute conflicts needs to be done. */
7394 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
7396 /* See if the derived type is marked as private. */
7397 if (gfc_match (" , private") == MATCH_YES
)
7399 if (gfc_current_state () != COMP_MODULE
)
7401 gfc_error ("Derived type at %C can only be PRIVATE in the "
7402 "specification part of a module");
7406 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
7409 else if (gfc_match (" , public") == MATCH_YES
)
7411 if (gfc_current_state () != COMP_MODULE
)
7413 gfc_error ("Derived type at %C can only be PUBLIC in the "
7414 "specification part of a module");
7418 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
7421 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
7423 /* If the type is defined to be bind(c) it then needs to make
7424 sure that all fields are interoperable. This will
7425 need to be a semantic check on the finished derived type.
7426 See 15.2.3 (lines 9-12) of F2003 draft. */
7427 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
7430 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
7432 else if (gfc_match (" , abstract") == MATCH_YES
)
7434 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
7437 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
7440 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
7442 if (!gfc_add_extension (attr
, &gfc_current_locus
))
7448 /* If we get here, something matched. */
7453 /* Match the beginning of a derived type declaration. If a type name
7454 was the result of a function, then it is possible to have a symbol
7455 already to be known as a derived type yet have no components. */
7458 gfc_match_derived_decl (void)
7460 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7461 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
7462 symbol_attribute attr
;
7463 gfc_symbol
*sym
, *gensym
;
7464 gfc_symbol
*extended
;
7466 match is_type_attr_spec
= MATCH_NO
;
7467 bool seen_attr
= false;
7468 gfc_interface
*intr
= NULL
, *head
;
7470 if (gfc_current_state () == COMP_DERIVED
)
7475 gfc_clear_attr (&attr
);
7480 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
7481 if (is_type_attr_spec
== MATCH_ERROR
)
7483 if (is_type_attr_spec
== MATCH_YES
)
7485 } while (is_type_attr_spec
== MATCH_YES
);
7487 /* Deal with derived type extensions. The extension attribute has
7488 been added to 'attr' but now the parent type must be found and
7491 extended
= check_extended_derived_type (parent
);
7493 if (parent
[0] && !extended
)
7496 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
7498 gfc_error ("Expected :: in TYPE definition at %C");
7502 m
= gfc_match (" %n%t", name
);
7506 /* Make sure the name is not the name of an intrinsic type. */
7507 if (gfc_is_intrinsic_typename (name
))
7509 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
7514 if (gfc_get_symbol (name
, NULL
, &gensym
))
7517 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
7519 gfc_error ("Derived type name '%s' at %C already has a basic type "
7520 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
7524 if (!gensym
->attr
.generic
7525 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
7528 if (!gensym
->attr
.function
7529 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
7532 sym
= gfc_find_dt_in_generic (gensym
);
7534 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
7536 gfc_error ("Derived type definition of '%s' at %C has already been "
7537 "defined", sym
->name
);
7543 /* Use upper case to save the actual derived-type symbol. */
7544 gfc_get_symbol (gfc_get_string ("%c%s",
7545 (char) TOUPPER ((unsigned char) gensym
->name
[0]),
7546 &gensym
->name
[1]), NULL
, &sym
);
7547 sym
->name
= gfc_get_string (gensym
->name
);
7548 head
= gensym
->generic
;
7549 intr
= gfc_get_interface ();
7551 intr
->where
= gfc_current_locus
;
7552 intr
->sym
->declared_at
= gfc_current_locus
;
7554 gensym
->generic
= intr
;
7555 gensym
->attr
.if_source
= IFSRC_DECL
;
7558 /* The symbol may already have the derived attribute without the
7559 components. The ways this can happen is via a function
7560 definition, an INTRINSIC statement or a subtype in another
7561 derived type that is a pointer. The first part of the AND clause
7562 is true if the symbol is not the return value of a function. */
7563 if (sym
->attr
.flavor
!= FL_DERIVED
7564 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
7567 if (attr
.access
!= ACCESS_UNKNOWN
7568 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
7570 else if (sym
->attr
.access
== ACCESS_UNKNOWN
7571 && gensym
->attr
.access
!= ACCESS_UNKNOWN
7572 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
7576 if (sym
->attr
.access
!= ACCESS_UNKNOWN
7577 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
7578 gensym
->attr
.access
= sym
->attr
.access
;
7580 /* See if the derived type was labeled as bind(c). */
7581 if (attr
.is_bind_c
!= 0)
7582 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
7584 /* Construct the f2k_derived namespace if it is not yet there. */
7585 if (!sym
->f2k_derived
)
7586 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7588 if (extended
&& !sym
->components
)
7593 /* Add the extended derived type as the first component. */
7594 gfc_add_component (sym
, parent
, &p
);
7596 gfc_set_sym_referenced (extended
);
7598 p
->ts
.type
= BT_DERIVED
;
7599 p
->ts
.u
.derived
= extended
;
7600 p
->initializer
= gfc_default_initializer (&p
->ts
);
7602 /* Set extension level. */
7603 if (extended
->attr
.extension
== 255)
7605 /* Since the extension field is 8 bit wide, we can only have
7606 up to 255 extension levels. */
7607 gfc_error ("Maximum extension level reached with type '%s' at %L",
7608 extended
->name
, &extended
->declared_at
);
7611 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
7613 /* Provide the links between the extended type and its extension. */
7614 if (!extended
->f2k_derived
)
7615 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
7616 st
= gfc_new_symtree (&extended
->f2k_derived
->sym_root
, sym
->name
);
7620 if (!sym
->hash_value
)
7621 /* Set the hash for the compound name for this type. */
7622 sym
->hash_value
= gfc_hash_value (sym
);
7624 /* Take over the ABSTRACT attribute. */
7625 sym
->attr
.abstract
= attr
.abstract
;
7627 gfc_new_block
= sym
;
7633 /* Cray Pointees can be declared as:
7634 pointer (ipt, a (n,m,...,*)) */
7637 gfc_mod_pointee_as (gfc_array_spec
*as
)
7639 as
->cray_pointee
= true; /* This will be useful to know later. */
7640 if (as
->type
== AS_ASSUMED_SIZE
)
7641 as
->cp_was_assumed
= true;
7642 else if (as
->type
== AS_ASSUMED_SHAPE
)
7644 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
7651 /* Match the enum definition statement, here we are trying to match
7652 the first line of enum definition statement.
7653 Returns MATCH_YES if match is found. */
7656 gfc_match_enum (void)
7660 m
= gfc_match_eos ();
7664 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
7671 /* Returns an initializer whose value is one higher than the value of the
7672 LAST_INITIALIZER argument. If the argument is NULL, the
7673 initializers value will be set to zero. The initializer's kind
7674 will be set to gfc_c_int_kind.
7676 If -fshort-enums is given, the appropriate kind will be selected
7677 later after all enumerators have been parsed. A warning is issued
7678 here if an initializer exceeds gfc_c_int_kind. */
7681 enum_initializer (gfc_expr
*last_initializer
, locus where
)
7684 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
7686 mpz_init (result
->value
.integer
);
7688 if (last_initializer
!= NULL
)
7690 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
7691 result
->where
= last_initializer
->where
;
7693 if (gfc_check_integer_range (result
->value
.integer
,
7694 gfc_c_int_kind
) != ARITH_OK
)
7696 gfc_error ("Enumerator exceeds the C integer type at %C");
7702 /* Control comes here, if it's the very first enumerator and no
7703 initializer has been given. It will be initialized to zero. */
7704 mpz_set_si (result
->value
.integer
, 0);
7711 /* Match a variable name with an optional initializer. When this
7712 subroutine is called, a variable is expected to be parsed next.
7713 Depending on what is happening at the moment, updates either the
7714 symbol table or the current interface. */
7717 enumerator_decl (void)
7719 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7720 gfc_expr
*initializer
;
7721 gfc_array_spec
*as
= NULL
;
7729 old_locus
= gfc_current_locus
;
7731 /* When we get here, we've just matched a list of attributes and
7732 maybe a type and a double colon. The next thing we expect to see
7733 is the name of the symbol. */
7734 m
= gfc_match_name (name
);
7738 var_locus
= gfc_current_locus
;
7740 /* OK, we've successfully matched the declaration. Now put the
7741 symbol in the current namespace. If we fail to create the symbol,
7743 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
7749 /* The double colon must be present in order to have initializers.
7750 Otherwise the statement is ambiguous with an assignment statement. */
7753 if (gfc_match_char ('=') == MATCH_YES
)
7755 m
= gfc_match_init_expr (&initializer
);
7758 gfc_error ("Expected an initialization expression at %C");
7767 /* If we do not have an initializer, the initialization value of the
7768 previous enumerator (stored in last_initializer) is incremented
7769 by 1 and is used to initialize the current enumerator. */
7770 if (initializer
== NULL
)
7771 initializer
= enum_initializer (last_initializer
, old_locus
);
7773 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
7775 gfc_error ("ENUMERATOR %L not initialized with integer expression",
7781 /* Store this current initializer, for the next enumerator variable
7782 to be parsed. add_init_expr_to_sym() zeros initializer, so we
7783 use last_initializer below. */
7784 last_initializer
= initializer
;
7785 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
7787 /* Maintain enumerator history. */
7788 gfc_find_symbol (name
, NULL
, 0, &sym
);
7789 create_enum_history (sym
, last_initializer
);
7791 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7794 /* Free stuff up and return. */
7795 gfc_free_expr (initializer
);
7801 /* Match the enumerator definition statement. */
7804 gfc_match_enumerator_def (void)
7809 gfc_clear_ts (¤t_ts
);
7811 m
= gfc_match (" enumerator");
7815 m
= gfc_match (" :: ");
7816 if (m
== MATCH_ERROR
)
7819 colon_seen
= (m
== MATCH_YES
);
7821 if (gfc_current_state () != COMP_ENUM
)
7823 gfc_error ("ENUM definition statement expected before %C");
7824 gfc_free_enum_history ();
7828 (¤t_ts
)->type
= BT_INTEGER
;
7829 (¤t_ts
)->kind
= gfc_c_int_kind
;
7831 gfc_clear_attr (¤t_attr
);
7832 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
7841 m
= enumerator_decl ();
7842 if (m
== MATCH_ERROR
)
7844 gfc_free_enum_history ();
7850 if (gfc_match_eos () == MATCH_YES
)
7852 if (gfc_match_char (',') != MATCH_YES
)
7856 if (gfc_current_state () == COMP_ENUM
)
7858 gfc_free_enum_history ();
7859 gfc_error ("Syntax error in ENUMERATOR definition at %C");
7864 gfc_free_array_spec (current_as
);
7871 /* Match binding attributes. */
7874 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
7876 bool found_passing
= false;
7877 bool seen_ptr
= false;
7878 match m
= MATCH_YES
;
7880 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
7881 this case the defaults are in there. */
7882 ba
->access
= ACCESS_UNKNOWN
;
7883 ba
->pass_arg
= NULL
;
7884 ba
->pass_arg_num
= 0;
7886 ba
->non_overridable
= 0;
7890 /* If we find a comma, we believe there are binding attributes. */
7891 m
= gfc_match_char (',');
7897 /* Access specifier. */
7899 m
= gfc_match (" public");
7900 if (m
== MATCH_ERROR
)
7904 if (ba
->access
!= ACCESS_UNKNOWN
)
7906 gfc_error ("Duplicate access-specifier at %C");
7910 ba
->access
= ACCESS_PUBLIC
;
7914 m
= gfc_match (" private");
7915 if (m
== MATCH_ERROR
)
7919 if (ba
->access
!= ACCESS_UNKNOWN
)
7921 gfc_error ("Duplicate access-specifier at %C");
7925 ba
->access
= ACCESS_PRIVATE
;
7929 /* If inside GENERIC, the following is not allowed. */
7934 m
= gfc_match (" nopass");
7935 if (m
== MATCH_ERROR
)
7941 gfc_error ("Binding attributes already specify passing,"
7942 " illegal NOPASS at %C");
7946 found_passing
= true;
7951 /* PASS possibly including argument. */
7952 m
= gfc_match (" pass");
7953 if (m
== MATCH_ERROR
)
7957 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
7961 gfc_error ("Binding attributes already specify passing,"
7962 " illegal PASS at %C");
7966 m
= gfc_match (" ( %n )", arg
);
7967 if (m
== MATCH_ERROR
)
7970 ba
->pass_arg
= gfc_get_string (arg
);
7971 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
7973 found_passing
= true;
7981 m
= gfc_match (" pointer");
7982 if (m
== MATCH_ERROR
)
7988 gfc_error ("Duplicate POINTER attribute at %C");
7998 /* NON_OVERRIDABLE flag. */
7999 m
= gfc_match (" non_overridable");
8000 if (m
== MATCH_ERROR
)
8004 if (ba
->non_overridable
)
8006 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
8010 ba
->non_overridable
= 1;
8014 /* DEFERRED flag. */
8015 m
= gfc_match (" deferred");
8016 if (m
== MATCH_ERROR
)
8022 gfc_error ("Duplicate DEFERRED at %C");
8033 /* Nothing matching found. */
8035 gfc_error ("Expected access-specifier at %C");
8037 gfc_error ("Expected binding attribute at %C");
8040 while (gfc_match_char (',') == MATCH_YES
);
8042 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
8043 if (ba
->non_overridable
&& ba
->deferred
)
8045 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
8052 if (ba
->access
== ACCESS_UNKNOWN
)
8053 ba
->access
= gfc_typebound_default_access
;
8055 if (ppc
&& !seen_ptr
)
8057 gfc_error ("POINTER attribute is required for procedure pointer component"
8069 /* Match a PROCEDURE specific binding inside a derived type. */
8072 match_procedure_in_type (void)
8074 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8075 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
8076 char* target
= NULL
, *ifc
= NULL
;
8077 gfc_typebound_proc tb
;
8086 /* Check current state. */
8087 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
8088 block
= gfc_state_stack
->previous
->sym
;
8091 /* Try to match PROCEDURE(interface). */
8092 if (gfc_match (" (") == MATCH_YES
)
8094 m
= gfc_match_name (target_buf
);
8095 if (m
== MATCH_ERROR
)
8099 gfc_error ("Interface-name expected after '(' at %C");
8103 if (gfc_match (" )") != MATCH_YES
)
8105 gfc_error ("')' expected at %C");
8112 /* Construct the data structure. */
8113 memset (&tb
, 0, sizeof (tb
));
8114 tb
.where
= gfc_current_locus
;
8116 /* Match binding attributes. */
8117 m
= match_binding_attributes (&tb
, false, false);
8118 if (m
== MATCH_ERROR
)
8120 seen_attrs
= (m
== MATCH_YES
);
8122 /* Check that attribute DEFERRED is given if an interface is specified. */
8123 if (tb
.deferred
&& !ifc
)
8125 gfc_error ("Interface must be specified for DEFERRED binding at %C");
8128 if (ifc
&& !tb
.deferred
)
8130 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
8134 /* Match the colons. */
8135 m
= gfc_match (" ::");
8136 if (m
== MATCH_ERROR
)
8138 seen_colons
= (m
== MATCH_YES
);
8139 if (seen_attrs
&& !seen_colons
)
8141 gfc_error ("Expected '::' after binding-attributes at %C");
8145 /* Match the binding names. */
8148 m
= gfc_match_name (name
);
8149 if (m
== MATCH_ERROR
)
8153 gfc_error ("Expected binding name at %C");
8157 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
8160 /* Try to match the '=> target', if it's there. */
8162 m
= gfc_match (" =>");
8163 if (m
== MATCH_ERROR
)
8169 gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
8175 gfc_error ("'::' needed in PROCEDURE binding with explicit target"
8180 m
= gfc_match_name (target_buf
);
8181 if (m
== MATCH_ERROR
)
8185 gfc_error ("Expected binding target after '=>' at %C");
8188 target
= target_buf
;
8191 /* If no target was found, it has the same name as the binding. */
8195 /* Get the namespace to insert the symbols into. */
8196 ns
= block
->f2k_derived
;
8199 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
8200 if (tb
.deferred
&& !block
->attr
.abstract
)
8202 gfc_error ("Type '%s' containing DEFERRED binding at %C "
8203 "is not ABSTRACT", block
->name
);
8207 /* See if we already have a binding with this name in the symtree which
8208 would be an error. If a GENERIC already targetted this binding, it may
8209 be already there but then typebound is still NULL. */
8210 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
8211 if (stree
&& stree
->n
.tb
)
8213 gfc_error ("There is already a procedure with binding name '%s' for "
8214 "the derived type '%s' at %C", name
, block
->name
);
8218 /* Insert it and set attributes. */
8222 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
8225 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
8227 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
8230 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
8232 if (gfc_match_eos () == MATCH_YES
)
8234 if (gfc_match_char (',') != MATCH_YES
)
8239 gfc_error ("Syntax error in PROCEDURE statement at %C");
8244 /* Match a GENERIC procedure binding inside a derived type. */
8247 gfc_match_generic (void)
8249 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8250 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
8252 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
8253 gfc_typebound_proc
* tb
;
8255 interface_type op_type
;
8256 gfc_intrinsic_op op
;
8259 /* Check current state. */
8260 if (gfc_current_state () == COMP_DERIVED
)
8262 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
8265 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
8267 block
= gfc_state_stack
->previous
->sym
;
8268 ns
= block
->f2k_derived
;
8269 gcc_assert (block
&& ns
);
8271 memset (&tbattr
, 0, sizeof (tbattr
));
8272 tbattr
.where
= gfc_current_locus
;
8274 /* See if we get an access-specifier. */
8275 m
= match_binding_attributes (&tbattr
, true, false);
8276 if (m
== MATCH_ERROR
)
8279 /* Now the colons, those are required. */
8280 if (gfc_match (" ::") != MATCH_YES
)
8282 gfc_error ("Expected '::' at %C");
8286 /* Match the binding name; depending on type (operator / generic) format
8287 it for future error messages into bind_name. */
8289 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
8290 if (m
== MATCH_ERROR
)
8294 gfc_error ("Expected generic name or operator descriptor at %C");
8300 case INTERFACE_GENERIC
:
8301 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
8304 case INTERFACE_USER_OP
:
8305 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
8308 case INTERFACE_INTRINSIC_OP
:
8309 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
8310 gfc_op2string (op
));
8317 /* Match the required =>. */
8318 if (gfc_match (" =>") != MATCH_YES
)
8320 gfc_error ("Expected '=>' at %C");
8324 /* Try to find existing GENERIC binding with this name / for this operator;
8325 if there is something, check that it is another GENERIC and then extend
8326 it rather than building a new node. Otherwise, create it and put it
8327 at the right position. */
8331 case INTERFACE_USER_OP
:
8332 case INTERFACE_GENERIC
:
8334 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8337 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
8349 case INTERFACE_INTRINSIC_OP
:
8359 if (!tb
->is_generic
)
8361 gcc_assert (op_type
== INTERFACE_GENERIC
);
8362 gfc_error ("There's already a non-generic procedure with binding name"
8363 " '%s' for the derived type '%s' at %C",
8364 bind_name
, block
->name
);
8368 if (tb
->access
!= tbattr
.access
)
8370 gfc_error ("Binding at %C must have the same access as already"
8371 " defined binding '%s'", bind_name
);
8377 tb
= gfc_get_typebound_proc (NULL
);
8378 tb
->where
= gfc_current_locus
;
8379 tb
->access
= tbattr
.access
;
8381 tb
->u
.generic
= NULL
;
8385 case INTERFACE_GENERIC
:
8386 case INTERFACE_USER_OP
:
8388 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
8391 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
8399 case INTERFACE_INTRINSIC_OP
:
8408 /* Now, match all following names as specific targets. */
8411 gfc_symtree
* target_st
;
8412 gfc_tbp_generic
* target
;
8414 m
= gfc_match_name (name
);
8415 if (m
== MATCH_ERROR
)
8419 gfc_error ("Expected specific binding name at %C");
8423 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
8425 /* See if this is a duplicate specification. */
8426 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
8427 if (target_st
== target
->specific_st
)
8429 gfc_error ("'%s' already defined as specific binding for the"
8430 " generic '%s' at %C", name
, bind_name
);
8434 target
= gfc_get_tbp_generic ();
8435 target
->specific_st
= target_st
;
8436 target
->specific
= NULL
;
8437 target
->next
= tb
->u
.generic
;
8438 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
8439 || (op_type
== INTERFACE_INTRINSIC_OP
));
8440 tb
->u
.generic
= target
;
8442 while (gfc_match (" ,") == MATCH_YES
);
8444 /* Here should be the end. */
8445 if (gfc_match_eos () != MATCH_YES
)
8447 gfc_error ("Junk after GENERIC binding at %C");
8458 /* Match a FINAL declaration inside a derived type. */
8461 gfc_match_final_decl (void)
8463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8466 gfc_namespace
* module_ns
;
8470 if (gfc_current_form
== FORM_FREE
)
8472 char c
= gfc_peek_ascii_char ();
8473 if (!gfc_is_whitespace (c
) && c
!= ':')
8477 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
8479 if (gfc_current_form
== FORM_FIXED
)
8482 gfc_error ("FINAL declaration at %C must be inside a derived type "
8483 "CONTAINS section");
8487 block
= gfc_state_stack
->previous
->sym
;
8490 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
8491 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
8493 gfc_error ("Derived type declaration with FINAL at %C must be in the"
8494 " specification part of a MODULE");
8498 module_ns
= gfc_current_ns
;
8499 gcc_assert (module_ns
);
8500 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
8502 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
8503 if (gfc_match (" ::") == MATCH_ERROR
)
8506 /* Match the sequence of procedure names. */
8513 if (first
&& gfc_match_eos () == MATCH_YES
)
8515 gfc_error ("Empty FINAL at %C");
8519 m
= gfc_match_name (name
);
8522 gfc_error ("Expected module procedure name at %C");
8525 else if (m
!= MATCH_YES
)
8528 if (gfc_match_eos () == MATCH_YES
)
8530 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8532 gfc_error ("Expected ',' at %C");
8536 if (gfc_get_symbol (name
, module_ns
, &sym
))
8538 gfc_error ("Unknown procedure name \"%s\" at %C", name
);
8542 /* Mark the symbol as module procedure. */
8543 if (sym
->attr
.proc
!= PROC_MODULE
8544 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8547 /* Check if we already have this symbol in the list, this is an error. */
8548 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
8549 if (f
->proc_sym
== sym
)
8551 gfc_error ("'%s' at %C is already defined as FINAL procedure!",
8556 /* Add this symbol to the list of finalizers. */
8557 gcc_assert (block
->f2k_derived
);
8559 f
= XCNEW (gfc_finalizer
);
8561 f
->proc_tree
= NULL
;
8562 f
->where
= gfc_current_locus
;
8563 f
->next
= block
->f2k_derived
->finalizers
;
8564 block
->f2k_derived
->finalizers
= f
;
8574 const ext_attr_t ext_attr_list
[] = {
8575 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
8576 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
8577 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
8578 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
8579 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
8580 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
8581 { NULL
, EXT_ATTR_LAST
, NULL
}
8584 /* Match a !GCC$ ATTRIBUTES statement of the form:
8585 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
8586 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
8588 TODO: We should support all GCC attributes using the same syntax for
8589 the attribute list, i.e. the list in C
8590 __attributes(( attribute-list ))
8592 !GCC$ ATTRIBUTES attribute-list ::
8593 Cf. c-parser.c's c_parser_attributes; the data can then directly be
8596 As there is absolutely no risk of confusion, we should never return
8599 gfc_match_gcc_attributes (void)
8601 symbol_attribute attr
;
8602 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8607 gfc_clear_attr (&attr
);
8612 if (gfc_match_name (name
) != MATCH_YES
)
8615 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
8616 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
8619 if (id
== EXT_ATTR_LAST
)
8621 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
8625 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
8628 gfc_gobble_whitespace ();
8629 ch
= gfc_next_ascii_char ();
8632 /* This is the successful exit condition for the loop. */
8633 if (gfc_next_ascii_char () == ':')
8643 if (gfc_match_eos () == MATCH_YES
)
8648 m
= gfc_match_name (name
);
8652 if (find_special (name
, &sym
, true))
8655 sym
->attr
.ext_attr
|= attr
.ext_attr
;
8657 if (gfc_match_eos () == MATCH_YES
)
8660 if (gfc_match_char (',') != MATCH_YES
)
8667 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");