1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 /* This flag is set if an old-style length selector is matched
29 during a type-declaration statement. */
31 static int old_char_selector
;
33 /* When variables acquire types and attributes from a declaration
34 statement, they get them from the following static variables. The
35 first part of a declaration sets these variables and the second
36 part copies these into symbol structures. */
38 static gfc_typespec current_ts
;
40 static symbol_attribute current_attr
;
41 static gfc_array_spec
*current_as
;
42 static int colon_seen
;
44 /* The current binding label (if any). */
45 static char curr_binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
46 /* Need to know how many identifiers are on the current data declaration
47 line in case we're given the BIND(C) attribute with a NAME= specifier. */
48 static int num_idents_on_line
;
49 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
50 can supply a name if the curr_binding_label is nil and NAME= was not. */
51 static int has_name_equals
= 0;
53 /* Initializer of the previous enumerator. */
55 static gfc_expr
*last_initializer
;
57 /* History of all the enumerators is maintained, so that
58 kind values of all the enumerators could be updated depending
59 upon the maximum initialized value. */
61 typedef struct enumerator_history
64 gfc_expr
*initializer
;
65 struct enumerator_history
*next
;
69 /* Header of enum history chain. */
71 static enumerator_history
*enum_history
= NULL
;
73 /* Pointer of enum history node containing largest initializer. */
75 static enumerator_history
*max_enum
= NULL
;
77 /* gfc_new_block points to the symbol of a newly matched block. */
79 gfc_symbol
*gfc_new_block
;
82 /********************* DATA statement subroutines *********************/
84 static bool in_match_data
= false;
87 gfc_in_match_data (void)
93 gfc_set_in_match_data (bool set_value
)
95 in_match_data
= set_value
;
98 /* Free a gfc_data_variable structure and everything beneath it. */
101 free_variable (gfc_data_variable
*p
)
103 gfc_data_variable
*q
;
108 gfc_free_expr (p
->expr
);
109 gfc_free_iterator (&p
->iter
, 0);
110 free_variable (p
->list
);
116 /* Free a gfc_data_value structure and everything beneath it. */
119 free_value (gfc_data_value
*p
)
126 gfc_free_expr (p
->expr
);
132 /* Free a list of gfc_data structures. */
135 gfc_free_data (gfc_data
*p
)
142 free_variable (p
->var
);
143 free_value (p
->value
);
149 /* Free all data in a namespace. */
152 gfc_free_data_all (gfc_namespace
*ns
)
165 static match
var_element (gfc_data_variable
*);
167 /* Match a list of variables terminated by an iterator and a right
171 var_list (gfc_data_variable
*parent
)
173 gfc_data_variable
*tail
, var
;
176 m
= var_element (&var
);
177 if (m
== MATCH_ERROR
)
182 tail
= gfc_get_data_variable ();
189 if (gfc_match_char (',') != MATCH_YES
)
192 m
= gfc_match_iterator (&parent
->iter
, 1);
195 if (m
== MATCH_ERROR
)
198 m
= var_element (&var
);
199 if (m
== MATCH_ERROR
)
204 tail
->next
= gfc_get_data_variable ();
210 if (gfc_match_char (')') != MATCH_YES
)
215 gfc_syntax_error (ST_DATA
);
220 /* Match a single element in a data variable list, which can be a
221 variable-iterator list. */
224 var_element (gfc_data_variable
*new)
229 memset (new, 0, sizeof (gfc_data_variable
));
231 if (gfc_match_char ('(') == MATCH_YES
)
232 return var_list (new);
234 m
= gfc_match_variable (&new->expr
, 0);
238 sym
= new->expr
->symtree
->n
.sym
;
240 if (!sym
->attr
.function
&& gfc_current_ns
->parent
241 && gfc_current_ns
->parent
== sym
->ns
)
243 gfc_error ("Host associated variable '%s' may not be in the DATA "
244 "statement at %C", sym
->name
);
248 if (gfc_current_state () != COMP_BLOCK_DATA
249 && sym
->attr
.in_common
250 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
251 "common block variable '%s' in DATA statement at %C",
252 sym
->name
) == FAILURE
)
255 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
262 /* Match the top-level list of data variables. */
265 top_var_list (gfc_data
*d
)
267 gfc_data_variable var
, *tail
, *new;
274 m
= var_element (&var
);
277 if (m
== MATCH_ERROR
)
280 new = gfc_get_data_variable ();
290 if (gfc_match_char ('/') == MATCH_YES
)
292 if (gfc_match_char (',') != MATCH_YES
)
299 gfc_syntax_error (ST_DATA
);
300 gfc_free_data_all (gfc_current_ns
);
306 match_data_constant (gfc_expr
**result
)
308 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
314 m
= gfc_match_literal_constant (&expr
, 1);
321 if (m
== MATCH_ERROR
)
324 m
= gfc_match_null (result
);
328 old_loc
= gfc_current_locus
;
330 /* Should this be a structure component, try to match it
331 before matching a name. */
332 m
= gfc_match_rvalue (result
);
333 if (m
== MATCH_ERROR
)
336 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
338 if (gfc_simplify_expr (*result
, 0) == FAILURE
)
343 gfc_current_locus
= old_loc
;
345 m
= gfc_match_name (name
);
349 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
353 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
355 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
359 else if (sym
->attr
.flavor
== FL_DERIVED
)
360 return gfc_match_structure_constructor (sym
, result
);
362 *result
= gfc_copy_expr (sym
->value
);
367 /* Match a list of values in a DATA statement. The leading '/' has
368 already been seen at this point. */
371 top_val_list (gfc_data
*data
)
373 gfc_data_value
*new, *tail
;
382 m
= match_data_constant (&expr
);
385 if (m
== MATCH_ERROR
)
388 new = gfc_get_data_value ();
397 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
405 msg
= gfc_extract_int (expr
, &tmp
);
406 gfc_free_expr (expr
);
414 m
= match_data_constant (&tail
->expr
);
417 if (m
== MATCH_ERROR
)
421 if (gfc_match_char ('/') == MATCH_YES
)
423 if (gfc_match_char (',') == MATCH_NO
)
430 gfc_syntax_error (ST_DATA
);
431 gfc_free_data_all (gfc_current_ns
);
436 /* Matches an old style initialization. */
439 match_old_style_init (const char *name
)
446 /* Set up data structure to hold initializers. */
447 gfc_find_sym_tree (name
, NULL
, 0, &st
);
450 newdata
= gfc_get_data ();
451 newdata
->var
= gfc_get_data_variable ();
452 newdata
->var
->expr
= gfc_get_variable_expr (st
);
453 newdata
->where
= gfc_current_locus
;
455 /* Match initial value list. This also eats the terminal '/'. */
456 m
= top_val_list (newdata
);
465 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
470 /* Mark the variable as having appeared in a data statement. */
471 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
477 /* Chain in namespace list of DATA initializers. */
478 newdata
->next
= gfc_current_ns
->data
;
479 gfc_current_ns
->data
= newdata
;
485 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
486 we are matching a DATA statement and are therefore issuing an error
487 if we encounter something unexpected, if not, we're trying to match
488 an old-style initialization expression of the form INTEGER I /2/. */
491 gfc_match_data (void)
496 gfc_set_in_match_data (true);
500 new = gfc_get_data ();
501 new->where
= gfc_current_locus
;
503 m
= top_var_list (new);
507 m
= top_val_list (new);
511 new->next
= gfc_current_ns
->data
;
512 gfc_current_ns
->data
= new;
514 if (gfc_match_eos () == MATCH_YES
)
517 gfc_match_char (','); /* Optional comma */
520 gfc_set_in_match_data (false);
524 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
531 gfc_set_in_match_data (false);
537 /************************ Declaration statements *********************/
539 /* Match an intent specification. Since this can only happen after an
540 INTENT word, a legal intent-spec must follow. */
543 match_intent_spec (void)
546 if (gfc_match (" ( in out )") == MATCH_YES
)
548 if (gfc_match (" ( in )") == MATCH_YES
)
550 if (gfc_match (" ( out )") == MATCH_YES
)
553 gfc_error ("Bad INTENT specification at %C");
554 return INTENT_UNKNOWN
;
558 /* Matches a character length specification, which is either a
559 specification expression or a '*'. */
562 char_len_param_value (gfc_expr
**expr
)
564 if (gfc_match_char ('*') == MATCH_YES
)
570 return gfc_match_expr (expr
);
574 /* A character length is a '*' followed by a literal integer or a
575 char_len_param_value in parenthesis. */
578 match_char_length (gfc_expr
**expr
)
583 m
= gfc_match_char ('*');
587 m
= gfc_match_small_literal_int (&length
, NULL
);
588 if (m
== MATCH_ERROR
)
593 *expr
= gfc_int_expr (length
);
597 if (gfc_match_char ('(') == MATCH_NO
)
600 m
= char_len_param_value (expr
);
601 if (m
== MATCH_ERROR
)
606 if (gfc_match_char (')') == MATCH_NO
)
608 gfc_free_expr (*expr
);
616 gfc_error ("Syntax error in character length specification at %C");
621 /* Special subroutine for finding a symbol. Check if the name is found
622 in the current name space. If not, and we're compiling a function or
623 subroutine and the parent compilation unit is an interface, then check
624 to see if the name we've been given is the name of the interface
625 (located in another namespace). */
628 find_special (const char *name
, gfc_symbol
**result
)
633 i
= gfc_get_symbol (name
, NULL
, result
);
637 if (gfc_current_state () != COMP_SUBROUTINE
638 && gfc_current_state () != COMP_FUNCTION
)
641 s
= gfc_state_stack
->previous
;
645 if (s
->state
!= COMP_INTERFACE
)
648 goto end
; /* Nameless interface. */
650 if (strcmp (name
, s
->sym
->name
) == 0)
661 /* Special subroutine for getting a symbol node associated with a
662 procedure name, used in SUBROUTINE and FUNCTION statements. The
663 symbol is created in the parent using with symtree node in the
664 child unit pointing to the symbol. If the current namespace has no
665 parent, then the symbol is just created in the current unit. */
668 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
674 /* Module functions have to be left in their own namespace because
675 they have potentially (almost certainly!) already been referenced.
676 In this sense, they are rather like external functions. This is
677 fixed up in resolve.c(resolve_entries), where the symbol name-
678 space is set to point to the master function, so that the fake
679 result mechanism can work. */
680 if (module_fcn_entry
)
682 /* Present if entry is declared to be a module procedure. */
683 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
686 rc
= gfc_get_symbol (name
, NULL
, result
);
687 else if (gfc_get_symbol (name
, NULL
, &sym
) == 0
689 && sym
->ts
.type
!= BT_UNKNOWN
690 && (*result
)->ts
.type
== BT_UNKNOWN
691 && sym
->attr
.flavor
== FL_UNKNOWN
)
692 /* Pick up the typespec for the entry, if declared in the function
693 body. Note that this symbol is FL_UNKNOWN because it will
694 only have appeared in a type declaration. The local symtree
695 is set to point to the module symbol and a unique symtree
696 to the local version. This latter ensures a correct clearing
699 (*result
)->ts
= sym
->ts
;
700 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
702 st
= gfc_get_unique_symtree (gfc_current_ns
);
707 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
710 gfc_current_ns
->refs
++;
712 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
714 /* Trap another encompassed procedure with the same name. All
715 these conditions are necessary to avoid picking up an entry
716 whose name clashes with that of the encompassing procedure;
717 this is handled using gsymbols to register unique,globally
719 if (sym
->attr
.flavor
!= 0
720 && sym
->attr
.proc
!= 0
721 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
722 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
723 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
724 name
, &sym
->declared_at
);
726 /* Trap a procedure with a name the same as interface in the
727 encompassing scope. */
728 if (sym
->attr
.generic
!= 0
729 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
730 && !sym
->attr
.mod_proc
)
731 gfc_error_now ("Name '%s' at %C is already defined"
732 " as a generic interface at %L",
733 name
, &sym
->declared_at
);
735 /* Trap declarations of attributes in encompassing scope. The
736 signature for this is that ts.kind is set. Legitimate
737 references only set ts.type. */
738 if (sym
->ts
.kind
!= 0
739 && !sym
->attr
.implicit_type
740 && sym
->attr
.proc
== 0
741 && gfc_current_ns
->parent
!= NULL
742 && sym
->attr
.access
== 0
743 && !module_fcn_entry
)
744 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
745 "and must not have attributes declared at %L",
746 name
, &sym
->declared_at
);
749 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
752 /* Module function entries will already have a symtree in
753 the current namespace but will need one at module level. */
754 if (module_fcn_entry
)
756 /* Present if entry is declared to be a module procedure. */
757 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
759 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
762 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
767 /* See if the procedure should be a module procedure. */
769 if (((sym
->ns
->proc_name
!= NULL
770 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
771 && sym
->attr
.proc
!= PROC_MODULE
)
772 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
773 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
774 sym
->name
, NULL
) == FAILURE
)
781 /* Verify that the given symbol representing a parameter is C
782 interoperable, by checking to see if it was marked as such after
783 its declaration. If the given symbol is not interoperable, a
784 warning is reported, thus removing the need to return the status to
785 the calling function. The standard does not require the user use
786 one of the iso_c_binding named constants to declare an
787 interoperable parameter, but we can't be sure if the param is C
788 interop or not if the user doesn't. For example, integer(4) may be
789 legal Fortran, but doesn't have meaning in C. It may interop with
790 a number of the C types, which causes a problem because the
791 compiler can't know which one. This code is almost certainly not
792 portable, and the user will get what they deserve if the C type
793 across platforms isn't always interoperable with integer(4). If
794 the user had used something like integer(c_int) or integer(c_long),
795 the compiler could have automatically handled the varying sizes
799 verify_c_interop_param (gfc_symbol
*sym
)
801 int is_c_interop
= 0;
802 try retval
= SUCCESS
;
804 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
805 Don't repeat the checks here. */
806 if (sym
->attr
.implicit_type
)
809 /* For subroutines or functions that are passed to a BIND(C) procedure,
810 they're interoperable if they're BIND(C) and their params are all
812 if (sym
->attr
.flavor
== FL_PROCEDURE
)
814 if (sym
->attr
.is_bind_c
== 0)
816 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
817 "attribute to be C interoperable", sym
->name
,
818 &(sym
->declared_at
));
824 if (sym
->attr
.is_c_interop
== 1)
825 /* We've already checked this procedure; don't check it again. */
828 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
833 /* See if we've stored a reference to a procedure that owns sym. */
834 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
836 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
839 (verify_c_interop (&(sym
->ts
), sym
->name
, &(sym
->declared_at
))
842 if (is_c_interop
!= 1)
844 /* Make personalized messages to give better feedback. */
845 if (sym
->ts
.type
== BT_DERIVED
)
846 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
847 " procedure '%s' but is not C interoperable "
848 "because derived type '%s' is not C interoperable",
849 sym
->name
, &(sym
->declared_at
),
850 sym
->ns
->proc_name
->name
,
851 sym
->ts
.derived
->name
);
853 gfc_warning ("Variable '%s' at %L is a parameter to the "
854 "BIND(C) procedure '%s' but may not be C "
856 sym
->name
, &(sym
->declared_at
),
857 sym
->ns
->proc_name
->name
);
860 /* Character strings are only C interoperable if they have a
862 if (sym
->ts
.type
== BT_CHARACTER
)
864 gfc_charlen
*cl
= sym
->ts
.cl
;
865 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
866 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
868 gfc_error ("Character argument '%s' at %L "
869 "must be length 1 because "
870 "procedure '%s' is BIND(C)",
871 sym
->name
, &sym
->declared_at
,
872 sym
->ns
->proc_name
->name
);
877 /* We have to make sure that any param to a bind(c) routine does
878 not have the allocatable, pointer, or optional attributes,
879 according to J3/04-007, section 5.1. */
880 if (sym
->attr
.allocatable
== 1)
882 gfc_error ("Variable '%s' at %L cannot have the "
883 "ALLOCATABLE attribute because procedure '%s'"
884 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
885 sym
->ns
->proc_name
->name
);
889 if (sym
->attr
.pointer
== 1)
891 gfc_error ("Variable '%s' at %L cannot have the "
892 "POINTER attribute because procedure '%s'"
893 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
894 sym
->ns
->proc_name
->name
);
898 if (sym
->attr
.optional
== 1)
900 gfc_error ("Variable '%s' at %L cannot have the "
901 "OPTIONAL attribute because procedure '%s'"
902 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
903 sym
->ns
->proc_name
->name
);
907 /* Make sure that if it has the dimension attribute, that it is
908 either assumed size or explicit shape. */
911 if (sym
->as
->type
== AS_ASSUMED_SHAPE
)
913 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
914 "argument to the procedure '%s' at %L because "
915 "the procedure is BIND(C)", sym
->name
,
916 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
917 &(sym
->ns
->proc_name
->declared_at
));
921 if (sym
->as
->type
== AS_DEFERRED
)
923 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
924 "argument to the procedure '%s' at %L because "
925 "the procedure is BIND(C)", sym
->name
,
926 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
927 &(sym
->ns
->proc_name
->declared_at
));
938 /* Function called by variable_decl() that adds a name to the symbol table. */
941 build_sym (const char *name
, gfc_charlen
*cl
,
942 gfc_array_spec
**as
, locus
*var_locus
)
944 symbol_attribute attr
;
947 if (gfc_get_symbol (name
, NULL
, &sym
))
950 /* Start updating the symbol table. Add basic type attribute if present. */
951 if (current_ts
.type
!= BT_UNKNOWN
952 && (sym
->attr
.implicit_type
== 0
953 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
954 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
957 if (sym
->ts
.type
== BT_CHARACTER
)
960 /* Add dimension attribute if present. */
961 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
965 /* Add attribute to symbol. The copy is so that we can reset the
966 dimension attribute. */
970 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
973 /* Finish any work that may need to be done for the binding label,
974 if it's a bind(c). The bind(c) attr is found before the symbol
975 is made, and before the symbol name (for data decls), so the
976 current_ts is holding the binding label, or nothing if the
977 name= attr wasn't given. Therefore, test here if we're dealing
978 with a bind(c) and make sure the binding label is set correctly. */
979 if (sym
->attr
.is_bind_c
== 1)
981 if (sym
->binding_label
[0] == '\0')
983 /* Set the binding label and verify that if a NAME= was specified
984 then only one identifier was in the entity-decl-list. */
985 if (set_binding_label (sym
->binding_label
, sym
->name
,
986 num_idents_on_line
) == FAILURE
)
991 /* See if we know we're in a common block, and if it's a bind(c)
992 common then we need to make sure we're an interoperable type. */
993 if (sym
->attr
.in_common
== 1)
995 /* Test the common block object. */
996 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
997 && sym
->ts
.is_c_interop
!= 1)
999 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1000 "must be declared with a C interoperable "
1001 "kind since common block '%s' is BIND(C)",
1002 sym
->name
, sym
->common_block
->name
,
1003 sym
->common_block
->name
);
1008 sym
->attr
.implied_index
= 0;
1014 /* Set character constant to the given length. The constant will be padded or
1018 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, bool array
)
1023 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1024 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
1026 slen
= expr
->value
.character
.length
;
1029 s
= gfc_getmem (len
+ 1);
1030 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
1032 memset (&s
[slen
], ' ', len
- slen
);
1034 if (gfc_option
.warn_character_truncation
&& slen
> len
)
1035 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1036 "(%d/%d)", &expr
->where
, slen
, len
);
1038 /* Apply the standard by 'hand' otherwise it gets cleared for
1040 if (array
&& slen
< len
&& !(gfc_option
.allow_std
& GFC_STD_GNU
))
1041 gfc_error_now ("The CHARACTER elements of the array constructor "
1042 "at %L must have the same length (%d/%d)",
1043 &expr
->where
, slen
, len
);
1046 gfc_free (expr
->value
.character
.string
);
1047 expr
->value
.character
.string
= s
;
1048 expr
->value
.character
.length
= len
;
1053 /* Function to create and update the enumerator history
1054 using the information passed as arguments.
1055 Pointer "max_enum" is also updated, to point to
1056 enum history node containing largest initializer.
1058 SYM points to the symbol node of enumerator.
1059 INIT points to its enumerator value. */
1062 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1064 enumerator_history
*new_enum_history
;
1065 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1067 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
1069 new_enum_history
->sym
= sym
;
1070 new_enum_history
->initializer
= init
;
1071 new_enum_history
->next
= NULL
;
1073 if (enum_history
== NULL
)
1075 enum_history
= new_enum_history
;
1076 max_enum
= enum_history
;
1080 new_enum_history
->next
= enum_history
;
1081 enum_history
= new_enum_history
;
1083 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1084 new_enum_history
->initializer
->value
.integer
) < 0)
1085 max_enum
= new_enum_history
;
1090 /* Function to free enum kind history. */
1093 gfc_free_enum_history (void)
1095 enumerator_history
*current
= enum_history
;
1096 enumerator_history
*next
;
1098 while (current
!= NULL
)
1100 next
= current
->next
;
1105 enum_history
= NULL
;
1109 /* Function called by variable_decl() that adds an initialization
1110 expression to a symbol. */
1113 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1115 symbol_attribute attr
;
1120 if (find_special (name
, &sym
))
1125 /* If this symbol is confirming an implicit parameter type,
1126 then an initialization expression is not allowed. */
1127 if (attr
.flavor
== FL_PARAMETER
1128 && sym
->value
!= NULL
1131 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1140 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1147 /* An initializer is required for PARAMETER declarations. */
1148 if (attr
.flavor
== FL_PARAMETER
)
1150 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1156 /* If a variable appears in a DATA block, it cannot have an
1160 gfc_error ("Variable '%s' at %C with an initializer already "
1161 "appears in a DATA statement", sym
->name
);
1165 /* Check if the assignment can happen. This has to be put off
1166 until later for a derived type variable. */
1167 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1168 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
1171 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
1173 /* Update symbol character length according initializer. */
1174 if (sym
->ts
.cl
->length
== NULL
)
1176 /* If there are multiple CHARACTER variables declared on the
1177 same line, we don't want them to share the same length. */
1178 sym
->ts
.cl
= gfc_get_charlen ();
1179 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1180 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
1182 if (sym
->attr
.flavor
== FL_PARAMETER
1183 && init
->expr_type
== EXPR_ARRAY
)
1184 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
1186 /* Update initializer character length according symbol. */
1187 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1189 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
1190 gfc_constructor
* p
;
1192 if (init
->expr_type
== EXPR_CONSTANT
)
1193 gfc_set_constant_character_len (len
, init
, false);
1194 else if (init
->expr_type
== EXPR_ARRAY
)
1196 /* Build a new charlen to prevent simplification from
1197 deleting the length before it is resolved. */
1198 init
->ts
.cl
= gfc_get_charlen ();
1199 init
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1200 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
1201 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
1203 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
1204 gfc_set_constant_character_len (len
, p
->expr
, false);
1209 /* Need to check if the expression we initialized this
1210 to was one of the iso_c_binding named constants. If so,
1211 and we're a parameter (constant), let it be iso_c.
1213 integer(c_int), parameter :: my_int = c_int
1214 integer(my_int) :: my_int_2
1215 If we mark my_int as iso_c (since we can see it's value
1216 is equal to one of the named constants), then my_int_2
1217 will be considered C interoperable. */
1218 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1220 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1221 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1222 /* attr bits needed for module files. */
1223 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1224 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1225 if (init
->ts
.is_iso_c
)
1226 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1229 /* Add initializer. Make sure we keep the ranks sane. */
1230 if (sym
->attr
.dimension
&& init
->rank
== 0)
1236 if (sym
->attr
.flavor
== FL_PARAMETER
1237 && init
->expr_type
== EXPR_CONSTANT
1238 && spec_size (sym
->as
, &size
) == SUCCESS
1239 && mpz_cmp_si (size
, 0) > 0)
1241 array
= gfc_start_constructor (init
->ts
.type
, init
->ts
.kind
,
1244 array
->value
.constructor
= c
= NULL
;
1245 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1247 if (array
->value
.constructor
== NULL
)
1249 array
->value
.constructor
= c
= gfc_get_constructor ();
1254 c
->next
= gfc_get_constructor ();
1256 c
->expr
= gfc_copy_expr (init
);
1260 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1261 for (n
= 0; n
< sym
->as
->rank
; n
++)
1262 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1267 init
->rank
= sym
->as
->rank
;
1271 if (sym
->attr
.save
== SAVE_NONE
)
1272 sym
->attr
.save
= SAVE_IMPLICIT
;
1280 /* Function called by variable_decl() that adds a name to a structure
1284 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1285 gfc_array_spec
**as
)
1289 /* If the current symbol is of the same derived type that we're
1290 constructing, it must have the pointer attribute. */
1291 if (current_ts
.type
== BT_DERIVED
1292 && current_ts
.derived
== gfc_current_block ()
1293 && current_attr
.pointer
== 0)
1295 gfc_error ("Component at %C must have the POINTER attribute");
1299 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1301 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1303 gfc_error ("Array component of structure at %C must have explicit "
1304 "or deferred shape");
1309 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
1314 gfc_set_component_attr (c
, ¤t_attr
);
1316 c
->initializer
= *init
;
1324 /* Check array components. */
1329 gfc_error ("Allocatable component at %C must be an array");
1338 if (c
->as
->type
!= AS_DEFERRED
)
1340 gfc_error ("Pointer array component of structure at %C must have a "
1345 else if (c
->allocatable
)
1347 if (c
->as
->type
!= AS_DEFERRED
)
1349 gfc_error ("Allocatable component of structure at %C must have a "
1356 if (c
->as
->type
!= AS_EXPLICIT
)
1358 gfc_error ("Array component of structure at %C must have an "
1368 /* Match a 'NULL()', and possibly take care of some side effects. */
1371 gfc_match_null (gfc_expr
**result
)
1377 m
= gfc_match (" null ( )");
1381 /* The NULL symbol now has to be/become an intrinsic function. */
1382 if (gfc_get_symbol ("null", NULL
, &sym
))
1384 gfc_error ("NULL() initialization at %C is ambiguous");
1388 gfc_intrinsic_symbol (sym
);
1390 if (sym
->attr
.proc
!= PROC_INTRINSIC
1391 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1392 sym
->name
, NULL
) == FAILURE
1393 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1396 e
= gfc_get_expr ();
1397 e
->where
= gfc_current_locus
;
1398 e
->expr_type
= EXPR_NULL
;
1399 e
->ts
.type
= BT_UNKNOWN
;
1407 /* Match a variable name with an optional initializer. When this
1408 subroutine is called, a variable is expected to be parsed next.
1409 Depending on what is happening at the moment, updates either the
1410 symbol table or the current interface. */
1413 variable_decl (int elem
)
1415 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1416 gfc_expr
*initializer
, *char_len
;
1418 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1429 old_locus
= gfc_current_locus
;
1431 /* When we get here, we've just matched a list of attributes and
1432 maybe a type and a double colon. The next thing we expect to see
1433 is the name of the symbol. */
1434 m
= gfc_match_name (name
);
1438 var_locus
= gfc_current_locus
;
1440 /* Now we could see the optional array spec. or character length. */
1441 m
= gfc_match_array_spec (&as
);
1442 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1443 cp_as
= gfc_copy_array_spec (as
);
1444 else if (m
== MATCH_ERROR
)
1448 as
= gfc_copy_array_spec (current_as
);
1453 if (current_ts
.type
== BT_CHARACTER
)
1455 switch (match_char_length (&char_len
))
1458 cl
= gfc_get_charlen ();
1459 cl
->next
= gfc_current_ns
->cl_list
;
1460 gfc_current_ns
->cl_list
= cl
;
1462 cl
->length
= char_len
;
1465 /* Non-constant lengths need to be copied after the first
1466 element. Also copy assumed lengths. */
1469 && (current_ts
.cl
->length
== NULL
1470 || current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
1472 cl
= gfc_get_charlen ();
1473 cl
->next
= gfc_current_ns
->cl_list
;
1474 gfc_current_ns
->cl_list
= cl
;
1475 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1487 /* If this symbol has already shown up in a Cray Pointer declaration,
1488 then we want to set the type & bail out. */
1489 if (gfc_option
.flag_cray_pointer
)
1491 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1492 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1494 sym
->ts
.type
= current_ts
.type
;
1495 sym
->ts
.kind
= current_ts
.kind
;
1497 sym
->ts
.derived
= current_ts
.derived
;
1498 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1499 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1502 /* Check to see if we have an array specification. */
1505 if (sym
->as
!= NULL
)
1507 gfc_error ("Duplicate array spec for Cray pointee at %C");
1508 gfc_free_array_spec (cp_as
);
1514 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1515 gfc_internal_error ("Couldn't set pointee array spec.");
1517 /* Fix the array spec. */
1518 m
= gfc_mod_pointee_as (sym
->as
);
1519 if (m
== MATCH_ERROR
)
1527 gfc_free_array_spec (cp_as
);
1532 /* OK, we've successfully matched the declaration. Now put the
1533 symbol in the current namespace, because it might be used in the
1534 optional initialization expression for this symbol, e.g. this is
1537 integer, parameter :: i = huge(i)
1539 This is only true for parameters or variables of a basic type.
1540 For components of derived types, it is not true, so we don't
1541 create a symbol for those yet. If we fail to create the symbol,
1543 if (gfc_current_state () != COMP_DERIVED
1544 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1550 /* An interface body specifies all of the procedure's
1551 characteristics and these shall be consistent with those
1552 specified in the procedure definition, except that the interface
1553 may specify a procedure that is not pure if the procedure is
1554 defined to be pure(12.3.2). */
1555 if (current_ts
.type
== BT_DERIVED
1556 && gfc_current_ns
->proc_name
1557 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1558 && current_ts
.derived
->ns
!= gfc_current_ns
)
1561 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, current_ts
.derived
->name
);
1562 if (!(current_ts
.derived
->attr
.imported
1564 && st
->n
.sym
== current_ts
.derived
)
1565 && !gfc_current_ns
->has_import_set
)
1567 gfc_error ("the type of '%s' at %C has not been declared within the "
1574 /* In functions that have a RESULT variable defined, the function
1575 name always refers to function calls. Therefore, the name is
1576 not allowed to appear in specification statements. */
1577 if (gfc_current_state () == COMP_FUNCTION
1578 && gfc_current_block () != NULL
1579 && gfc_current_block ()->result
!= NULL
1580 && gfc_current_block ()->result
!= gfc_current_block ()
1581 && strcmp (gfc_current_block ()->name
, name
) == 0)
1583 gfc_error ("Function name '%s' not allowed at %C", name
);
1588 /* We allow old-style initializations of the form
1589 integer i /2/, j(4) /3*3, 1/
1590 (if no colon has been seen). These are different from data
1591 statements in that initializers are only allowed to apply to the
1592 variable immediately preceding, i.e.
1594 is not allowed. Therefore we have to do some work manually, that
1595 could otherwise be left to the matchers for DATA statements. */
1597 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1599 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1600 "initialization at %C") == FAILURE
)
1603 return match_old_style_init (name
);
1606 /* The double colon must be present in order to have initializers.
1607 Otherwise the statement is ambiguous with an assignment statement. */
1610 if (gfc_match (" =>") == MATCH_YES
)
1612 if (!current_attr
.pointer
)
1614 gfc_error ("Initialization at %C isn't for a pointer variable");
1619 m
= gfc_match_null (&initializer
);
1622 gfc_error ("Pointer initialization requires a NULL() at %C");
1626 if (gfc_pure (NULL
))
1628 gfc_error ("Initialization of pointer at %C is not allowed in "
1629 "a PURE procedure");
1637 else if (gfc_match_char ('=') == MATCH_YES
)
1639 if (current_attr
.pointer
)
1641 gfc_error ("Pointer initialization at %C requires '=>', "
1647 m
= gfc_match_init_expr (&initializer
);
1650 gfc_error ("Expected an initialization expression at %C");
1654 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1656 gfc_error ("Initialization of variable at %C is not allowed in "
1657 "a PURE procedure");
1666 if (initializer
!= NULL
&& current_attr
.allocatable
1667 && gfc_current_state () == COMP_DERIVED
)
1669 gfc_error ("Initialization of allocatable component at %C is not "
1675 /* Add the initializer. Note that it is fine if initializer is
1676 NULL here, because we sometimes also need to check if a
1677 declaration *must* have an initialization expression. */
1678 if (gfc_current_state () != COMP_DERIVED
)
1679 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1682 if (current_ts
.type
== BT_DERIVED
1683 && !current_attr
.pointer
&& !initializer
)
1684 initializer
= gfc_default_initializer (¤t_ts
);
1685 t
= build_struct (name
, cl
, &initializer
, &as
);
1688 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1691 /* Free stuff up and return. */
1692 gfc_free_expr (initializer
);
1693 gfc_free_array_spec (as
);
1699 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1700 This assumes that the byte size is equal to the kind number for
1701 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1704 gfc_match_old_kind_spec (gfc_typespec
*ts
)
1709 if (gfc_match_char ('*') != MATCH_YES
)
1712 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1716 original_kind
= ts
->kind
;
1718 /* Massage the kind numbers for complex types. */
1719 if (ts
->type
== BT_COMPLEX
)
1723 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1724 gfc_basic_typename (ts
->type
), original_kind
);
1730 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1732 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1733 gfc_basic_typename (ts
->type
), original_kind
);
1737 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1738 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1745 /* Match a kind specification. Since kinds are generally optional, we
1746 usually return MATCH_NO if something goes wrong. If a "kind="
1747 string is found, then we know we have an error. */
1750 gfc_match_kind_spec (gfc_typespec
*ts
)
1760 where
= gfc_current_locus
;
1762 if (gfc_match_char ('(') == MATCH_NO
)
1765 /* Also gobbles optional text. */
1766 if (gfc_match (" kind = ") == MATCH_YES
)
1769 n
= gfc_match_init_expr (&e
);
1771 gfc_error ("Expected initialization expression at %C");
1777 gfc_error ("Expected scalar initialization expression at %C");
1782 msg
= gfc_extract_int (e
, &ts
->kind
);
1790 /* Before throwing away the expression, let's see if we had a
1791 C interoperable kind (and store the fact). */
1792 if (e
->ts
.is_c_interop
== 1)
1794 /* Mark this as c interoperable if being declared with one
1795 of the named constants from iso_c_binding. */
1796 ts
->is_c_interop
= e
->ts
.is_iso_c
;
1797 ts
->f90_type
= e
->ts
.f90_type
;
1803 /* Ignore errors to this point, if we've gotten here. This means
1804 we ignore the m=MATCH_ERROR from above. */
1805 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1807 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1808 gfc_basic_typename (ts
->type
));
1811 else if (gfc_match_char (')') != MATCH_YES
)
1813 gfc_error ("Missing right parenthesis at %C");
1817 /* All tests passed. */
1820 if(m
== MATCH_ERROR
)
1821 gfc_current_locus
= where
;
1823 /* Return what we know from the test(s). */
1828 gfc_current_locus
= where
;
1833 /* Match the various kind/length specifications in a CHARACTER
1834 declaration. We don't return MATCH_NO. */
1837 match_char_spec (gfc_typespec
*ts
)
1839 int kind
, seen_length
;
1843 gfc_expr
*kind_expr
= NULL
;
1844 kind
= gfc_default_character_kind
;
1848 /* Try the old-style specification first. */
1849 old_char_selector
= 0;
1851 m
= match_char_length (&len
);
1855 old_char_selector
= 1;
1860 m
= gfc_match_char ('(');
1863 m
= MATCH_YES
; /* Character without length is a single char. */
1867 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
1868 if (gfc_match (" kind =") == MATCH_YES
)
1870 m
= gfc_match_small_int_expr(&kind
, &kind_expr
);
1872 if (m
== MATCH_ERROR
)
1877 if (gfc_match (" , len =") == MATCH_NO
)
1880 m
= char_len_param_value (&len
);
1883 if (m
== MATCH_ERROR
)
1890 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
1891 if (gfc_match (" len =") == MATCH_YES
)
1893 m
= char_len_param_value (&len
);
1896 if (m
== MATCH_ERROR
)
1900 if (gfc_match_char (')') == MATCH_YES
)
1903 if (gfc_match (" , kind =") != MATCH_YES
)
1906 gfc_match_small_int_expr(&kind
, &kind_expr
);
1908 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1910 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1917 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
1918 m
= char_len_param_value (&len
);
1921 if (m
== MATCH_ERROR
)
1925 m
= gfc_match_char (')');
1929 if (gfc_match_char (',') != MATCH_YES
)
1932 gfc_match (" kind ="); /* Gobble optional text. */
1934 m
= gfc_match_small_int_expr(&kind
, &kind_expr
);
1935 if (m
== MATCH_ERROR
)
1941 /* Require a right-paren at this point. */
1942 m
= gfc_match_char (')');
1947 gfc_error ("Syntax error in CHARACTER declaration at %C");
1949 gfc_free_expr (len
);
1953 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1955 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1959 if (seen_length
== 1 && len
!= NULL
1960 && len
->ts
.type
!= BT_INTEGER
&& len
->ts
.type
!= BT_UNKNOWN
)
1962 gfc_error ("Expression at %C must be of INTEGER type");
1968 gfc_free_expr (len
);
1969 gfc_free_expr (kind_expr
);
1973 /* Do some final massaging of the length values. */
1974 cl
= gfc_get_charlen ();
1975 cl
->next
= gfc_current_ns
->cl_list
;
1976 gfc_current_ns
->cl_list
= cl
;
1978 if (seen_length
== 0)
1979 cl
->length
= gfc_int_expr (1);
1986 /* We have to know if it was a c interoperable kind so we can
1987 do accurate type checking of bind(c) procs, etc. */
1988 if (kind_expr
!= NULL
)
1990 /* Mark this as c interoperable if being declared with one
1991 of the named constants from iso_c_binding. */
1992 ts
->is_c_interop
= kind_expr
->ts
.is_iso_c
;
1993 gfc_free_expr (kind_expr
);
1995 else if (len
!= NULL
)
1997 /* Here, we might have parsed something such as:
1999 In this case, the parsing code above grabs the c_char when
2000 looking for the length (line 1690, roughly). it's the last
2001 testcase for parsing the kind params of a character variable.
2002 However, it's not actually the length. this seems like it
2004 To see if the user used a C interop kind, test the expr
2005 of the so called length, and see if it's C interoperable. */
2006 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2013 /* Matches a type specification. If successful, sets the ts structure
2014 to the matched specification. This is necessary for FUNCTION and
2015 IMPLICIT statements.
2017 If implicit_flag is nonzero, then we don't check for the optional
2018 kind specification. Not doing so is needed for matching an IMPLICIT
2019 statement correctly. */
2022 match_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2031 /* Clear the current binding label, in case one is given. */
2032 curr_binding_label
[0] = '\0';
2034 if (gfc_match (" byte") == MATCH_YES
)
2036 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
2040 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2042 gfc_error ("BYTE type used at %C "
2043 "is not available on the target machine");
2047 ts
->type
= BT_INTEGER
;
2052 if (gfc_match (" integer") == MATCH_YES
)
2054 ts
->type
= BT_INTEGER
;
2055 ts
->kind
= gfc_default_integer_kind
;
2059 if (gfc_match (" character") == MATCH_YES
)
2061 ts
->type
= BT_CHARACTER
;
2062 if (implicit_flag
== 0)
2063 return match_char_spec (ts
);
2068 if (gfc_match (" real") == MATCH_YES
)
2071 ts
->kind
= gfc_default_real_kind
;
2075 if (gfc_match (" double precision") == MATCH_YES
)
2078 ts
->kind
= gfc_default_double_kind
;
2082 if (gfc_match (" complex") == MATCH_YES
)
2084 ts
->type
= BT_COMPLEX
;
2085 ts
->kind
= gfc_default_complex_kind
;
2089 if (gfc_match (" double complex") == MATCH_YES
)
2091 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
2092 "conform to the Fortran 95 standard") == FAILURE
)
2095 ts
->type
= BT_COMPLEX
;
2096 ts
->kind
= gfc_default_double_kind
;
2100 if (gfc_match (" logical") == MATCH_YES
)
2102 ts
->type
= BT_LOGICAL
;
2103 ts
->kind
= gfc_default_logical_kind
;
2107 m
= gfc_match (" type ( %n )", name
);
2111 /* Search for the name but allow the components to be defined later. */
2112 if (gfc_get_ha_symbol (name
, &sym
))
2114 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2118 if (sym
->attr
.flavor
!= FL_DERIVED
2119 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
2122 ts
->type
= BT_DERIVED
;
2129 /* For all types except double, derived and character, look for an
2130 optional kind specifier. MATCH_NO is actually OK at this point. */
2131 if (implicit_flag
== 1)
2134 if (gfc_current_form
== FORM_FREE
)
2136 c
= gfc_peek_char();
2137 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
2138 && c
!= ':' && c
!= ',')
2142 m
= gfc_match_kind_spec (ts
);
2143 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2144 m
= gfc_match_old_kind_spec (ts
);
2147 m
= MATCH_YES
; /* No kind specifier found. */
2153 /* Match an IMPLICIT NONE statement. Actually, this statement is
2154 already matched in parse.c, or we would not end up here in the
2155 first place. So the only thing we need to check, is if there is
2156 trailing garbage. If not, the match is successful. */
2159 gfc_match_implicit_none (void)
2161 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
2165 /* Match the letter range(s) of an IMPLICIT statement. */
2168 match_implicit_range (void)
2170 int c
, c1
, c2
, inner
;
2173 cur_loc
= gfc_current_locus
;
2175 gfc_gobble_whitespace ();
2176 c
= gfc_next_char ();
2179 gfc_error ("Missing character range in IMPLICIT at %C");
2186 gfc_gobble_whitespace ();
2187 c1
= gfc_next_char ();
2191 gfc_gobble_whitespace ();
2192 c
= gfc_next_char ();
2197 inner
= 0; /* Fall through. */
2204 gfc_gobble_whitespace ();
2205 c2
= gfc_next_char ();
2209 gfc_gobble_whitespace ();
2210 c
= gfc_next_char ();
2212 if ((c
!= ',') && (c
!= ')'))
2225 gfc_error ("Letters must be in alphabetic order in "
2226 "IMPLICIT statement at %C");
2230 /* See if we can add the newly matched range to the pending
2231 implicits from this IMPLICIT statement. We do not check for
2232 conflicts with whatever earlier IMPLICIT statements may have
2233 set. This is done when we've successfully finished matching
2235 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
2242 gfc_syntax_error (ST_IMPLICIT
);
2244 gfc_current_locus
= cur_loc
;
2249 /* Match an IMPLICIT statement, storing the types for
2250 gfc_set_implicit() if the statement is accepted by the parser.
2251 There is a strange looking, but legal syntactic construction
2252 possible. It looks like:
2254 IMPLICIT INTEGER (a-b) (c-d)
2256 This is legal if "a-b" is a constant expression that happens to
2257 equal one of the legal kinds for integers. The real problem
2258 happens with an implicit specification that looks like:
2260 IMPLICIT INTEGER (a-b)
2262 In this case, a typespec matcher that is "greedy" (as most of the
2263 matchers are) gobbles the character range as a kindspec, leaving
2264 nothing left. We therefore have to go a bit more slowly in the
2265 matching process by inhibiting the kindspec checking during
2266 typespec matching and checking for a kind later. */
2269 gfc_match_implicit (void)
2276 /* We don't allow empty implicit statements. */
2277 if (gfc_match_eos () == MATCH_YES
)
2279 gfc_error ("Empty IMPLICIT statement at %C");
2285 /* First cleanup. */
2286 gfc_clear_new_implicit ();
2288 /* A basic type is mandatory here. */
2289 m
= match_type_spec (&ts
, 1);
2290 if (m
== MATCH_ERROR
)
2295 cur_loc
= gfc_current_locus
;
2296 m
= match_implicit_range ();
2300 /* We may have <TYPE> (<RANGE>). */
2301 gfc_gobble_whitespace ();
2302 c
= gfc_next_char ();
2303 if ((c
== '\n') || (c
== ','))
2305 /* Check for CHARACTER with no length parameter. */
2306 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
2308 ts
.kind
= gfc_default_character_kind
;
2309 ts
.cl
= gfc_get_charlen ();
2310 ts
.cl
->next
= gfc_current_ns
->cl_list
;
2311 gfc_current_ns
->cl_list
= ts
.cl
;
2312 ts
.cl
->length
= gfc_int_expr (1);
2315 /* Record the Successful match. */
2316 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2321 gfc_current_locus
= cur_loc
;
2324 /* Discard the (incorrectly) matched range. */
2325 gfc_clear_new_implicit ();
2327 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2328 if (ts
.type
== BT_CHARACTER
)
2329 m
= match_char_spec (&ts
);
2332 m
= gfc_match_kind_spec (&ts
);
2335 m
= gfc_match_old_kind_spec (&ts
);
2336 if (m
== MATCH_ERROR
)
2342 if (m
== MATCH_ERROR
)
2345 m
= match_implicit_range ();
2346 if (m
== MATCH_ERROR
)
2351 gfc_gobble_whitespace ();
2352 c
= gfc_next_char ();
2353 if ((c
!= '\n') && (c
!= ','))
2356 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2364 gfc_syntax_error (ST_IMPLICIT
);
2372 gfc_match_import (void)
2374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2379 if (gfc_current_ns
->proc_name
== NULL
2380 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
2382 gfc_error ("IMPORT statement at %C only permitted in "
2383 "an INTERFACE body");
2387 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IMPORT statement at %C")
2391 if (gfc_match_eos () == MATCH_YES
)
2393 /* All host variables should be imported. */
2394 gfc_current_ns
->has_import_set
= 1;
2398 if (gfc_match (" ::") == MATCH_YES
)
2400 if (gfc_match_eos () == MATCH_YES
)
2402 gfc_error ("Expecting list of named entities at %C");
2409 m
= gfc_match (" %n", name
);
2413 if (gfc_current_ns
->parent
!= NULL
2414 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
2416 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2419 else if (gfc_current_ns
->proc_name
->ns
->parent
!= NULL
2420 && gfc_find_symbol (name
,
2421 gfc_current_ns
->proc_name
->ns
->parent
,
2424 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2430 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2431 "at %C - does not exist.", name
);
2435 if (gfc_find_symtree (gfc_current_ns
->sym_root
,name
))
2437 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2442 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
2445 sym
->attr
.imported
= 1;
2457 if (gfc_match_eos () == MATCH_YES
)
2459 if (gfc_match_char (',') != MATCH_YES
)
2466 gfc_error ("Syntax error in IMPORT statement at %C");
2471 /* A minimal implementation of gfc_match without whitespace, escape
2472 characters or variable arguments. Returns true if the next
2473 characters match the TARGET template exactly. */
2476 match_string_p (const char *target
)
2480 for (p
= target
; *p
; p
++)
2481 if (gfc_next_char () != *p
)
2486 /* Matches an attribute specification including array specs. If
2487 successful, leaves the variables current_attr and current_as
2488 holding the specification. Also sets the colon_seen variable for
2489 later use by matchers associated with initializations.
2491 This subroutine is a little tricky in the sense that we don't know
2492 if we really have an attr-spec until we hit the double colon.
2493 Until that time, we can only return MATCH_NO. This forces us to
2494 check for duplicate specification at this level. */
2497 match_attr_spec (void)
2499 /* Modifiers that can exist in a type statement. */
2501 { GFC_DECL_BEGIN
= 0,
2502 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2503 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2504 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
2505 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
2506 DECL_IS_BIND_C
, DECL_NONE
,
2507 GFC_DECL_END
/* Sentinel */
2511 /* GFC_DECL_END is the sentinel, index starts at 0. */
2512 #define NUM_DECL GFC_DECL_END
2514 locus start
, seen_at
[NUM_DECL
];
2521 gfc_clear_attr (¤t_attr
);
2522 start
= gfc_current_locus
;
2527 /* See if we get all of the keywords up to the final double colon. */
2528 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2536 gfc_gobble_whitespace ();
2538 ch
= gfc_next_char ();
2541 /* This is the successful exit condition for the loop. */
2542 if (gfc_next_char () == ':')
2547 gfc_gobble_whitespace ();
2548 switch (gfc_peek_char ())
2551 if (match_string_p ("allocatable"))
2552 d
= DECL_ALLOCATABLE
;
2556 /* Try and match the bind(c). */
2557 m
= gfc_match_bind_c (NULL
);
2560 else if (m
== MATCH_ERROR
)
2565 if (match_string_p ("dimension"))
2570 if (match_string_p ("external"))
2575 if (match_string_p ("int"))
2577 ch
= gfc_next_char ();
2580 if (match_string_p ("nt"))
2582 /* Matched "intent". */
2583 /* TODO: Call match_intent_spec from here. */
2584 if (gfc_match (" ( in out )") == MATCH_YES
)
2586 else if (gfc_match (" ( in )") == MATCH_YES
)
2588 else if (gfc_match (" ( out )") == MATCH_YES
)
2594 if (match_string_p ("insic"))
2596 /* Matched "intrinsic". */
2604 if (match_string_p ("optional"))
2610 switch (gfc_next_char ())
2613 if (match_string_p ("rameter"))
2615 /* Matched "parameter". */
2621 if (match_string_p ("inter"))
2623 /* Matched "pointer". */
2629 ch
= gfc_next_char ();
2632 if (match_string_p ("vate"))
2634 /* Matched "private". */
2640 if (match_string_p ("tected"))
2642 /* Matched "protected". */
2649 if (match_string_p ("blic"))
2651 /* Matched "public". */
2659 if (match_string_p ("save"))
2664 if (match_string_p ("target"))
2670 ch
= gfc_next_char ();
2673 if (match_string_p ("lue"))
2675 /* Matched "value". */
2681 if (match_string_p ("latile"))
2683 /* Matched "volatile". */
2691 /* No double colon and no recognizable decl_type, so assume that
2692 we've been looking at something else the whole time. */
2700 seen_at
[d
] = gfc_current_locus
;
2702 if (d
== DECL_DIMENSION
)
2704 m
= gfc_match_array_spec (¤t_as
);
2708 gfc_error ("Missing dimension specification at %C");
2712 if (m
== MATCH_ERROR
)
2717 /* Since we've seen a double colon, we have to be looking at an
2718 attr-spec. This means that we can now issue errors. */
2719 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2724 case DECL_ALLOCATABLE
:
2725 attr
= "ALLOCATABLE";
2727 case DECL_DIMENSION
:
2734 attr
= "INTENT (IN)";
2737 attr
= "INTENT (OUT)";
2740 attr
= "INTENT (IN OUT)";
2742 case DECL_INTRINSIC
:
2748 case DECL_PARAMETER
:
2754 case DECL_PROTECTED
:
2769 case DECL_IS_BIND_C
:
2779 attr
= NULL
; /* This shouldn't happen. */
2782 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2787 /* Now that we've dealt with duplicate attributes, add the attributes
2788 to the current attribute. */
2789 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2794 if (gfc_current_state () == COMP_DERIVED
2795 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2796 && d
!= DECL_PRIVATE
&& d
!= DECL_PUBLIC
2799 if (d
== DECL_ALLOCATABLE
)
2801 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ALLOCATABLE "
2802 "attribute at %C in a TYPE definition")
2811 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2818 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2819 && gfc_current_state () != COMP_MODULE
)
2821 if (d
== DECL_PRIVATE
)
2825 if (gfc_current_state () == COMP_DERIVED
2826 && gfc_state_stack
->previous
2827 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
2829 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Attribute %s "
2830 "at %L in a TYPE definition", attr
,
2840 gfc_error ("%s attribute at %L is not allowed outside of the "
2841 "specification part of a module", attr
, &seen_at
[d
]);
2849 case DECL_ALLOCATABLE
:
2850 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2853 case DECL_DIMENSION
:
2854 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2858 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2862 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2866 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2870 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2873 case DECL_INTRINSIC
:
2874 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2878 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2881 case DECL_PARAMETER
:
2882 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2886 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2889 case DECL_PROTECTED
:
2890 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2892 gfc_error ("PROTECTED at %C only allowed in specification "
2893 "part of a module");
2898 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED "
2903 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
2907 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2912 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2917 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2921 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2924 case DECL_IS_BIND_C
:
2925 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
2929 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE attribute "
2934 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
2938 if (gfc_notify_std (GFC_STD_F2003
,
2939 "Fortran 2003: VOLATILE attribute at %C")
2943 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
2947 gfc_internal_error ("match_attr_spec(): Bad attribute");
2961 gfc_current_locus
= start
;
2962 gfc_free_array_spec (current_as
);
2968 /* Set the binding label, dest_label, either with the binding label
2969 stored in the given gfc_typespec, ts, or if none was provided, it
2970 will be the symbol name in all lower case, as required by the draft
2971 (J3/04-007, section 15.4.1). If a binding label was given and
2972 there is more than one argument (num_idents), it is an error. */
2975 set_binding_label (char *dest_label
, const char *sym_name
, int num_idents
)
2977 if (num_idents
> 1 && has_name_equals
)
2979 gfc_error ("Multiple identifiers provided with "
2980 "single NAME= specifier at %C");
2984 if (curr_binding_label
[0] != '\0')
2986 /* Binding label given; store in temp holder til have sym. */
2987 strncpy (dest_label
, curr_binding_label
,
2988 strlen (curr_binding_label
) + 1);
2992 /* No binding label given, and the NAME= specifier did not exist,
2993 which means there was no NAME="". */
2994 if (sym_name
!= NULL
&& has_name_equals
== 0)
2995 strncpy (dest_label
, sym_name
, strlen (sym_name
) + 1);
3002 /* Set the status of the given common block as being BIND(C) or not,
3003 depending on the given parameter, is_bind_c. */
3006 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
3008 com_block
->is_bind_c
= is_bind_c
;
3013 /* Verify that the given gfc_typespec is for a C interoperable type. */
3016 verify_c_interop (gfc_typespec
*ts
, const char *name
, locus
*where
)
3020 /* Make sure the kind used is appropriate for the type.
3021 The f90_type is unknown if an integer constant was
3022 used (e.g., real(4), bind(c) :: myFloat). */
3023 if (ts
->f90_type
!= BT_UNKNOWN
)
3025 t
= gfc_validate_c_kind (ts
);
3028 /* Print an error, but continue parsing line. */
3029 gfc_error_now ("C kind parameter is for type %s but "
3030 "symbol '%s' at %L is of type %s",
3031 gfc_basic_typename (ts
->f90_type
),
3033 gfc_basic_typename (ts
->type
));
3037 /* Make sure the kind is C interoperable. This does not care about the
3038 possible error above. */
3039 if (ts
->type
== BT_DERIVED
&& ts
->derived
!= NULL
)
3040 return (ts
->derived
->ts
.is_c_interop
? SUCCESS
: FAILURE
);
3041 else if (ts
->is_c_interop
!= 1)
3048 /* Verify that the variables of a given common block, which has been
3049 defined with the attribute specifier bind(c), to be of a C
3050 interoperable type. Errors will be reported here, if
3054 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
3056 gfc_symbol
*curr_sym
= NULL
;
3057 try retval
= SUCCESS
;
3059 curr_sym
= com_block
->head
;
3061 /* Make sure we have at least one symbol. */
3062 if (curr_sym
== NULL
)
3065 /* Here we know we have a symbol, so we'll execute this loop
3069 /* The second to last param, 1, says this is in a common block. */
3070 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
3071 curr_sym
= curr_sym
->common_next
;
3072 } while (curr_sym
!= NULL
);
3078 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3079 an appropriate error message is reported. */
3082 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
3083 int is_in_common
, gfc_common_head
*com_block
)
3085 try retval
= SUCCESS
;
3087 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
3089 tmp_sym
= tmp_sym
->result
;
3090 /* Make sure it wasn't an implicitly typed result. */
3091 if (tmp_sym
->attr
.implicit_type
)
3093 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3094 "%L may not be C interoperable", tmp_sym
->name
,
3095 &tmp_sym
->declared_at
);
3096 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
3097 /* Mark it as C interoperable to prevent duplicate warnings. */
3098 tmp_sym
->ts
.is_c_interop
= 1;
3099 tmp_sym
->attr
.is_c_interop
= 1;
3103 /* Here, we know we have the bind(c) attribute, so if we have
3104 enough type info, then verify that it's a C interop kind.
3105 The info could be in the symbol already, or possibly still in
3106 the given ts (current_ts), so look in both. */
3107 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
3109 if (verify_c_interop (&(tmp_sym
->ts
), tmp_sym
->name
,
3110 &(tmp_sym
->declared_at
)) != SUCCESS
)
3112 /* See if we're dealing with a sym in a common block or not. */
3113 if (is_in_common
== 1)
3115 gfc_warning ("Variable '%s' in common block '%s' at %L "
3116 "may not be a C interoperable "
3117 "kind though common block '%s' is BIND(C)",
3118 tmp_sym
->name
, com_block
->name
,
3119 &(tmp_sym
->declared_at
), com_block
->name
);
3123 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
3124 gfc_error ("Type declaration '%s' at %L is not C "
3125 "interoperable but it is BIND(C)",
3126 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3128 gfc_warning ("Variable '%s' at %L "
3129 "may not be a C interoperable "
3130 "kind but it is bind(c)",
3131 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3135 /* Variables declared w/in a common block can't be bind(c)
3136 since there's no way for C to see these variables, so there's
3137 semantically no reason for the attribute. */
3138 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
3140 gfc_error ("Variable '%s' in common block '%s' at "
3141 "%L cannot be declared with BIND(C) "
3142 "since it is not a global",
3143 tmp_sym
->name
, com_block
->name
,
3144 &(tmp_sym
->declared_at
));
3148 /* Scalar variables that are bind(c) can not have the pointer
3149 or allocatable attributes. */
3150 if (tmp_sym
->attr
.is_bind_c
== 1)
3152 if (tmp_sym
->attr
.pointer
== 1)
3154 gfc_error ("Variable '%s' at %L cannot have both the "
3155 "POINTER and BIND(C) attributes",
3156 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3160 if (tmp_sym
->attr
.allocatable
== 1)
3162 gfc_error ("Variable '%s' at %L cannot have both the "
3163 "ALLOCATABLE and BIND(C) attributes",
3164 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3168 /* If it is a BIND(C) function, make sure the return value is a
3169 scalar value. The previous tests in this function made sure
3170 the type is interoperable. */
3171 if (tmp_sym
->attr
.function
== 1 && tmp_sym
->as
!= NULL
)
3172 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3173 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
3175 /* BIND(C) functions can not return a character string. */
3176 if (tmp_sym
->attr
.function
== 1 && tmp_sym
->ts
.type
== BT_CHARACTER
)
3177 if (tmp_sym
->ts
.cl
== NULL
|| tmp_sym
->ts
.cl
->length
== NULL
3178 || tmp_sym
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3179 || mpz_cmp_si (tmp_sym
->ts
.cl
->length
->value
.integer
, 1) != 0)
3180 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3181 "be a character string", tmp_sym
->name
,
3182 &(tmp_sym
->declared_at
));
3186 /* See if the symbol has been marked as private. If it has, make sure
3187 there is no binding label and warn the user if there is one. */
3188 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
3189 && tmp_sym
->binding_label
[0] != '\0')
3190 /* Use gfc_warning_now because we won't say that the symbol fails
3191 just because of this. */
3192 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3193 "given the binding label '%s'", tmp_sym
->name
,
3194 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
3200 /* Set the appropriate fields for a symbol that's been declared as
3201 BIND(C) (the is_bind_c flag and the binding label), and verify that
3202 the type is C interoperable. Errors are reported by the functions
3203 used to set/test these fields. */
3206 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
3208 try retval
= SUCCESS
;
3210 /* TODO: Do we need to make sure the vars aren't marked private? */
3212 /* Set the is_bind_c bit in symbol_attribute. */
3213 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
3215 if (set_binding_label (tmp_sym
->binding_label
, tmp_sym
->name
,
3216 num_idents
) != SUCCESS
)
3223 /* Set the fields marking the given common block as BIND(C), including
3224 a binding label, and report any errors encountered. */
3227 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
3229 try retval
= SUCCESS
;
3231 /* destLabel, common name, typespec (which may have binding label). */
3232 if (set_binding_label (com_block
->binding_label
, com_block
->name
, num_idents
)
3236 /* Set the given common block (com_block) to being bind(c) (1). */
3237 set_com_block_bind_c (com_block
, 1);
3243 /* Retrieve the list of one or more identifiers that the given bind(c)
3244 attribute applies to. */
3247 get_bind_c_idents (void)
3249 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3251 gfc_symbol
*tmp_sym
= NULL
;
3253 gfc_common_head
*com_block
= NULL
;
3255 if (gfc_match_name (name
) == MATCH_YES
)
3257 found_id
= MATCH_YES
;
3258 gfc_get_ha_symbol (name
, &tmp_sym
);
3260 else if (match_common_name (name
) == MATCH_YES
)
3262 found_id
= MATCH_YES
;
3263 com_block
= gfc_get_common (name
, 0);
3267 gfc_error ("Need either entity or common block name for "
3268 "attribute specification statement at %C");
3272 /* Save the current identifier and look for more. */
3275 /* Increment the number of identifiers found for this spec stmt. */
3278 /* Make sure we have a sym or com block, and verify that it can
3279 be bind(c). Set the appropriate field(s) and look for more
3281 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
3283 if (tmp_sym
!= NULL
)
3285 if (set_verify_bind_c_sym (tmp_sym
, num_idents
)
3291 if (set_verify_bind_c_com_block(com_block
, num_idents
)
3296 /* Look to see if we have another identifier. */
3298 if (gfc_match_eos () == MATCH_YES
)
3299 found_id
= MATCH_NO
;
3300 else if (gfc_match_char (',') != MATCH_YES
)
3301 found_id
= MATCH_NO
;
3302 else if (gfc_match_name (name
) == MATCH_YES
)
3304 found_id
= MATCH_YES
;
3305 gfc_get_ha_symbol (name
, &tmp_sym
);
3307 else if (match_common_name (name
) == MATCH_YES
)
3309 found_id
= MATCH_YES
;
3310 com_block
= gfc_get_common (name
, 0);
3314 gfc_error ("Missing entity or common block name for "
3315 "attribute specification statement at %C");
3321 gfc_internal_error ("Missing symbol");
3323 } while (found_id
== MATCH_YES
);
3325 /* if we get here we were successful */
3330 /* Try and match a BIND(C) attribute specification statement. */
3333 gfc_match_bind_c_stmt (void)
3335 match found_match
= MATCH_NO
;
3340 /* This may not be necessary. */
3342 /* Clear the temporary binding label holder. */
3343 curr_binding_label
[0] = '\0';
3345 /* Look for the bind(c). */
3346 found_match
= gfc_match_bind_c (NULL
);
3348 if (found_match
== MATCH_YES
)
3350 /* Look for the :: now, but it is not required. */
3353 /* Get the identifier(s) that needs to be updated. This may need to
3354 change to hand the flag(s) for the attr specified so all identifiers
3355 found can have all appropriate parts updated (assuming that the same
3356 spec stmt can have multiple attrs, such as both bind(c) and
3358 if (get_bind_c_idents () != SUCCESS
)
3359 /* Error message should have printed already. */
3367 /* Match a data declaration statement. */
3370 gfc_match_data_decl (void)
3376 num_idents_on_line
= 0;
3378 m
= match_type_spec (¤t_ts
, 0);
3382 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
3384 sym
= gfc_use_derived (current_ts
.derived
);
3392 current_ts
.derived
= sym
;
3395 m
= match_attr_spec ();
3396 if (m
== MATCH_ERROR
)
3402 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
3405 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
3408 gfc_find_symbol (current_ts
.derived
->name
,
3409 current_ts
.derived
->ns
->parent
, 1, &sym
);
3411 /* Any symbol that we find had better be a type definition
3412 which has its components defined. */
3413 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
3414 && current_ts
.derived
->components
!= NULL
)
3417 /* Now we have an error, which we signal, and then fix up
3418 because the knock-on is plain and simple confusing. */
3419 gfc_error_now ("Derived type at %C has not been previously defined "
3420 "and so cannot appear in a derived type definition");
3421 current_attr
.pointer
= 1;
3426 /* If we have an old-style character declaration, and no new-style
3427 attribute specifications, then there a comma is optional between
3428 the type specification and the variable list. */
3429 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
3430 gfc_match_char (',');
3432 /* Give the types/attributes to symbols that follow. Give the element
3433 a number so that repeat character length expressions can be copied. */
3437 num_idents_on_line
++;
3438 m
= variable_decl (elem
++);
3439 if (m
== MATCH_ERROR
)
3444 if (gfc_match_eos () == MATCH_YES
)
3446 if (gfc_match_char (',') != MATCH_YES
)
3450 if (gfc_error_flag_test () == 0)
3451 gfc_error ("Syntax error in data declaration at %C");
3454 gfc_free_data_all (gfc_current_ns
);
3457 gfc_free_array_spec (current_as
);
3463 /* Match a prefix associated with a function or subroutine
3464 declaration. If the typespec pointer is nonnull, then a typespec
3465 can be matched. Note that if nothing matches, MATCH_YES is
3466 returned (the null string was matched). */
3469 match_prefix (gfc_typespec
*ts
)
3473 gfc_clear_attr (¤t_attr
);
3477 if (!seen_type
&& ts
!= NULL
3478 && match_type_spec (ts
, 0) == MATCH_YES
3479 && gfc_match_space () == MATCH_YES
)
3486 if (gfc_match ("elemental% ") == MATCH_YES
)
3488 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
3494 if (gfc_match ("pure% ") == MATCH_YES
)
3496 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
3502 if (gfc_match ("recursive% ") == MATCH_YES
)
3504 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
3510 /* At this point, the next item is not a prefix. */
3515 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
3518 copy_prefix (symbol_attribute
*dest
, locus
*where
)
3520 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
3523 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
3526 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
3533 /* Match a formal argument list. */
3536 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
3538 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
3539 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3545 if (gfc_match_char ('(') != MATCH_YES
)
3552 if (gfc_match_char (')') == MATCH_YES
)
3557 if (gfc_match_char ('*') == MATCH_YES
)
3561 m
= gfc_match_name (name
);
3565 if (gfc_get_symbol (name
, NULL
, &sym
))
3569 p
= gfc_get_formal_arglist ();
3581 /* We don't add the VARIABLE flavor because the name could be a
3582 dummy procedure. We don't apply these attributes to formal
3583 arguments of statement functions. */
3584 if (sym
!= NULL
&& !st_flag
3585 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
3586 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
3592 /* The name of a program unit can be in a different namespace,
3593 so check for it explicitly. After the statement is accepted,
3594 the name is checked for especially in gfc_get_symbol(). */
3595 if (gfc_new_block
!= NULL
&& sym
!= NULL
3596 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
3598 gfc_error ("Name '%s' at %C is the name of the procedure",
3604 if (gfc_match_char (')') == MATCH_YES
)
3607 m
= gfc_match_char (',');
3610 gfc_error ("Unexpected junk in formal argument list at %C");
3616 /* Check for duplicate symbols in the formal argument list. */
3619 for (p
= head
; p
->next
; p
= p
->next
)
3624 for (q
= p
->next
; q
; q
= q
->next
)
3625 if (p
->sym
== q
->sym
)
3627 gfc_error ("Duplicate symbol '%s' in formal argument list "
3628 "at %C", p
->sym
->name
);
3636 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
)
3646 gfc_free_formal_arglist (head
);
3651 /* Match a RESULT specification following a function declaration or
3652 ENTRY statement. Also matches the end-of-statement. */
3655 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
3657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3661 if (gfc_match (" result (") != MATCH_YES
)
3664 m
= gfc_match_name (name
);
3668 /* Get the right paren, and that's it because there could be the
3669 bind(c) attribute after the result clause. */
3670 if (gfc_match_char(')') != MATCH_YES
)
3672 /* TODO: should report the missing right paren here. */
3676 if (strcmp (function
->name
, name
) == 0)
3678 gfc_error ("RESULT variable at %C must be different than function name");
3682 if (gfc_get_symbol (name
, NULL
, &r
))
3685 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
3686 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
3695 /* Match a function suffix, which could be a combination of a result
3696 clause and BIND(C), either one, or neither. The draft does not
3697 require them to come in a specific order. */
3700 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
3702 match is_bind_c
; /* Found bind(c). */
3703 match is_result
; /* Found result clause. */
3704 match found_match
; /* Status of whether we've found a good match. */
3705 int peek_char
; /* Character we're going to peek at. */
3707 /* Initialize to having found nothing. */
3708 found_match
= MATCH_NO
;
3709 is_bind_c
= MATCH_NO
;
3710 is_result
= MATCH_NO
;
3712 /* Get the next char to narrow between result and bind(c). */
3713 gfc_gobble_whitespace ();
3714 peek_char
= gfc_peek_char ();
3719 /* Look for result clause. */
3720 is_result
= match_result (sym
, result
);
3721 if (is_result
== MATCH_YES
)
3723 /* Now see if there is a bind(c) after it. */
3724 is_bind_c
= gfc_match_bind_c (sym
);
3725 /* We've found the result clause and possibly bind(c). */
3726 found_match
= MATCH_YES
;
3729 /* This should only be MATCH_ERROR. */
3730 found_match
= is_result
;
3733 /* Look for bind(c) first. */
3734 is_bind_c
= gfc_match_bind_c (sym
);
3735 if (is_bind_c
== MATCH_YES
)
3737 /* Now see if a result clause followed it. */
3738 is_result
= match_result (sym
, result
);
3739 found_match
= MATCH_YES
;
3743 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
3744 found_match
= MATCH_ERROR
;
3748 gfc_error ("Unexpected junk after function declaration at %C");
3749 found_match
= MATCH_ERROR
;
3753 if (is_bind_c
== MATCH_YES
)
3754 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1)
3762 /* Match a function declaration. */
3765 gfc_match_function_decl (void)
3767 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3768 gfc_symbol
*sym
, *result
;
3772 match found_match
; /* Status returned by match func. */
3774 if (gfc_current_state () != COMP_NONE
3775 && gfc_current_state () != COMP_INTERFACE
3776 && gfc_current_state () != COMP_CONTAINS
)
3779 gfc_clear_ts (¤t_ts
);
3781 old_loc
= gfc_current_locus
;
3783 m
= match_prefix (¤t_ts
);
3786 gfc_current_locus
= old_loc
;
3790 if (gfc_match ("function% %n", name
) != MATCH_YES
)
3792 gfc_current_locus
= old_loc
;
3795 if (get_proc_name (name
, &sym
, false))
3797 gfc_new_block
= sym
;
3799 m
= gfc_match_formal_arglist (sym
, 0, 0);
3802 gfc_error ("Expected formal argument list in function "
3803 "definition at %C");
3807 else if (m
== MATCH_ERROR
)
3812 /* According to the draft, the bind(c) and result clause can
3813 come in either order after the formal_arg_list (i.e., either
3814 can be first, both can exist together or by themselves or neither
3815 one). Therefore, the match_result can't match the end of the
3816 string, and check for the bind(c) or result clause in either order. */
3817 found_match
= gfc_match_eos ();
3819 /* Make sure that it isn't already declared as BIND(C). If it is, it
3820 must have been marked BIND(C) with a BIND(C) attribute and that is
3821 not allowed for procedures. */
3822 if (sym
->attr
.is_bind_c
== 1)
3824 sym
->attr
.is_bind_c
= 0;
3825 if (sym
->old_symbol
!= NULL
)
3826 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3827 "variables or common blocks",
3828 &(sym
->old_symbol
->declared_at
));
3830 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3831 "variables or common blocks", &gfc_current_locus
);
3834 if (found_match
!= MATCH_YES
)
3836 /* If we haven't found the end-of-statement, look for a suffix. */
3837 suffix_match
= gfc_match_suffix (sym
, &result
);
3838 if (suffix_match
== MATCH_YES
)
3839 /* Need to get the eos now. */
3840 found_match
= gfc_match_eos ();
3842 found_match
= suffix_match
;
3845 if(found_match
!= MATCH_YES
)
3849 /* Make changes to the symbol. */
3852 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3855 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
3856 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
3859 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
3860 && !sym
->attr
.implicit_type
)
3862 gfc_error ("Function '%s' at %C already has a type of %s", name
,
3863 gfc_basic_typename (sym
->ts
.type
));
3869 sym
->ts
= current_ts
;
3874 result
->ts
= current_ts
;
3875 sym
->result
= result
;
3882 gfc_current_locus
= old_loc
;
3887 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
3888 pass the name of the entry, rather than the gfc_current_block name, and
3889 to return false upon finding an existing global entry. */
3892 add_global_entry (const char *name
, int sub
)
3896 s
= gfc_get_gsymbol(name
);
3899 || (s
->type
!= GSYM_UNKNOWN
3900 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3901 global_used(s
, NULL
);
3904 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3905 s
->where
= gfc_current_locus
;
3913 /* Match an ENTRY statement. */
3916 gfc_match_entry (void)
3921 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3922 gfc_compile_state state
;
3926 bool module_procedure
;
3928 m
= gfc_match_name (name
);
3932 state
= gfc_current_state ();
3933 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
3938 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
3941 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
3943 case COMP_BLOCK_DATA
:
3944 gfc_error ("ENTRY statement at %C cannot appear within "
3947 case COMP_INTERFACE
:
3948 gfc_error ("ENTRY statement at %C cannot appear within "
3952 gfc_error ("ENTRY statement at %C cannot appear within "
3953 "a DERIVED TYPE block");
3956 gfc_error ("ENTRY statement at %C cannot appear within "
3957 "an IF-THEN block");
3960 gfc_error ("ENTRY statement at %C cannot appear within "
3964 gfc_error ("ENTRY statement at %C cannot appear within "
3968 gfc_error ("ENTRY statement at %C cannot appear within "
3972 gfc_error ("ENTRY statement at %C cannot appear within "
3976 gfc_error ("ENTRY statement at %C cannot appear within "
3977 "a contained subprogram");
3980 gfc_internal_error ("gfc_match_entry(): Bad state");
3985 module_procedure
= gfc_current_ns
->parent
!= NULL
3986 && gfc_current_ns
->parent
->proc_name
3987 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
3990 if (gfc_current_ns
->parent
!= NULL
3991 && gfc_current_ns
->parent
->proc_name
3992 && !module_procedure
)
3994 gfc_error("ENTRY statement at %C cannot appear in a "
3995 "contained procedure");
3999 /* Module function entries need special care in get_proc_name
4000 because previous references within the function will have
4001 created symbols attached to the current namespace. */
4002 if (get_proc_name (name
, &entry
,
4003 gfc_current_ns
->parent
!= NULL
4005 && gfc_current_ns
->proc_name
->attr
.function
))
4008 proc
= gfc_current_block ();
4010 if (state
== COMP_SUBROUTINE
)
4012 /* An entry in a subroutine. */
4013 if (!add_global_entry (name
, 1))
4016 m
= gfc_match_formal_arglist (entry
, 0, 1);
4020 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
4021 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
4026 /* An entry in a function.
4027 We need to take special care because writing
4032 ENTRY f() RESULT (r)
4034 ENTRY f RESULT (r). */
4035 if (!add_global_entry (name
, 0))
4038 old_loc
= gfc_current_locus
;
4039 if (gfc_match_eos () == MATCH_YES
)
4041 gfc_current_locus
= old_loc
;
4042 /* Match the empty argument list, and add the interface to
4044 m
= gfc_match_formal_arglist (entry
, 0, 1);
4047 m
= gfc_match_formal_arglist (entry
, 0, 0);
4054 if (gfc_match_eos () == MATCH_YES
)
4056 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
4057 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
4060 entry
->result
= entry
;
4064 m
= match_result (proc
, &result
);
4066 gfc_syntax_error (ST_ENTRY
);
4070 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
4071 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
4072 || gfc_add_function (&entry
->attr
, result
->name
, NULL
)
4076 entry
->result
= result
;
4080 if (gfc_match_eos () != MATCH_YES
)
4082 gfc_syntax_error (ST_ENTRY
);
4086 entry
->attr
.recursive
= proc
->attr
.recursive
;
4087 entry
->attr
.elemental
= proc
->attr
.elemental
;
4088 entry
->attr
.pure
= proc
->attr
.pure
;
4090 el
= gfc_get_entry_list ();
4092 el
->next
= gfc_current_ns
->entries
;
4093 gfc_current_ns
->entries
= el
;
4095 el
->id
= el
->next
->id
+ 1;
4099 new_st
.op
= EXEC_ENTRY
;
4100 new_st
.ext
.entry
= el
;
4106 /* Match a subroutine statement, including optional prefixes. */
4109 gfc_match_subroutine (void)
4111 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4117 if (gfc_current_state () != COMP_NONE
4118 && gfc_current_state () != COMP_INTERFACE
4119 && gfc_current_state () != COMP_CONTAINS
)
4122 m
= match_prefix (NULL
);
4126 m
= gfc_match ("subroutine% %n", name
);
4130 if (get_proc_name (name
, &sym
, false))
4132 gfc_new_block
= sym
;
4134 /* Check what next non-whitespace character is so we can tell if there
4135 where the required parens if we have a BIND(C). */
4136 gfc_gobble_whitespace ();
4137 peek_char
= gfc_peek_char ();
4139 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
4142 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
4145 /* Make sure that it isn't already declared as BIND(C). If it is, it
4146 must have been marked BIND(C) with a BIND(C) attribute and that is
4147 not allowed for procedures. */
4148 if (sym
->attr
.is_bind_c
== 1)
4150 sym
->attr
.is_bind_c
= 0;
4151 if (sym
->old_symbol
!= NULL
)
4152 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4153 "variables or common blocks",
4154 &(sym
->old_symbol
->declared_at
));
4156 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4157 "variables or common blocks", &gfc_current_locus
);
4160 /* Here, we are just checking if it has the bind(c) attribute, and if
4161 so, then we need to make sure it's all correct. If it doesn't,
4162 we still need to continue matching the rest of the subroutine line. */
4163 is_bind_c
= gfc_match_bind_c (sym
);
4164 if (is_bind_c
== MATCH_ERROR
)
4166 /* There was an attempt at the bind(c), but it was wrong. An
4167 error message should have been printed w/in the gfc_match_bind_c
4168 so here we'll just return the MATCH_ERROR. */
4172 if (is_bind_c
== MATCH_YES
)
4174 if (peek_char
!= '(')
4176 gfc_error ("Missing required parentheses before BIND(C) at %C");
4179 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1)
4184 if (gfc_match_eos () != MATCH_YES
)
4186 gfc_syntax_error (ST_SUBROUTINE
);
4190 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
4197 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4198 given, and set the binding label in either the given symbol (if not
4199 NULL), or in the current_ts. The symbol may be NULL because we may
4200 encounter the BIND(C) before the declaration itself. Return
4201 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4202 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4203 or MATCH_YES if the specifier was correct and the binding label and
4204 bind(c) fields were set correctly for the given symbol or the
4208 gfc_match_bind_c (gfc_symbol
*sym
)
4210 /* binding label, if exists */
4211 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
4215 /* Initialize the flag that specifies whether we encountered a NAME=
4216 specifier or not. */
4217 has_name_equals
= 0;
4219 /* Init the first char to nil so we can catch if we don't have
4220 the label (name attr) or the symbol name yet. */
4221 binding_label
[0] = '\0';
4223 /* This much we have to be able to match, in this order, if
4224 there is a bind(c) label. */
4225 if (gfc_match (" bind ( c ") != MATCH_YES
)
4228 /* Now see if there is a binding label, or if we've reached the
4229 end of the bind(c) attribute without one. */
4230 if (gfc_match_char (',') == MATCH_YES
)
4232 if (gfc_match (" name = ") != MATCH_YES
)
4234 gfc_error ("Syntax error in NAME= specifier for binding label "
4236 /* should give an error message here */
4240 has_name_equals
= 1;
4242 /* Get the opening quote. */
4243 double_quote
= MATCH_YES
;
4244 single_quote
= MATCH_YES
;
4245 double_quote
= gfc_match_char ('"');
4246 if (double_quote
!= MATCH_YES
)
4247 single_quote
= gfc_match_char ('\'');
4248 if (double_quote
!= MATCH_YES
&& single_quote
!= MATCH_YES
)
4250 gfc_error ("Syntax error in NAME= specifier for binding label "
4255 /* Grab the binding label, using functions that will not lower
4256 case the names automatically. */
4257 if (gfc_match_name_C (binding_label
) != MATCH_YES
)
4260 /* Get the closing quotation. */
4261 if (double_quote
== MATCH_YES
)
4263 if (gfc_match_char ('"') != MATCH_YES
)
4265 gfc_error ("Missing closing quote '\"' for binding label at %C");
4266 /* User started string with '"' so looked to match it. */
4272 if (gfc_match_char ('\'') != MATCH_YES
)
4274 gfc_error ("Missing closing quote '\'' for binding label at %C");
4275 /* User started string with "'" char. */
4281 /* Get the required right paren. */
4282 if (gfc_match_char (')') != MATCH_YES
)
4284 gfc_error ("Missing closing paren for binding label at %C");
4288 /* Save the binding label to the symbol. If sym is null, we're
4289 probably matching the typespec attributes of a declaration and
4290 haven't gotten the name yet, and therefore, no symbol yet. */
4291 if (binding_label
[0] != '\0')
4295 strncpy (sym
->binding_label
, binding_label
,
4296 strlen (binding_label
)+1);
4299 strncpy (curr_binding_label
, binding_label
,
4300 strlen (binding_label
) + 1);
4304 /* No binding label, but if symbol isn't null, we
4305 can set the label for it here. */
4306 /* TODO: If the name= was given and no binding label (name=""), we simply
4307 will let fortran mangle the symbol name as it usually would.
4308 However, this could still let C call it if the user looked up the
4309 symbol in the object file. Should the name set during mangling in
4310 trans-decl.c be marked with characters that are invalid for C to
4312 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
4313 strncpy (sym
->binding_label
, sym
->name
, strlen (sym
->name
) + 1);
4316 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
4317 && current_interface
.type
== INTERFACE_ABSTRACT
)
4319 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4327 /* Return nonzero if we're currently compiling a contained procedure. */
4330 contained_procedure (void)
4334 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
4335 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
4336 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
4342 /* Set the kind of each enumerator. The kind is selected such that it is
4343 interoperable with the corresponding C enumeration type, making
4344 sure that -fshort-enums is honored. */
4349 enumerator_history
*current_history
= NULL
;
4353 if (max_enum
== NULL
|| enum_history
== NULL
)
4356 if (!gfc_option
.fshort_enums
)
4362 kind
= gfc_integer_kinds
[i
++].kind
;
4364 while (kind
< gfc_c_int_kind
4365 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
4368 current_history
= enum_history
;
4369 while (current_history
!= NULL
)
4371 current_history
->sym
->ts
.kind
= kind
;
4372 current_history
= current_history
->next
;
4377 /* Match any of the various end-block statements. Returns the type of
4378 END to the caller. The END INTERFACE, END IF, END DO and END
4379 SELECT statements cannot be replaced by a single END statement. */
4382 gfc_match_end (gfc_statement
*st
)
4384 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4385 gfc_compile_state state
;
4387 const char *block_name
;
4392 old_loc
= gfc_current_locus
;
4393 if (gfc_match ("end") != MATCH_YES
)
4396 state
= gfc_current_state ();
4397 block_name
= gfc_current_block () == NULL
4398 ? NULL
: gfc_current_block ()->name
;
4400 if (state
== COMP_CONTAINS
)
4402 state
= gfc_state_stack
->previous
->state
;
4403 block_name
= gfc_state_stack
->previous
->sym
== NULL
4404 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
4411 *st
= ST_END_PROGRAM
;
4412 target
= " program";
4416 case COMP_SUBROUTINE
:
4417 *st
= ST_END_SUBROUTINE
;
4418 target
= " subroutine";
4419 eos_ok
= !contained_procedure ();
4423 *st
= ST_END_FUNCTION
;
4424 target
= " function";
4425 eos_ok
= !contained_procedure ();
4428 case COMP_BLOCK_DATA
:
4429 *st
= ST_END_BLOCK_DATA
;
4430 target
= " block data";
4435 *st
= ST_END_MODULE
;
4440 case COMP_INTERFACE
:
4441 *st
= ST_END_INTERFACE
;
4442 target
= " interface";
4465 *st
= ST_END_SELECT
;
4471 *st
= ST_END_FORALL
;
4486 last_initializer
= NULL
;
4488 gfc_free_enum_history ();
4492 gfc_error ("Unexpected END statement at %C");
4496 if (gfc_match_eos () == MATCH_YES
)
4500 /* We would have required END [something]. */
4501 gfc_error ("%s statement expected at %L",
4502 gfc_ascii_statement (*st
), &old_loc
);
4509 /* Verify that we've got the sort of end-block that we're expecting. */
4510 if (gfc_match (target
) != MATCH_YES
)
4512 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
4516 /* If we're at the end, make sure a block name wasn't required. */
4517 if (gfc_match_eos () == MATCH_YES
)
4520 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
4521 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
)
4524 if (gfc_current_block () == NULL
)
4527 gfc_error ("Expected block name of '%s' in %s statement at %C",
4528 block_name
, gfc_ascii_statement (*st
));
4533 /* END INTERFACE has a special handler for its several possible endings. */
4534 if (*st
== ST_END_INTERFACE
)
4535 return gfc_match_end_interface ();
4537 /* We haven't hit the end of statement, so what is left must be an
4539 m
= gfc_match_space ();
4541 m
= gfc_match_name (name
);
4544 gfc_error ("Expected terminating name at %C");
4548 if (block_name
== NULL
)
4551 if (strcmp (name
, block_name
) != 0)
4553 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
4554 gfc_ascii_statement (*st
));
4558 if (gfc_match_eos () == MATCH_YES
)
4562 gfc_syntax_error (*st
);
4565 gfc_current_locus
= old_loc
;
4571 /***************** Attribute declaration statements ****************/
4573 /* Set the attribute of a single variable. */
4578 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4586 m
= gfc_match_name (name
);
4590 if (find_special (name
, &sym
))
4593 var_locus
= gfc_current_locus
;
4595 /* Deal with possible array specification for certain attributes. */
4596 if (current_attr
.dimension
4597 || current_attr
.allocatable
4598 || current_attr
.pointer
4599 || current_attr
.target
)
4601 m
= gfc_match_array_spec (&as
);
4602 if (m
== MATCH_ERROR
)
4605 if (current_attr
.dimension
&& m
== MATCH_NO
)
4607 gfc_error ("Missing array specification at %L in DIMENSION "
4608 "statement", &var_locus
);
4613 if ((current_attr
.allocatable
|| current_attr
.pointer
)
4614 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
4616 gfc_error ("Array specification must be deferred at %L", &var_locus
);
4622 /* Update symbol table. DIMENSION attribute is set
4623 in gfc_set_array_spec(). */
4624 if (current_attr
.dimension
== 0
4625 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
4631 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
4637 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
4639 /* Fix the array spec. */
4640 m
= gfc_mod_pointee_as (sym
->as
);
4641 if (m
== MATCH_ERROR
)
4645 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
4651 if ((current_attr
.external
|| current_attr
.intrinsic
)
4652 && sym
->attr
.flavor
!= FL_PROCEDURE
4653 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
4662 gfc_free_array_spec (as
);
4667 /* Generic attribute declaration subroutine. Used for attributes that
4668 just have a list of names. */
4675 /* Gobble the optional double colon, by simply ignoring the result
4685 if (gfc_match_eos () == MATCH_YES
)
4691 if (gfc_match_char (',') != MATCH_YES
)
4693 gfc_error ("Unexpected character in variable list at %C");
4703 /* This routine matches Cray Pointer declarations of the form:
4704 pointer ( <pointer>, <pointee> )
4706 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
4707 The pointer, if already declared, should be an integer. Otherwise, we
4708 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
4709 be either a scalar, or an array declaration. No space is allocated for
4710 the pointee. For the statement
4711 pointer (ipt, ar(10))
4712 any subsequent uses of ar will be translated (in C-notation) as
4713 ar(i) => ((<type> *) ipt)(i)
4714 After gimplification, pointee variable will disappear in the code. */
4717 cray_pointer_decl (void)
4721 gfc_symbol
*cptr
; /* Pointer symbol. */
4722 gfc_symbol
*cpte
; /* Pointee symbol. */
4728 if (gfc_match_char ('(') != MATCH_YES
)
4730 gfc_error ("Expected '(' at %C");
4734 /* Match pointer. */
4735 var_locus
= gfc_current_locus
;
4736 gfc_clear_attr (¤t_attr
);
4737 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
4738 current_ts
.type
= BT_INTEGER
;
4739 current_ts
.kind
= gfc_index_integer_kind
;
4741 m
= gfc_match_symbol (&cptr
, 0);
4744 gfc_error ("Expected variable name at %C");
4748 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
4751 gfc_set_sym_referenced (cptr
);
4753 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
4755 cptr
->ts
.type
= BT_INTEGER
;
4756 cptr
->ts
.kind
= gfc_index_integer_kind
;
4758 else if (cptr
->ts
.type
!= BT_INTEGER
)
4760 gfc_error ("Cray pointer at %C must be an integer");
4763 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
4764 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
4765 " memory addresses require %d bytes",
4766 cptr
->ts
.kind
, gfc_index_integer_kind
);
4768 if (gfc_match_char (',') != MATCH_YES
)
4770 gfc_error ("Expected \",\" at %C");
4774 /* Match Pointee. */
4775 var_locus
= gfc_current_locus
;
4776 gfc_clear_attr (¤t_attr
);
4777 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
4778 current_ts
.type
= BT_UNKNOWN
;
4779 current_ts
.kind
= 0;
4781 m
= gfc_match_symbol (&cpte
, 0);
4784 gfc_error ("Expected variable name at %C");
4788 /* Check for an optional array spec. */
4789 m
= gfc_match_array_spec (&as
);
4790 if (m
== MATCH_ERROR
)
4792 gfc_free_array_spec (as
);
4795 else if (m
== MATCH_NO
)
4797 gfc_free_array_spec (as
);
4801 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
4804 gfc_set_sym_referenced (cpte
);
4806 if (cpte
->as
== NULL
)
4808 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
4809 gfc_internal_error ("Couldn't set Cray pointee array spec.");
4811 else if (as
!= NULL
)
4813 gfc_error ("Duplicate array spec for Cray pointee at %C");
4814 gfc_free_array_spec (as
);
4820 if (cpte
->as
!= NULL
)
4822 /* Fix array spec. */
4823 m
= gfc_mod_pointee_as (cpte
->as
);
4824 if (m
== MATCH_ERROR
)
4828 /* Point the Pointee at the Pointer. */
4829 cpte
->cp_pointer
= cptr
;
4831 if (gfc_match_char (')') != MATCH_YES
)
4833 gfc_error ("Expected \")\" at %C");
4836 m
= gfc_match_char (',');
4838 done
= true; /* Stop searching for more declarations. */
4842 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
4843 || gfc_match_eos () != MATCH_YES
)
4845 gfc_error ("Expected \",\" or end of statement at %C");
4853 gfc_match_external (void)
4856 gfc_clear_attr (¤t_attr
);
4857 current_attr
.external
= 1;
4859 return attr_decl ();
4864 gfc_match_intent (void)
4868 intent
= match_intent_spec ();
4869 if (intent
== INTENT_UNKNOWN
)
4872 gfc_clear_attr (¤t_attr
);
4873 current_attr
.intent
= intent
;
4875 return attr_decl ();
4880 gfc_match_intrinsic (void)
4883 gfc_clear_attr (¤t_attr
);
4884 current_attr
.intrinsic
= 1;
4886 return attr_decl ();
4891 gfc_match_optional (void)
4894 gfc_clear_attr (¤t_attr
);
4895 current_attr
.optional
= 1;
4897 return attr_decl ();
4902 gfc_match_pointer (void)
4904 gfc_gobble_whitespace ();
4905 if (gfc_peek_char () == '(')
4907 if (!gfc_option
.flag_cray_pointer
)
4909 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
4913 return cray_pointer_decl ();
4917 gfc_clear_attr (¤t_attr
);
4918 current_attr
.pointer
= 1;
4920 return attr_decl ();
4926 gfc_match_allocatable (void)
4928 gfc_clear_attr (¤t_attr
);
4929 current_attr
.allocatable
= 1;
4931 return attr_decl ();
4936 gfc_match_dimension (void)
4938 gfc_clear_attr (¤t_attr
);
4939 current_attr
.dimension
= 1;
4941 return attr_decl ();
4946 gfc_match_target (void)
4948 gfc_clear_attr (¤t_attr
);
4949 current_attr
.target
= 1;
4951 return attr_decl ();
4955 /* Match the list of entities being specified in a PUBLIC or PRIVATE
4959 access_attr_decl (gfc_statement st
)
4961 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4962 interface_type type
;
4965 gfc_intrinsic_op
operator;
4968 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4973 m
= gfc_match_generic_spec (&type
, name
, &operator);
4976 if (m
== MATCH_ERROR
)
4981 case INTERFACE_NAMELESS
:
4982 case INTERFACE_ABSTRACT
:
4985 case INTERFACE_GENERIC
:
4986 if (gfc_get_symbol (name
, NULL
, &sym
))
4989 if (gfc_add_access (&sym
->attr
, (st
== ST_PUBLIC
)
4990 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
4991 sym
->name
, NULL
) == FAILURE
)
4996 case INTERFACE_INTRINSIC_OP
:
4997 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
4999 gfc_current_ns
->operator_access
[operator] =
5000 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
5004 gfc_error ("Access specification of the %s operator at %C has "
5005 "already been specified", gfc_op2string (operator));
5011 case INTERFACE_USER_OP
:
5012 uop
= gfc_get_uop (name
);
5014 if (uop
->access
== ACCESS_UNKNOWN
)
5016 uop
->access
= (st
== ST_PUBLIC
)
5017 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
5021 gfc_error ("Access specification of the .%s. operator at %C "
5022 "has already been specified", sym
->name
);
5029 if (gfc_match_char (',') == MATCH_NO
)
5033 if (gfc_match_eos () != MATCH_YES
)
5038 gfc_syntax_error (st
);
5046 gfc_match_protected (void)
5051 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5053 gfc_error ("PROTECTED at %C only allowed in specification "
5054 "part of a module");
5059 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED statement at %C")
5063 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
5068 if (gfc_match_eos () == MATCH_YES
)
5073 m
= gfc_match_symbol (&sym
, 0);
5077 if (gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5090 if (gfc_match_eos () == MATCH_YES
)
5092 if (gfc_match_char (',') != MATCH_YES
)
5099 gfc_error ("Syntax error in PROTECTED statement at %C");
5104 /* The PRIVATE statement is a bit weird in that it can be an attribute
5105 declaration, but also works as a standlone statement inside of a
5106 type declaration or a module. */
5109 gfc_match_private (gfc_statement
*st
)
5112 if (gfc_match ("private") != MATCH_YES
)
5115 if (gfc_current_state () != COMP_MODULE
5116 && (gfc_current_state () != COMP_DERIVED
5117 || !gfc_state_stack
->previous
5118 || gfc_state_stack
->previous
->state
!= COMP_MODULE
))
5120 gfc_error ("PRIVATE statement at %C is only allowed in the "
5121 "specification part of a module");
5125 if (gfc_current_state () == COMP_DERIVED
)
5127 if (gfc_match_eos () == MATCH_YES
)
5133 gfc_syntax_error (ST_PRIVATE
);
5137 if (gfc_match_eos () == MATCH_YES
)
5144 return access_attr_decl (ST_PRIVATE
);
5149 gfc_match_public (gfc_statement
*st
)
5152 if (gfc_match ("public") != MATCH_YES
)
5155 if (gfc_current_state () != COMP_MODULE
)
5157 gfc_error ("PUBLIC statement at %C is only allowed in the "
5158 "specification part of a module");
5162 if (gfc_match_eos () == MATCH_YES
)
5169 return access_attr_decl (ST_PUBLIC
);
5173 /* Workhorse for gfc_match_parameter. */
5182 m
= gfc_match_symbol (&sym
, 0);
5184 gfc_error ("Expected variable name at %C in PARAMETER statement");
5189 if (gfc_match_char ('=') == MATCH_NO
)
5191 gfc_error ("Expected = sign in PARAMETER statement at %C");
5195 m
= gfc_match_init_expr (&init
);
5197 gfc_error ("Expected expression at %C in PARAMETER statement");
5201 if (sym
->ts
.type
== BT_UNKNOWN
5202 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
5208 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
5209 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
5215 if (sym
->ts
.type
== BT_CHARACTER
5216 && sym
->ts
.cl
!= NULL
5217 && sym
->ts
.cl
->length
!= NULL
5218 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
5219 && init
->expr_type
== EXPR_CONSTANT
5220 && init
->ts
.type
== BT_CHARACTER
5221 && init
->ts
.kind
== 1)
5222 gfc_set_constant_character_len (
5223 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
, false);
5229 gfc_free_expr (init
);
5234 /* Match a parameter statement, with the weird syntax that these have. */
5237 gfc_match_parameter (void)
5241 if (gfc_match_char ('(') == MATCH_NO
)
5250 if (gfc_match (" )%t") == MATCH_YES
)
5253 if (gfc_match_char (',') != MATCH_YES
)
5255 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5265 /* Save statements have a special syntax. */
5268 gfc_match_save (void)
5270 char n
[GFC_MAX_SYMBOL_LEN
+1];
5275 if (gfc_match_eos () == MATCH_YES
)
5277 if (gfc_current_ns
->seen_save
)
5279 if (gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
5280 "follows previous SAVE statement")
5285 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
5289 if (gfc_current_ns
->save_all
)
5291 if (gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
5292 "blanket SAVE statement")
5301 m
= gfc_match_symbol (&sym
, 0);
5305 if (gfc_add_save (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5317 m
= gfc_match (" / %n /", &n
);
5318 if (m
== MATCH_ERROR
)
5323 c
= gfc_get_common (n
, 0);
5326 gfc_current_ns
->seen_save
= 1;
5329 if (gfc_match_eos () == MATCH_YES
)
5331 if (gfc_match_char (',') != MATCH_YES
)
5338 gfc_error ("Syntax error in SAVE statement at %C");
5344 gfc_match_value (void)
5349 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE statement at %C")
5353 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
5358 if (gfc_match_eos () == MATCH_YES
)
5363 m
= gfc_match_symbol (&sym
, 0);
5367 if (gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5380 if (gfc_match_eos () == MATCH_YES
)
5382 if (gfc_match_char (',') != MATCH_YES
)
5389 gfc_error ("Syntax error in VALUE statement at %C");
5395 gfc_match_volatile (void)
5400 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VOLATILE statement at %C")
5404 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
5409 if (gfc_match_eos () == MATCH_YES
)
5414 /* VOLATILE is special because it can be added to host-associated
5416 m
= gfc_match_symbol (&sym
, 1);
5420 if (gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5433 if (gfc_match_eos () == MATCH_YES
)
5435 if (gfc_match_char (',') != MATCH_YES
)
5442 gfc_error ("Syntax error in VOLATILE statement at %C");
5447 /* Match a module procedure statement. Note that we have to modify
5448 symbols in the parent's namespace because the current one was there
5449 to receive symbols that are in an interface's formal argument list. */
5452 gfc_match_modproc (void)
5454 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5457 gfc_namespace
*module_ns
;
5459 if (gfc_state_stack
->state
!= COMP_INTERFACE
5460 || gfc_state_stack
->previous
== NULL
5461 || current_interface
.type
== INTERFACE_NAMELESS
5462 || current_interface
.type
== INTERFACE_ABSTRACT
)
5464 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5469 module_ns
= gfc_current_ns
->parent
;
5470 for (; module_ns
; module_ns
= module_ns
->parent
)
5471 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5474 if (module_ns
== NULL
)
5479 m
= gfc_match_name (name
);
5485 if (gfc_get_symbol (name
, module_ns
, &sym
))
5488 if (sym
->attr
.proc
!= PROC_MODULE
5489 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
5490 sym
->name
, NULL
) == FAILURE
)
5493 if (gfc_add_interface (sym
) == FAILURE
)
5496 sym
->attr
.mod_proc
= 1;
5498 if (gfc_match_eos () == MATCH_YES
)
5500 if (gfc_match_char (',') != MATCH_YES
)
5507 gfc_syntax_error (ST_MODULE_PROC
);
5512 /* Match the optional attribute specifiers for a type declaration.
5513 Return MATCH_ERROR if an error is encountered in one of the handled
5514 attributes (public, private, bind(c)), MATCH_NO if what's found is
5515 not a handled attribute, and MATCH_YES otherwise. TODO: More error
5516 checking on attribute conflicts needs to be done. */
5519 gfc_get_type_attr_spec (symbol_attribute
*attr
)
5521 /* See if the derived type is marked as private. */
5522 if (gfc_match (" , private") == MATCH_YES
)
5524 if (gfc_current_state () != COMP_MODULE
)
5526 gfc_error ("Derived type at %C can only be PRIVATE in the "
5527 "specification part of a module");
5531 if (gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
5534 else if (gfc_match (" , public") == MATCH_YES
)
5536 if (gfc_current_state () != COMP_MODULE
)
5538 gfc_error ("Derived type at %C can only be PUBLIC in the "
5539 "specification part of a module");
5543 if (gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
5546 else if (gfc_match(" , bind ( c )") == MATCH_YES
)
5548 /* If the type is defined to be bind(c) it then needs to make
5549 sure that all fields are interoperable. This will
5550 need to be a semantic check on the finished derived type.
5551 See 15.2.3 (lines 9-12) of F2003 draft. */
5552 if (gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0) != SUCCESS
)
5555 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
5560 /* If we get here, something matched. */
5565 /* Match the beginning of a derived type declaration. If a type name
5566 was the result of a function, then it is possible to have a symbol
5567 already to be known as a derived type yet have no components. */
5570 gfc_match_derived_decl (void)
5572 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5573 symbol_attribute attr
;
5576 match is_type_attr_spec
= MATCH_NO
;
5577 bool seen_attr
= false;
5579 if (gfc_current_state () == COMP_DERIVED
)
5582 gfc_clear_attr (&attr
);
5586 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
);
5587 if (is_type_attr_spec
== MATCH_ERROR
)
5589 if (is_type_attr_spec
== MATCH_YES
)
5591 } while (is_type_attr_spec
== MATCH_YES
);
5593 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
5595 gfc_error ("Expected :: in TYPE definition at %C");
5599 m
= gfc_match (" %n%t", name
);
5603 /* Make sure the name is not the name of an intrinsic type. */
5604 if (gfc_is_intrinsic_typename (name
))
5606 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5611 if (gfc_get_symbol (name
, NULL
, &sym
))
5614 if (sym
->ts
.type
!= BT_UNKNOWN
)
5616 gfc_error ("Derived type name '%s' at %C already has a basic type "
5617 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
5621 /* The symbol may already have the derived attribute without the
5622 components. The ways this can happen is via a function
5623 definition, an INTRINSIC statement or a subtype in another
5624 derived type that is a pointer. The first part of the AND clause
5625 is true if a the symbol is not the return value of a function. */
5626 if (sym
->attr
.flavor
!= FL_DERIVED
5627 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
5630 if (sym
->components
!= NULL
)
5632 gfc_error ("Derived type definition of '%s' at %C has already been "
5633 "defined", sym
->name
);
5637 if (attr
.access
!= ACCESS_UNKNOWN
5638 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
5641 /* See if the derived type was labeled as bind(c). */
5642 if (attr
.is_bind_c
!= 0)
5643 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
5645 gfc_new_block
= sym
;
5651 /* Cray Pointees can be declared as:
5652 pointer (ipt, a (n,m,...,*))
5653 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
5654 cheat and set a constant bound of 1 for the last dimension, if this
5655 is the case. Since there is no bounds-checking for Cray Pointees,
5656 this will be okay. */
5659 gfc_mod_pointee_as (gfc_array_spec
*as
)
5661 as
->cray_pointee
= true; /* This will be useful to know later. */
5662 if (as
->type
== AS_ASSUMED_SIZE
)
5664 as
->type
= AS_EXPLICIT
;
5665 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
5666 as
->cp_was_assumed
= true;
5668 else if (as
->type
== AS_ASSUMED_SHAPE
)
5670 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
5677 /* Match the enum definition statement, here we are trying to match
5678 the first line of enum definition statement.
5679 Returns MATCH_YES if match is found. */
5682 gfc_match_enum (void)
5686 m
= gfc_match_eos ();
5690 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENUM and ENUMERATOR at %C")
5698 /* Match a variable name with an optional initializer. When this
5699 subroutine is called, a variable is expected to be parsed next.
5700 Depending on what is happening at the moment, updates either the
5701 symbol table or the current interface. */
5704 enumerator_decl (void)
5706 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5707 gfc_expr
*initializer
;
5708 gfc_array_spec
*as
= NULL
;
5716 old_locus
= gfc_current_locus
;
5718 /* When we get here, we've just matched a list of attributes and
5719 maybe a type and a double colon. The next thing we expect to see
5720 is the name of the symbol. */
5721 m
= gfc_match_name (name
);
5725 var_locus
= gfc_current_locus
;
5727 /* OK, we've successfully matched the declaration. Now put the
5728 symbol in the current namespace. If we fail to create the symbol,
5730 if (build_sym (name
, NULL
, &as
, &var_locus
) == FAILURE
)
5736 /* The double colon must be present in order to have initializers.
5737 Otherwise the statement is ambiguous with an assignment statement. */
5740 if (gfc_match_char ('=') == MATCH_YES
)
5742 m
= gfc_match_init_expr (&initializer
);
5745 gfc_error ("Expected an initialization expression at %C");
5754 /* If we do not have an initializer, the initialization value of the
5755 previous enumerator (stored in last_initializer) is incremented
5756 by 1 and is used to initialize the current enumerator. */
5757 if (initializer
== NULL
)
5758 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
5760 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
5762 gfc_error("ENUMERATOR %L not initialized with integer expression",
5765 gfc_free_enum_history ();
5769 /* Store this current initializer, for the next enumerator variable
5770 to be parsed. add_init_expr_to_sym() zeros initializer, so we
5771 use last_initializer below. */
5772 last_initializer
= initializer
;
5773 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
5775 /* Maintain enumerator history. */
5776 gfc_find_symbol (name
, NULL
, 0, &sym
);
5777 create_enum_history (sym
, last_initializer
);
5779 return (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
5782 /* Free stuff up and return. */
5783 gfc_free_expr (initializer
);
5789 /* Match the enumerator definition statement. */
5792 gfc_match_enumerator_def (void)
5797 gfc_clear_ts (¤t_ts
);
5799 m
= gfc_match (" enumerator");
5803 m
= gfc_match (" :: ");
5804 if (m
== MATCH_ERROR
)
5807 colon_seen
= (m
== MATCH_YES
);
5809 if (gfc_current_state () != COMP_ENUM
)
5811 gfc_error ("ENUM definition statement expected before %C");
5812 gfc_free_enum_history ();
5816 (¤t_ts
)->type
= BT_INTEGER
;
5817 (¤t_ts
)->kind
= gfc_c_int_kind
;
5819 gfc_clear_attr (¤t_attr
);
5820 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
5829 m
= enumerator_decl ();
5830 if (m
== MATCH_ERROR
)
5835 if (gfc_match_eos () == MATCH_YES
)
5837 if (gfc_match_char (',') != MATCH_YES
)
5841 if (gfc_current_state () == COMP_ENUM
)
5843 gfc_free_enum_history ();
5844 gfc_error ("Syntax error in ENUMERATOR definition at %C");
5849 gfc_free_array_spec (current_as
);