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
);
685 rc
= gfc_get_symbol (name
, NULL
, result
);
688 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
691 gfc_current_ns
->refs
++;
693 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
695 /* Trap another encompassed procedure with the same name. All
696 these conditions are necessary to avoid picking up an entry
697 whose name clashes with that of the encompassing procedure;
698 this is handled using gsymbols to register unique,globally
700 if (sym
->attr
.flavor
!= 0
701 && sym
->attr
.proc
!= 0
702 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
703 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
704 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
705 name
, &sym
->declared_at
);
707 /* Trap a procedure with a name the same as interface in the
708 encompassing scope. */
709 if (sym
->attr
.generic
!= 0
710 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
711 && !sym
->attr
.mod_proc
)
712 gfc_error_now ("Name '%s' at %C is already defined"
713 " as a generic interface at %L",
714 name
, &sym
->declared_at
);
716 /* Trap declarations of attributes in encompassing scope. The
717 signature for this is that ts.kind is set. Legitimate
718 references only set ts.type. */
719 if (sym
->ts
.kind
!= 0
720 && !sym
->attr
.implicit_type
721 && sym
->attr
.proc
== 0
722 && gfc_current_ns
->parent
!= NULL
723 && sym
->attr
.access
== 0
724 && !module_fcn_entry
)
725 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
726 "and must not have attributes declared at %L",
727 name
, &sym
->declared_at
);
730 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
733 /* Module function entries will already have a symtree in
734 the current namespace but will need one at module level. */
735 if (module_fcn_entry
)
737 /* Present if entry is declared to be a module procedure. */
738 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
740 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
743 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
748 /* See if the procedure should be a module procedure. */
750 if (((sym
->ns
->proc_name
!= NULL
751 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
752 && sym
->attr
.proc
!= PROC_MODULE
)
753 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
754 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
755 sym
->name
, NULL
) == FAILURE
)
762 /* Verify that the given symbol representing a parameter is C
763 interoperable, by checking to see if it was marked as such after
764 its declaration. If the given symbol is not interoperable, a
765 warning is reported, thus removing the need to return the status to
766 the calling function. The standard does not require the user use
767 one of the iso_c_binding named constants to declare an
768 interoperable parameter, but we can't be sure if the param is C
769 interop or not if the user doesn't. For example, integer(4) may be
770 legal Fortran, but doesn't have meaning in C. It may interop with
771 a number of the C types, which causes a problem because the
772 compiler can't know which one. This code is almost certainly not
773 portable, and the user will get what they deserve if the C type
774 across platforms isn't always interoperable with integer(4). If
775 the user had used something like integer(c_int) or integer(c_long),
776 the compiler could have automatically handled the varying sizes
780 verify_c_interop_param (gfc_symbol
*sym
)
782 int is_c_interop
= 0;
783 try retval
= SUCCESS
;
785 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
786 Don't repeat the checks here. */
787 if (sym
->attr
.implicit_type
)
790 /* For subroutines or functions that are passed to a BIND(C) procedure,
791 they're interoperable if they're BIND(C) and their params are all
793 if (sym
->attr
.flavor
== FL_PROCEDURE
)
795 if (sym
->attr
.is_bind_c
== 0)
797 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
798 "attribute to be C interoperable", sym
->name
,
799 &(sym
->declared_at
));
805 if (sym
->attr
.is_c_interop
== 1)
806 /* We've already checked this procedure; don't check it again. */
809 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
814 /* See if we've stored a reference to a procedure that owns sym. */
815 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
817 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
820 (verify_c_interop (&(sym
->ts
), sym
->name
, &(sym
->declared_at
))
823 if (is_c_interop
!= 1)
825 /* Make personalized messages to give better feedback. */
826 if (sym
->ts
.type
== BT_DERIVED
)
827 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
828 " procedure '%s' but is not C interoperable "
829 "because derived type '%s' is not C interoperable",
830 sym
->name
, &(sym
->declared_at
),
831 sym
->ns
->proc_name
->name
,
832 sym
->ts
.derived
->name
);
834 gfc_warning ("Variable '%s' at %L is a parameter to the "
835 "BIND(C) procedure '%s' but may not be C "
837 sym
->name
, &(sym
->declared_at
),
838 sym
->ns
->proc_name
->name
);
841 /* Character strings are only C interoperable if they have a
843 if (sym
->ts
.type
== BT_CHARACTER
)
845 gfc_charlen
*cl
= sym
->ts
.cl
;
846 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
847 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
849 gfc_error ("Character argument '%s' at %L "
850 "must be length 1 because "
851 "procedure '%s' is BIND(C)",
852 sym
->name
, &sym
->declared_at
,
853 sym
->ns
->proc_name
->name
);
858 /* We have to make sure that any param to a bind(c) routine does
859 not have the allocatable, pointer, or optional attributes,
860 according to J3/04-007, section 5.1. */
861 if (sym
->attr
.allocatable
== 1)
863 gfc_error ("Variable '%s' at %L cannot have the "
864 "ALLOCATABLE attribute because procedure '%s'"
865 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
866 sym
->ns
->proc_name
->name
);
870 if (sym
->attr
.pointer
== 1)
872 gfc_error ("Variable '%s' at %L cannot have the "
873 "POINTER attribute because procedure '%s'"
874 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
875 sym
->ns
->proc_name
->name
);
879 if (sym
->attr
.optional
== 1)
881 gfc_error ("Variable '%s' at %L cannot have the "
882 "OPTIONAL attribute because procedure '%s'"
883 " is BIND(C)", sym
->name
, &(sym
->declared_at
),
884 sym
->ns
->proc_name
->name
);
888 /* Make sure that if it has the dimension attribute, that it is
889 either assumed size or explicit shape. */
892 if (sym
->as
->type
== AS_ASSUMED_SHAPE
)
894 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
895 "argument to the procedure '%s' at %L because "
896 "the procedure is BIND(C)", sym
->name
,
897 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
898 &(sym
->ns
->proc_name
->declared_at
));
902 if (sym
->as
->type
== AS_DEFERRED
)
904 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
905 "argument to the procedure '%s' at %L because "
906 "the procedure is BIND(C)", sym
->name
,
907 &(sym
->declared_at
), sym
->ns
->proc_name
->name
,
908 &(sym
->ns
->proc_name
->declared_at
));
919 /* Function called by variable_decl() that adds a name to the symbol table. */
922 build_sym (const char *name
, gfc_charlen
*cl
,
923 gfc_array_spec
**as
, locus
*var_locus
)
925 symbol_attribute attr
;
928 if (gfc_get_symbol (name
, NULL
, &sym
))
931 /* Start updating the symbol table. Add basic type attribute if present. */
932 if (current_ts
.type
!= BT_UNKNOWN
933 && (sym
->attr
.implicit_type
== 0
934 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
935 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
938 if (sym
->ts
.type
== BT_CHARACTER
)
941 /* Add dimension attribute if present. */
942 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
946 /* Add attribute to symbol. The copy is so that we can reset the
947 dimension attribute. */
951 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
954 /* Finish any work that may need to be done for the binding label,
955 if it's a bind(c). The bind(c) attr is found before the symbol
956 is made, and before the symbol name (for data decls), so the
957 current_ts is holding the binding label, or nothing if the
958 name= attr wasn't given. Therefore, test here if we're dealing
959 with a bind(c) and make sure the binding label is set correctly. */
960 if (sym
->attr
.is_bind_c
== 1)
962 if (sym
->binding_label
[0] == '\0')
964 /* Here, we're not checking the numIdents (the last param).
965 This could be an error we're letting slip through! */
966 if (set_binding_label (sym
->binding_label
, sym
->name
, 1) == FAILURE
)
971 /* See if we know we're in a common block, and if it's a bind(c)
972 common then we need to make sure we're an interoperable type. */
973 if (sym
->attr
.in_common
== 1)
975 /* Test the common block object. */
976 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
977 && sym
->ts
.is_c_interop
!= 1)
979 gfc_error_now ("Variable '%s' in common block '%s' at %C "
980 "must be declared with a C interoperable "
981 "kind since common block '%s' is BIND(C)",
982 sym
->name
, sym
->common_block
->name
,
983 sym
->common_block
->name
);
988 sym
->attr
.implied_index
= 0;
994 /* Set character constant to the given length. The constant will be padded or
998 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, bool array
)
1003 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1004 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
1006 slen
= expr
->value
.character
.length
;
1009 s
= gfc_getmem (len
+ 1);
1010 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
1012 memset (&s
[slen
], ' ', len
- slen
);
1014 if (gfc_option
.warn_character_truncation
&& slen
> len
)
1015 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1016 "(%d/%d)", &expr
->where
, slen
, len
);
1018 /* Apply the standard by 'hand' otherwise it gets cleared for
1020 if (array
&& slen
< len
&& !(gfc_option
.allow_std
& GFC_STD_GNU
))
1021 gfc_error_now ("The CHARACTER elements of the array constructor "
1022 "at %L must have the same length (%d/%d)",
1023 &expr
->where
, slen
, len
);
1026 gfc_free (expr
->value
.character
.string
);
1027 expr
->value
.character
.string
= s
;
1028 expr
->value
.character
.length
= len
;
1033 /* Function to create and update the enumerator history
1034 using the information passed as arguments.
1035 Pointer "max_enum" is also updated, to point to
1036 enum history node containing largest initializer.
1038 SYM points to the symbol node of enumerator.
1039 INIT points to its enumerator value. */
1042 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1044 enumerator_history
*new_enum_history
;
1045 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1047 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
1049 new_enum_history
->sym
= sym
;
1050 new_enum_history
->initializer
= init
;
1051 new_enum_history
->next
= NULL
;
1053 if (enum_history
== NULL
)
1055 enum_history
= new_enum_history
;
1056 max_enum
= enum_history
;
1060 new_enum_history
->next
= enum_history
;
1061 enum_history
= new_enum_history
;
1063 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1064 new_enum_history
->initializer
->value
.integer
) < 0)
1065 max_enum
= new_enum_history
;
1070 /* Function to free enum kind history. */
1073 gfc_free_enum_history (void)
1075 enumerator_history
*current
= enum_history
;
1076 enumerator_history
*next
;
1078 while (current
!= NULL
)
1080 next
= current
->next
;
1085 enum_history
= NULL
;
1089 /* Function called by variable_decl() that adds an initialization
1090 expression to a symbol. */
1093 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1095 symbol_attribute attr
;
1100 if (find_special (name
, &sym
))
1105 /* If this symbol is confirming an implicit parameter type,
1106 then an initialization expression is not allowed. */
1107 if (attr
.flavor
== FL_PARAMETER
1108 && sym
->value
!= NULL
1111 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1120 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1127 /* An initializer is required for PARAMETER declarations. */
1128 if (attr
.flavor
== FL_PARAMETER
)
1130 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1136 /* If a variable appears in a DATA block, it cannot have an
1140 gfc_error ("Variable '%s' at %C with an initializer already "
1141 "appears in a DATA statement", sym
->name
);
1145 /* Check if the assignment can happen. This has to be put off
1146 until later for a derived type variable. */
1147 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
1148 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
1151 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
1153 /* Update symbol character length according initializer. */
1154 if (sym
->ts
.cl
->length
== NULL
)
1156 /* If there are multiple CHARACTER variables declared on the
1157 same line, we don't want them to share the same length. */
1158 sym
->ts
.cl
= gfc_get_charlen ();
1159 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1160 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
1162 if (sym
->attr
.flavor
== FL_PARAMETER
1163 && init
->expr_type
== EXPR_ARRAY
)
1164 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
1166 /* Update initializer character length according symbol. */
1167 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1169 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
1170 gfc_constructor
* p
;
1172 if (init
->expr_type
== EXPR_CONSTANT
)
1173 gfc_set_constant_character_len (len
, init
, false);
1174 else if (init
->expr_type
== EXPR_ARRAY
)
1176 /* Build a new charlen to prevent simplification from
1177 deleting the length before it is resolved. */
1178 init
->ts
.cl
= gfc_get_charlen ();
1179 init
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1180 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
1181 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
1183 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
1184 gfc_set_constant_character_len (len
, p
->expr
, false);
1189 /* Need to check if the expression we initialized this
1190 to was one of the iso_c_binding named constants. If so,
1191 and we're a parameter (constant), let it be iso_c.
1193 integer(c_int), parameter :: my_int = c_int
1194 integer(my_int) :: my_int_2
1195 If we mark my_int as iso_c (since we can see it's value
1196 is equal to one of the named constants), then my_int_2
1197 will be considered C interoperable. */
1198 if (sym
->ts
.type
!= BT_CHARACTER
&& sym
->ts
.type
!= BT_DERIVED
)
1200 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1201 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1202 /* attr bits needed for module files. */
1203 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1204 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1205 if (init
->ts
.is_iso_c
)
1206 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1209 /* Add initializer. Make sure we keep the ranks sane. */
1210 if (sym
->attr
.dimension
&& init
->rank
== 0)
1216 if (sym
->attr
.flavor
== FL_PARAMETER
1217 && init
->expr_type
== EXPR_CONSTANT
1218 && spec_size (sym
->as
, &size
) == SUCCESS
1219 && mpz_cmp_si (size
, 0) > 0)
1221 array
= gfc_start_constructor (init
->ts
.type
, init
->ts
.kind
,
1224 array
->value
.constructor
= c
= NULL
;
1225 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1227 if (array
->value
.constructor
== NULL
)
1229 array
->value
.constructor
= c
= gfc_get_constructor ();
1234 c
->next
= gfc_get_constructor ();
1236 c
->expr
= gfc_copy_expr (init
);
1240 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1241 for (n
= 0; n
< sym
->as
->rank
; n
++)
1242 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1247 init
->rank
= sym
->as
->rank
;
1251 if (sym
->attr
.save
== SAVE_NONE
)
1252 sym
->attr
.save
= SAVE_IMPLICIT
;
1260 /* Function called by variable_decl() that adds a name to a structure
1264 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1265 gfc_array_spec
**as
)
1269 /* If the current symbol is of the same derived type that we're
1270 constructing, it must have the pointer attribute. */
1271 if (current_ts
.type
== BT_DERIVED
1272 && current_ts
.derived
== gfc_current_block ()
1273 && current_attr
.pointer
== 0)
1275 gfc_error ("Component at %C must have the POINTER attribute");
1279 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1281 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1283 gfc_error ("Array component of structure at %C must have explicit "
1284 "or deferred shape");
1289 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
1294 gfc_set_component_attr (c
, ¤t_attr
);
1296 c
->initializer
= *init
;
1304 /* Check array components. */
1309 gfc_error ("Allocatable component at %C must be an array");
1318 if (c
->as
->type
!= AS_DEFERRED
)
1320 gfc_error ("Pointer array component of structure at %C must have a "
1325 else if (c
->allocatable
)
1327 if (c
->as
->type
!= AS_DEFERRED
)
1329 gfc_error ("Allocatable component of structure at %C must have a "
1336 if (c
->as
->type
!= AS_EXPLICIT
)
1338 gfc_error ("Array component of structure at %C must have an "
1348 /* Match a 'NULL()', and possibly take care of some side effects. */
1351 gfc_match_null (gfc_expr
**result
)
1357 m
= gfc_match (" null ( )");
1361 /* The NULL symbol now has to be/become an intrinsic function. */
1362 if (gfc_get_symbol ("null", NULL
, &sym
))
1364 gfc_error ("NULL() initialization at %C is ambiguous");
1368 gfc_intrinsic_symbol (sym
);
1370 if (sym
->attr
.proc
!= PROC_INTRINSIC
1371 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1372 sym
->name
, NULL
) == FAILURE
1373 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1376 e
= gfc_get_expr ();
1377 e
->where
= gfc_current_locus
;
1378 e
->expr_type
= EXPR_NULL
;
1379 e
->ts
.type
= BT_UNKNOWN
;
1387 /* Match a variable name with an optional initializer. When this
1388 subroutine is called, a variable is expected to be parsed next.
1389 Depending on what is happening at the moment, updates either the
1390 symbol table or the current interface. */
1393 variable_decl (int elem
)
1395 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1396 gfc_expr
*initializer
, *char_len
;
1398 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1409 old_locus
= gfc_current_locus
;
1411 /* When we get here, we've just matched a list of attributes and
1412 maybe a type and a double colon. The next thing we expect to see
1413 is the name of the symbol. */
1414 m
= gfc_match_name (name
);
1418 var_locus
= gfc_current_locus
;
1420 /* Now we could see the optional array spec. or character length. */
1421 m
= gfc_match_array_spec (&as
);
1422 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1423 cp_as
= gfc_copy_array_spec (as
);
1424 else if (m
== MATCH_ERROR
)
1428 as
= gfc_copy_array_spec (current_as
);
1433 if (current_ts
.type
== BT_CHARACTER
)
1435 switch (match_char_length (&char_len
))
1438 cl
= gfc_get_charlen ();
1439 cl
->next
= gfc_current_ns
->cl_list
;
1440 gfc_current_ns
->cl_list
= cl
;
1442 cl
->length
= char_len
;
1445 /* Non-constant lengths need to be copied after the first
1448 if (elem
> 1 && current_ts
.cl
->length
1449 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1451 cl
= gfc_get_charlen ();
1452 cl
->next
= gfc_current_ns
->cl_list
;
1453 gfc_current_ns
->cl_list
= cl
;
1454 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1466 /* If this symbol has already shown up in a Cray Pointer declaration,
1467 then we want to set the type & bail out. */
1468 if (gfc_option
.flag_cray_pointer
)
1470 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1471 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1473 sym
->ts
.type
= current_ts
.type
;
1474 sym
->ts
.kind
= current_ts
.kind
;
1476 sym
->ts
.derived
= current_ts
.derived
;
1477 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
1478 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
1481 /* Check to see if we have an array specification. */
1484 if (sym
->as
!= NULL
)
1486 gfc_error ("Duplicate array spec for Cray pointee at %C");
1487 gfc_free_array_spec (cp_as
);
1493 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1494 gfc_internal_error ("Couldn't set pointee array spec.");
1496 /* Fix the array spec. */
1497 m
= gfc_mod_pointee_as (sym
->as
);
1498 if (m
== MATCH_ERROR
)
1506 gfc_free_array_spec (cp_as
);
1511 /* OK, we've successfully matched the declaration. Now put the
1512 symbol in the current namespace, because it might be used in the
1513 optional initialization expression for this symbol, e.g. this is
1516 integer, parameter :: i = huge(i)
1518 This is only true for parameters or variables of a basic type.
1519 For components of derived types, it is not true, so we don't
1520 create a symbol for those yet. If we fail to create the symbol,
1522 if (gfc_current_state () != COMP_DERIVED
1523 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1529 /* An interface body specifies all of the procedure's
1530 characteristics and these shall be consistent with those
1531 specified in the procedure definition, except that the interface
1532 may specify a procedure that is not pure if the procedure is
1533 defined to be pure(12.3.2). */
1534 if (current_ts
.type
== BT_DERIVED
1535 && gfc_current_ns
->proc_name
1536 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1537 && current_ts
.derived
->ns
!= gfc_current_ns
1538 && !gfc_current_ns
->has_import_set
)
1540 gfc_error ("the type of '%s' at %C has not been declared within the "
1546 /* In functions that have a RESULT variable defined, the function
1547 name always refers to function calls. Therefore, the name is
1548 not allowed to appear in specification statements. */
1549 if (gfc_current_state () == COMP_FUNCTION
1550 && gfc_current_block () != NULL
1551 && gfc_current_block ()->result
!= NULL
1552 && gfc_current_block ()->result
!= gfc_current_block ()
1553 && strcmp (gfc_current_block ()->name
, name
) == 0)
1555 gfc_error ("Function name '%s' not allowed at %C", name
);
1560 /* We allow old-style initializations of the form
1561 integer i /2/, j(4) /3*3, 1/
1562 (if no colon has been seen). These are different from data
1563 statements in that initializers are only allowed to apply to the
1564 variable immediately preceding, i.e.
1566 is not allowed. Therefore we have to do some work manually, that
1567 could otherwise be left to the matchers for DATA statements. */
1569 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1571 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1572 "initialization at %C") == FAILURE
)
1575 return match_old_style_init (name
);
1578 /* The double colon must be present in order to have initializers.
1579 Otherwise the statement is ambiguous with an assignment statement. */
1582 if (gfc_match (" =>") == MATCH_YES
)
1584 if (!current_attr
.pointer
)
1586 gfc_error ("Initialization at %C isn't for a pointer variable");
1591 m
= gfc_match_null (&initializer
);
1594 gfc_error ("Pointer initialization requires a NULL() at %C");
1598 if (gfc_pure (NULL
))
1600 gfc_error ("Initialization of pointer at %C is not allowed in "
1601 "a PURE procedure");
1609 else if (gfc_match_char ('=') == MATCH_YES
)
1611 if (current_attr
.pointer
)
1613 gfc_error ("Pointer initialization at %C requires '=>', "
1619 m
= gfc_match_init_expr (&initializer
);
1622 gfc_error ("Expected an initialization expression at %C");
1626 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1628 gfc_error ("Initialization of variable at %C is not allowed in "
1629 "a PURE procedure");
1638 if (initializer
!= NULL
&& current_attr
.allocatable
1639 && gfc_current_state () == COMP_DERIVED
)
1641 gfc_error ("Initialization of allocatable component at %C is not "
1647 /* Add the initializer. Note that it is fine if initializer is
1648 NULL here, because we sometimes also need to check if a
1649 declaration *must* have an initialization expression. */
1650 if (gfc_current_state () != COMP_DERIVED
)
1651 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1654 if (current_ts
.type
== BT_DERIVED
1655 && !current_attr
.pointer
&& !initializer
)
1656 initializer
= gfc_default_initializer (¤t_ts
);
1657 t
= build_struct (name
, cl
, &initializer
, &as
);
1660 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1663 /* Free stuff up and return. */
1664 gfc_free_expr (initializer
);
1665 gfc_free_array_spec (as
);
1671 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1672 This assumes that the byte size is equal to the kind number for
1673 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1676 gfc_match_old_kind_spec (gfc_typespec
*ts
)
1681 if (gfc_match_char ('*') != MATCH_YES
)
1684 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1688 original_kind
= ts
->kind
;
1690 /* Massage the kind numbers for complex types. */
1691 if (ts
->type
== BT_COMPLEX
)
1695 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1696 gfc_basic_typename (ts
->type
), original_kind
);
1702 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1704 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1705 gfc_basic_typename (ts
->type
), original_kind
);
1709 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1710 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1717 /* Match a kind specification. Since kinds are generally optional, we
1718 usually return MATCH_NO if something goes wrong. If a "kind="
1719 string is found, then we know we have an error. */
1722 gfc_match_kind_spec (gfc_typespec
*ts
)
1732 where
= gfc_current_locus
;
1734 if (gfc_match_char ('(') == MATCH_NO
)
1737 /* Also gobbles optional text. */
1738 if (gfc_match (" kind = ") == MATCH_YES
)
1741 n
= gfc_match_init_expr (&e
);
1743 gfc_error ("Expected initialization expression at %C");
1749 gfc_error ("Expected scalar initialization expression at %C");
1754 msg
= gfc_extract_int (e
, &ts
->kind
);
1762 /* Before throwing away the expression, let's see if we had a
1763 C interoperable kind (and store the fact). */
1764 if (e
->ts
.is_c_interop
== 1)
1766 /* Mark this as c interoperable if being declared with one
1767 of the named constants from iso_c_binding. */
1768 ts
->is_c_interop
= e
->ts
.is_iso_c
;
1769 ts
->f90_type
= e
->ts
.f90_type
;
1775 /* Ignore errors to this point, if we've gotten here. This means
1776 we ignore the m=MATCH_ERROR from above. */
1777 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1779 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1780 gfc_basic_typename (ts
->type
));
1783 else if (gfc_match_char (')') != MATCH_YES
)
1785 gfc_error ("Missing right parenthesis at %C");
1789 /* All tests passed. */
1792 if(m
== MATCH_ERROR
)
1793 gfc_current_locus
= where
;
1795 /* Return what we know from the test(s). */
1800 gfc_current_locus
= where
;
1805 /* Match the various kind/length specifications in a CHARACTER
1806 declaration. We don't return MATCH_NO. */
1809 match_char_spec (gfc_typespec
*ts
)
1811 int kind
, seen_length
;
1815 gfc_expr
*kind_expr
= NULL
;
1816 kind
= gfc_default_character_kind
;
1820 /* Try the old-style specification first. */
1821 old_char_selector
= 0;
1823 m
= match_char_length (&len
);
1827 old_char_selector
= 1;
1832 m
= gfc_match_char ('(');
1835 m
= MATCH_YES
; /* Character without length is a single char. */
1839 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
1840 if (gfc_match (" kind =") == MATCH_YES
)
1842 m
= gfc_match_small_int_expr(&kind
, &kind_expr
);
1844 if (m
== MATCH_ERROR
)
1849 if (gfc_match (" , len =") == MATCH_NO
)
1852 m
= char_len_param_value (&len
);
1855 if (m
== MATCH_ERROR
)
1862 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
1863 if (gfc_match (" len =") == MATCH_YES
)
1865 m
= char_len_param_value (&len
);
1868 if (m
== MATCH_ERROR
)
1872 if (gfc_match_char (')') == MATCH_YES
)
1875 if (gfc_match (" , kind =") != MATCH_YES
)
1878 gfc_match_small_int_expr(&kind
, &kind_expr
);
1880 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1882 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1889 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
1890 m
= char_len_param_value (&len
);
1893 if (m
== MATCH_ERROR
)
1897 m
= gfc_match_char (')');
1901 if (gfc_match_char (',') != MATCH_YES
)
1904 gfc_match (" kind ="); /* Gobble optional text. */
1906 m
= gfc_match_small_int_expr(&kind
, &kind_expr
);
1907 if (m
== MATCH_ERROR
)
1913 /* Require a right-paren at this point. */
1914 m
= gfc_match_char (')');
1919 gfc_error ("Syntax error in CHARACTER declaration at %C");
1921 gfc_free_expr (len
);
1925 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1927 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1931 if (seen_length
== 1 && len
!= NULL
1932 && len
->ts
.type
!= BT_INTEGER
&& len
->ts
.type
!= BT_UNKNOWN
)
1934 gfc_error ("Expression at %C must be of INTEGER type");
1940 gfc_free_expr (len
);
1941 gfc_free_expr (kind_expr
);
1945 /* Do some final massaging of the length values. */
1946 cl
= gfc_get_charlen ();
1947 cl
->next
= gfc_current_ns
->cl_list
;
1948 gfc_current_ns
->cl_list
= cl
;
1950 if (seen_length
== 0)
1951 cl
->length
= gfc_int_expr (1);
1958 /* We have to know if it was a c interoperable kind so we can
1959 do accurate type checking of bind(c) procs, etc. */
1960 if (kind_expr
!= NULL
)
1962 /* Mark this as c interoperable if being declared with one
1963 of the named constants from iso_c_binding. */
1964 ts
->is_c_interop
= kind_expr
->ts
.is_iso_c
;
1965 gfc_free_expr (kind_expr
);
1967 else if (len
!= NULL
)
1969 /* Here, we might have parsed something such as:
1971 In this case, the parsing code above grabs the c_char when
1972 looking for the length (line 1690, roughly). it's the last
1973 testcase for parsing the kind params of a character variable.
1974 However, it's not actually the length. this seems like it
1976 To see if the user used a C interop kind, test the expr
1977 of the so called length, and see if it's C interoperable. */
1978 ts
->is_c_interop
= len
->ts
.is_iso_c
;
1985 /* Matches a type specification. If successful, sets the ts structure
1986 to the matched specification. This is necessary for FUNCTION and
1987 IMPLICIT statements.
1989 If implicit_flag is nonzero, then we don't check for the optional
1990 kind specification. Not doing so is needed for matching an IMPLICIT
1991 statement correctly. */
1994 match_type_spec (gfc_typespec
*ts
, int implicit_flag
)
1996 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2003 /* Clear the current binding label, in case one is given. */
2004 curr_binding_label
[0] = '\0';
2006 if (gfc_match (" byte") == MATCH_YES
)
2008 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
2012 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
2014 gfc_error ("BYTE type used at %C "
2015 "is not available on the target machine");
2019 ts
->type
= BT_INTEGER
;
2024 if (gfc_match (" integer") == MATCH_YES
)
2026 ts
->type
= BT_INTEGER
;
2027 ts
->kind
= gfc_default_integer_kind
;
2031 if (gfc_match (" character") == MATCH_YES
)
2033 ts
->type
= BT_CHARACTER
;
2034 if (implicit_flag
== 0)
2035 return match_char_spec (ts
);
2040 if (gfc_match (" real") == MATCH_YES
)
2043 ts
->kind
= gfc_default_real_kind
;
2047 if (gfc_match (" double precision") == MATCH_YES
)
2050 ts
->kind
= gfc_default_double_kind
;
2054 if (gfc_match (" complex") == MATCH_YES
)
2056 ts
->type
= BT_COMPLEX
;
2057 ts
->kind
= gfc_default_complex_kind
;
2061 if (gfc_match (" double complex") == MATCH_YES
)
2063 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
2064 "conform to the Fortran 95 standard") == FAILURE
)
2067 ts
->type
= BT_COMPLEX
;
2068 ts
->kind
= gfc_default_double_kind
;
2072 if (gfc_match (" logical") == MATCH_YES
)
2074 ts
->type
= BT_LOGICAL
;
2075 ts
->kind
= gfc_default_logical_kind
;
2079 m
= gfc_match (" type ( %n )", name
);
2083 /* Search for the name but allow the components to be defined later. */
2084 if (gfc_get_ha_symbol (name
, &sym
))
2086 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2090 if (sym
->attr
.flavor
!= FL_DERIVED
2091 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
2094 ts
->type
= BT_DERIVED
;
2101 /* For all types except double, derived and character, look for an
2102 optional kind specifier. MATCH_NO is actually OK at this point. */
2103 if (implicit_flag
== 1)
2106 if (gfc_current_form
== FORM_FREE
)
2108 c
= gfc_peek_char();
2109 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
2110 && c
!= ':' && c
!= ',')
2114 m
= gfc_match_kind_spec (ts
);
2115 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
2116 m
= gfc_match_old_kind_spec (ts
);
2119 m
= MATCH_YES
; /* No kind specifier found. */
2125 /* Match an IMPLICIT NONE statement. Actually, this statement is
2126 already matched in parse.c, or we would not end up here in the
2127 first place. So the only thing we need to check, is if there is
2128 trailing garbage. If not, the match is successful. */
2131 gfc_match_implicit_none (void)
2133 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
2137 /* Match the letter range(s) of an IMPLICIT statement. */
2140 match_implicit_range (void)
2142 int c
, c1
, c2
, inner
;
2145 cur_loc
= gfc_current_locus
;
2147 gfc_gobble_whitespace ();
2148 c
= gfc_next_char ();
2151 gfc_error ("Missing character range in IMPLICIT at %C");
2158 gfc_gobble_whitespace ();
2159 c1
= gfc_next_char ();
2163 gfc_gobble_whitespace ();
2164 c
= gfc_next_char ();
2169 inner
= 0; /* Fall through. */
2176 gfc_gobble_whitespace ();
2177 c2
= gfc_next_char ();
2181 gfc_gobble_whitespace ();
2182 c
= gfc_next_char ();
2184 if ((c
!= ',') && (c
!= ')'))
2197 gfc_error ("Letters must be in alphabetic order in "
2198 "IMPLICIT statement at %C");
2202 /* See if we can add the newly matched range to the pending
2203 implicits from this IMPLICIT statement. We do not check for
2204 conflicts with whatever earlier IMPLICIT statements may have
2205 set. This is done when we've successfully finished matching
2207 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
2214 gfc_syntax_error (ST_IMPLICIT
);
2216 gfc_current_locus
= cur_loc
;
2221 /* Match an IMPLICIT statement, storing the types for
2222 gfc_set_implicit() if the statement is accepted by the parser.
2223 There is a strange looking, but legal syntactic construction
2224 possible. It looks like:
2226 IMPLICIT INTEGER (a-b) (c-d)
2228 This is legal if "a-b" is a constant expression that happens to
2229 equal one of the legal kinds for integers. The real problem
2230 happens with an implicit specification that looks like:
2232 IMPLICIT INTEGER (a-b)
2234 In this case, a typespec matcher that is "greedy" (as most of the
2235 matchers are) gobbles the character range as a kindspec, leaving
2236 nothing left. We therefore have to go a bit more slowly in the
2237 matching process by inhibiting the kindspec checking during
2238 typespec matching and checking for a kind later. */
2241 gfc_match_implicit (void)
2248 /* We don't allow empty implicit statements. */
2249 if (gfc_match_eos () == MATCH_YES
)
2251 gfc_error ("Empty IMPLICIT statement at %C");
2257 /* First cleanup. */
2258 gfc_clear_new_implicit ();
2260 /* A basic type is mandatory here. */
2261 m
= match_type_spec (&ts
, 1);
2262 if (m
== MATCH_ERROR
)
2267 cur_loc
= gfc_current_locus
;
2268 m
= match_implicit_range ();
2272 /* We may have <TYPE> (<RANGE>). */
2273 gfc_gobble_whitespace ();
2274 c
= gfc_next_char ();
2275 if ((c
== '\n') || (c
== ','))
2277 /* Check for CHARACTER with no length parameter. */
2278 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
2280 ts
.kind
= gfc_default_character_kind
;
2281 ts
.cl
= gfc_get_charlen ();
2282 ts
.cl
->next
= gfc_current_ns
->cl_list
;
2283 gfc_current_ns
->cl_list
= ts
.cl
;
2284 ts
.cl
->length
= gfc_int_expr (1);
2287 /* Record the Successful match. */
2288 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2293 gfc_current_locus
= cur_loc
;
2296 /* Discard the (incorrectly) matched range. */
2297 gfc_clear_new_implicit ();
2299 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2300 if (ts
.type
== BT_CHARACTER
)
2301 m
= match_char_spec (&ts
);
2304 m
= gfc_match_kind_spec (&ts
);
2307 m
= gfc_match_old_kind_spec (&ts
);
2308 if (m
== MATCH_ERROR
)
2314 if (m
== MATCH_ERROR
)
2317 m
= match_implicit_range ();
2318 if (m
== MATCH_ERROR
)
2323 gfc_gobble_whitespace ();
2324 c
= gfc_next_char ();
2325 if ((c
!= '\n') && (c
!= ','))
2328 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2336 gfc_syntax_error (ST_IMPLICIT
);
2344 gfc_match_import (void)
2346 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2351 if (gfc_current_ns
->proc_name
== NULL
2352 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
2354 gfc_error ("IMPORT statement at %C only permitted in "
2355 "an INTERFACE body");
2359 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IMPORT statement at %C")
2363 if (gfc_match_eos () == MATCH_YES
)
2365 /* All host variables should be imported. */
2366 gfc_current_ns
->has_import_set
= 1;
2370 if (gfc_match (" ::") == MATCH_YES
)
2372 if (gfc_match_eos () == MATCH_YES
)
2374 gfc_error ("Expecting list of named entities at %C");
2381 m
= gfc_match (" %n", name
);
2385 if (gfc_current_ns
->parent
!= NULL
2386 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
2388 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2391 else if (gfc_current_ns
->proc_name
->ns
->parent
!= NULL
2392 && gfc_find_symbol (name
,
2393 gfc_current_ns
->proc_name
->ns
->parent
,
2396 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2402 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2403 "at %C - does not exist.", name
);
2407 if (gfc_find_symtree (gfc_current_ns
->sym_root
,name
))
2409 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2414 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
2417 sym
->ns
= gfc_current_ns
;
2429 if (gfc_match_eos () == MATCH_YES
)
2431 if (gfc_match_char (',') != MATCH_YES
)
2438 gfc_error ("Syntax error in IMPORT statement at %C");
2443 /* Matches an attribute specification including array specs. If
2444 successful, leaves the variables current_attr and current_as
2445 holding the specification. Also sets the colon_seen variable for
2446 later use by matchers associated with initializations.
2448 This subroutine is a little tricky in the sense that we don't know
2449 if we really have an attr-spec until we hit the double colon.
2450 Until that time, we can only return MATCH_NO. This forces us to
2451 check for duplicate specification at this level. */
2454 match_attr_spec (void)
2456 /* Modifiers that can exist in a type statement. */
2458 { GFC_DECL_BEGIN
= 0,
2459 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2460 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2461 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
2462 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
2463 DECL_IS_BIND_C
, DECL_COLON
, DECL_NONE
,
2464 GFC_DECL_END
/* Sentinel */
2468 /* GFC_DECL_END is the sentinel, index starts at 0. */
2469 #define NUM_DECL GFC_DECL_END
2471 static mstring decls
[] = {
2472 minit (", allocatable", DECL_ALLOCATABLE
),
2473 minit (", dimension", DECL_DIMENSION
),
2474 minit (", external", DECL_EXTERNAL
),
2475 minit (", intent ( in )", DECL_IN
),
2476 minit (", intent ( out )", DECL_OUT
),
2477 minit (", intent ( in out )", DECL_INOUT
),
2478 minit (", intrinsic", DECL_INTRINSIC
),
2479 minit (", optional", DECL_OPTIONAL
),
2480 minit (", parameter", DECL_PARAMETER
),
2481 minit (", pointer", DECL_POINTER
),
2482 minit (", protected", DECL_PROTECTED
),
2483 minit (", private", DECL_PRIVATE
),
2484 minit (", public", DECL_PUBLIC
),
2485 minit (", save", DECL_SAVE
),
2486 minit (", target", DECL_TARGET
),
2487 minit (", value", DECL_VALUE
),
2488 minit (", volatile", DECL_VOLATILE
),
2489 minit ("::", DECL_COLON
),
2490 minit (NULL
, DECL_NONE
)
2493 locus start
, seen_at
[NUM_DECL
];
2501 gfc_clear_attr (¤t_attr
);
2502 start
= gfc_current_locus
;
2507 /* See if we get all of the keywords up to the final double colon. */
2508 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2513 d
= (decl_types
) gfc_match_strings (decls
);
2517 /* See if we can find the bind(c) since all else failed.
2518 We need to skip over any whitespace and stop on the ','. */
2519 gfc_gobble_whitespace ();
2520 peek_char
= gfc_peek_char ();
2521 if (peek_char
== ',')
2523 /* Chomp the comma. */
2524 peek_char
= gfc_next_char ();
2525 /* Try and match the bind(c). */
2526 if (gfc_match_bind_c (NULL
) == MATCH_YES
)
2531 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2535 seen_at
[d
] = gfc_current_locus
;
2537 if (d
== DECL_DIMENSION
)
2539 m
= gfc_match_array_spec (¤t_as
);
2543 gfc_error ("Missing dimension specification at %C");
2547 if (m
== MATCH_ERROR
)
2552 /* No double colon, so assume that we've been looking at something
2553 else the whole time. */
2560 /* Since we've seen a double colon, we have to be looking at an
2561 attr-spec. This means that we can now issue errors. */
2562 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2567 case DECL_ALLOCATABLE
:
2568 attr
= "ALLOCATABLE";
2570 case DECL_DIMENSION
:
2577 attr
= "INTENT (IN)";
2580 attr
= "INTENT (OUT)";
2583 attr
= "INTENT (IN OUT)";
2585 case DECL_INTRINSIC
:
2591 case DECL_PARAMETER
:
2597 case DECL_PROTECTED
:
2612 case DECL_IS_BIND_C
:
2622 attr
= NULL
; /* This shouldn't happen. */
2625 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2630 /* Now that we've dealt with duplicate attributes, add the attributes
2631 to the current attribute. */
2632 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2637 if (gfc_current_state () == COMP_DERIVED
2638 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2639 && d
!= DECL_COLON
&& d
!= DECL_PRIVATE
2640 && d
!= DECL_PUBLIC
&& d
!= DECL_NONE
)
2642 if (d
== DECL_ALLOCATABLE
)
2644 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ALLOCATABLE "
2645 "attribute at %C in a TYPE definition")
2654 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2661 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2662 && gfc_current_state () != COMP_MODULE
)
2664 if (d
== DECL_PRIVATE
)
2668 if (gfc_current_state () == COMP_DERIVED
2669 && gfc_state_stack
->previous
2670 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
2672 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Attribute %s "
2673 "at %L in a TYPE definition", attr
,
2683 gfc_error ("%s attribute at %L is not allowed outside of the "
2684 "specification part of a module", attr
, &seen_at
[d
]);
2692 case DECL_ALLOCATABLE
:
2693 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2696 case DECL_DIMENSION
:
2697 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2701 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2705 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2709 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2713 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2716 case DECL_INTRINSIC
:
2717 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2721 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2724 case DECL_PARAMETER
:
2725 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2729 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2732 case DECL_PROTECTED
:
2733 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2735 gfc_error ("PROTECTED at %C only allowed in specification "
2736 "part of a module");
2741 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED "
2746 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
2750 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2755 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2760 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2764 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2767 case DECL_IS_BIND_C
:
2768 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
2772 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE attribute "
2777 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
2781 if (gfc_notify_std (GFC_STD_F2003
,
2782 "Fortran 2003: VOLATILE attribute at %C")
2786 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
2790 gfc_internal_error ("match_attr_spec(): Bad attribute");
2804 gfc_current_locus
= start
;
2805 gfc_free_array_spec (current_as
);
2811 /* Set the binding label, dest_label, either with the binding label
2812 stored in the given gfc_typespec, ts, or if none was provided, it
2813 will be the symbol name in all lower case, as required by the draft
2814 (J3/04-007, section 15.4.1). If a binding label was given and
2815 there is more than one argument (num_idents), it is an error. */
2818 set_binding_label (char *dest_label
, const char *sym_name
, int num_idents
)
2820 if (curr_binding_label
[0] != '\0')
2822 if (num_idents
> 1 || num_idents_on_line
> 1)
2824 gfc_error ("Multiple identifiers provided with "
2825 "single NAME= specifier at %C");
2829 /* Binding label given; store in temp holder til have sym. */
2830 strncpy (dest_label
, curr_binding_label
,
2831 strlen (curr_binding_label
) + 1);
2835 /* No binding label given, and the NAME= specifier did not exist,
2836 which means there was no NAME="". */
2837 if (sym_name
!= NULL
&& has_name_equals
== 0)
2838 strncpy (dest_label
, sym_name
, strlen (sym_name
) + 1);
2845 /* Set the status of the given common block as being BIND(C) or not,
2846 depending on the given parameter, is_bind_c. */
2849 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
2851 com_block
->is_bind_c
= is_bind_c
;
2856 /* Verify that the given gfc_typespec is for a C interoperable type. */
2859 verify_c_interop (gfc_typespec
*ts
, const char *name
, locus
*where
)
2863 /* Make sure the kind used is appropriate for the type.
2864 The f90_type is unknown if an integer constant was
2865 used (e.g., real(4), bind(c) :: myFloat). */
2866 if (ts
->f90_type
!= BT_UNKNOWN
)
2868 t
= gfc_validate_c_kind (ts
);
2871 /* Print an error, but continue parsing line. */
2872 gfc_error_now ("C kind parameter is for type %s but "
2873 "symbol '%s' at %L is of type %s",
2874 gfc_basic_typename (ts
->f90_type
),
2876 gfc_basic_typename (ts
->type
));
2880 /* Make sure the kind is C interoperable. This does not care about the
2881 possible error above. */
2882 if (ts
->type
== BT_DERIVED
&& ts
->derived
!= NULL
)
2883 return (ts
->derived
->ts
.is_c_interop
? SUCCESS
: FAILURE
);
2884 else if (ts
->is_c_interop
!= 1)
2891 /* Verify that the variables of a given common block, which has been
2892 defined with the attribute specifier bind(c), to be of a C
2893 interoperable type. Errors will be reported here, if
2897 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
2899 gfc_symbol
*curr_sym
= NULL
;
2900 try retval
= SUCCESS
;
2902 curr_sym
= com_block
->head
;
2904 /* Make sure we have at least one symbol. */
2905 if (curr_sym
== NULL
)
2908 /* Here we know we have a symbol, so we'll execute this loop
2912 /* The second to last param, 1, says this is in a common block. */
2913 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
2914 curr_sym
= curr_sym
->common_next
;
2915 } while (curr_sym
!= NULL
);
2921 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
2922 an appropriate error message is reported. */
2925 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
2926 int is_in_common
, gfc_common_head
*com_block
)
2928 try retval
= SUCCESS
;
2930 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
2932 tmp_sym
= tmp_sym
->result
;
2933 /* Make sure it wasn't an implicitly typed result. */
2934 if (tmp_sym
->attr
.implicit_type
)
2936 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
2937 "%L may not be C interoperable", tmp_sym
->name
,
2938 &tmp_sym
->declared_at
);
2939 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
2940 /* Mark it as C interoperable to prevent duplicate warnings. */
2941 tmp_sym
->ts
.is_c_interop
= 1;
2942 tmp_sym
->attr
.is_c_interop
= 1;
2946 /* Here, we know we have the bind(c) attribute, so if we have
2947 enough type info, then verify that it's a C interop kind.
2948 The info could be in the symbol already, or possibly still in
2949 the given ts (current_ts), so look in both. */
2950 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
2952 if (verify_c_interop (&(tmp_sym
->ts
), tmp_sym
->name
,
2953 &(tmp_sym
->declared_at
)) != SUCCESS
)
2955 /* See if we're dealing with a sym in a common block or not. */
2956 if (is_in_common
== 1)
2958 gfc_warning ("Variable '%s' in common block '%s' at %L "
2959 "may not be a C interoperable "
2960 "kind though common block '%s' is BIND(C)",
2961 tmp_sym
->name
, com_block
->name
,
2962 &(tmp_sym
->declared_at
), com_block
->name
);
2966 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
2967 gfc_error ("Type declaration '%s' at %L is not C "
2968 "interoperable but it is BIND(C)",
2969 tmp_sym
->name
, &(tmp_sym
->declared_at
));
2971 gfc_warning ("Variable '%s' at %L "
2972 "may not be a C interoperable "
2973 "kind but it is bind(c)",
2974 tmp_sym
->name
, &(tmp_sym
->declared_at
));
2978 /* Variables declared w/in a common block can't be bind(c)
2979 since there's no way for C to see these variables, so there's
2980 semantically no reason for the attribute. */
2981 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
2983 gfc_error ("Variable '%s' in common block '%s' at "
2984 "%L cannot be declared with BIND(C) "
2985 "since it is not a global",
2986 tmp_sym
->name
, com_block
->name
,
2987 &(tmp_sym
->declared_at
));
2991 /* Scalar variables that are bind(c) can not have the pointer
2992 or allocatable attributes. */
2993 if (tmp_sym
->attr
.is_bind_c
== 1)
2995 if (tmp_sym
->attr
.pointer
== 1)
2997 gfc_error ("Variable '%s' at %L cannot have both the "
2998 "POINTER and BIND(C) attributes",
2999 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3003 if (tmp_sym
->attr
.allocatable
== 1)
3005 gfc_error ("Variable '%s' at %L cannot have both the "
3006 "ALLOCATABLE and BIND(C) attributes",
3007 tmp_sym
->name
, &(tmp_sym
->declared_at
));
3011 /* If it is a BIND(C) function, make sure the return value is a
3012 scalar value. The previous tests in this function made sure
3013 the type is interoperable. */
3014 if (tmp_sym
->attr
.function
== 1 && tmp_sym
->as
!= NULL
)
3015 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3016 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
3018 /* BIND(C) functions can not return a character string. */
3019 if (tmp_sym
->attr
.function
== 1 && tmp_sym
->ts
.type
== BT_CHARACTER
)
3020 if (tmp_sym
->ts
.cl
== NULL
|| tmp_sym
->ts
.cl
->length
== NULL
3021 || tmp_sym
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3022 || mpz_cmp_si (tmp_sym
->ts
.cl
->length
->value
.integer
, 1) != 0)
3023 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3024 "be a character string", tmp_sym
->name
,
3025 &(tmp_sym
->declared_at
));
3029 /* See if the symbol has been marked as private. If it has, make sure
3030 there is no binding label and warn the user if there is one. */
3031 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
3032 && tmp_sym
->binding_label
[0] != '\0')
3033 /* Use gfc_warning_now because we won't say that the symbol fails
3034 just because of this. */
3035 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3036 "given the binding label '%s'", tmp_sym
->name
,
3037 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
3043 /* Set the appropriate fields for a symbol that's been declared as
3044 BIND(C) (the is_bind_c flag and the binding label), and verify that
3045 the type is C interoperable. Errors are reported by the functions
3046 used to set/test these fields. */
3049 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
3051 try retval
= SUCCESS
;
3053 /* TODO: Do we need to make sure the vars aren't marked private? */
3055 /* Set the is_bind_c bit in symbol_attribute. */
3056 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
3058 if (set_binding_label (tmp_sym
->binding_label
, tmp_sym
->name
,
3059 num_idents
) != SUCCESS
)
3066 /* Set the fields marking the given common block as BIND(C), including
3067 a binding label, and report any errors encountered. */
3070 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
3072 try retval
= SUCCESS
;
3074 /* destLabel, common name, typespec (which may have binding label). */
3075 if (set_binding_label (com_block
->binding_label
, com_block
->name
, num_idents
)
3079 /* Set the given common block (com_block) to being bind(c) (1). */
3080 set_com_block_bind_c (com_block
, 1);
3086 /* Retrieve the list of one or more identifiers that the given bind(c)
3087 attribute applies to. */
3090 get_bind_c_idents (void)
3092 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3094 gfc_symbol
*tmp_sym
= NULL
;
3096 gfc_common_head
*com_block
= NULL
;
3098 if (gfc_match_name (name
) == MATCH_YES
)
3100 found_id
= MATCH_YES
;
3101 gfc_get_ha_symbol (name
, &tmp_sym
);
3103 else if (match_common_name (name
) == MATCH_YES
)
3105 found_id
= MATCH_YES
;
3106 com_block
= gfc_get_common (name
, 0);
3110 gfc_error ("Need either entity or common block name for "
3111 "attribute specification statement at %C");
3115 /* Save the current identifier and look for more. */
3118 /* Increment the number of identifiers found for this spec stmt. */
3121 /* Make sure we have a sym or com block, and verify that it can
3122 be bind(c). Set the appropriate field(s) and look for more
3124 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
3126 if (tmp_sym
!= NULL
)
3128 if (set_verify_bind_c_sym (tmp_sym
, num_idents
)
3134 if (set_verify_bind_c_com_block(com_block
, num_idents
)
3139 /* Look to see if we have another identifier. */
3141 if (gfc_match_eos () == MATCH_YES
)
3142 found_id
= MATCH_NO
;
3143 else if (gfc_match_char (',') != MATCH_YES
)
3144 found_id
= MATCH_NO
;
3145 else if (gfc_match_name (name
) == MATCH_YES
)
3147 found_id
= MATCH_YES
;
3148 gfc_get_ha_symbol (name
, &tmp_sym
);
3150 else if (match_common_name (name
) == MATCH_YES
)
3152 found_id
= MATCH_YES
;
3153 com_block
= gfc_get_common (name
, 0);
3157 gfc_error ("Missing entity or common block name for "
3158 "attribute specification statement at %C");
3164 gfc_internal_error ("Missing symbol");
3166 } while (found_id
== MATCH_YES
);
3168 /* if we get here we were successful */
3173 /* Try and match a BIND(C) attribute specification statement. */
3176 gfc_match_bind_c_stmt (void)
3178 match found_match
= MATCH_NO
;
3183 /* This may not be necessary. */
3185 /* Clear the temporary binding label holder. */
3186 curr_binding_label
[0] = '\0';
3188 /* Look for the bind(c). */
3189 found_match
= gfc_match_bind_c (NULL
);
3191 if (found_match
== MATCH_YES
)
3193 /* Look for the :: now, but it is not required. */
3196 /* Get the identifier(s) that needs to be updated. This may need to
3197 change to hand the flag(s) for the attr specified so all identifiers
3198 found can have all appropriate parts updated (assuming that the same
3199 spec stmt can have multiple attrs, such as both bind(c) and
3201 if (get_bind_c_idents () != SUCCESS
)
3202 /* Error message should have printed already. */
3210 /* Match a data declaration statement. */
3213 gfc_match_data_decl (void)
3219 num_idents_on_line
= 0;
3221 m
= match_type_spec (¤t_ts
, 0);
3225 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
3227 sym
= gfc_use_derived (current_ts
.derived
);
3235 current_ts
.derived
= sym
;
3238 m
= match_attr_spec ();
3239 if (m
== MATCH_ERROR
)
3245 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
3248 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
3251 gfc_find_symbol (current_ts
.derived
->name
,
3252 current_ts
.derived
->ns
->parent
, 1, &sym
);
3254 /* Any symbol that we find had better be a type definition
3255 which has its components defined. */
3256 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
3257 && current_ts
.derived
->components
!= NULL
)
3260 /* Now we have an error, which we signal, and then fix up
3261 because the knock-on is plain and simple confusing. */
3262 gfc_error_now ("Derived type at %C has not been previously defined "
3263 "and so cannot appear in a derived type definition");
3264 current_attr
.pointer
= 1;
3269 /* If we have an old-style character declaration, and no new-style
3270 attribute specifications, then there a comma is optional between
3271 the type specification and the variable list. */
3272 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
3273 gfc_match_char (',');
3275 /* Give the types/attributes to symbols that follow. Give the element
3276 a number so that repeat character length expressions can be copied. */
3280 num_idents_on_line
++;
3281 m
= variable_decl (elem
++);
3282 if (m
== MATCH_ERROR
)
3287 if (gfc_match_eos () == MATCH_YES
)
3289 if (gfc_match_char (',') != MATCH_YES
)
3293 if (gfc_error_flag_test () == 0)
3294 gfc_error ("Syntax error in data declaration at %C");
3297 gfc_free_data_all (gfc_current_ns
);
3300 gfc_free_array_spec (current_as
);
3306 /* Match a prefix associated with a function or subroutine
3307 declaration. If the typespec pointer is nonnull, then a typespec
3308 can be matched. Note that if nothing matches, MATCH_YES is
3309 returned (the null string was matched). */
3312 match_prefix (gfc_typespec
*ts
)
3316 gfc_clear_attr (¤t_attr
);
3320 if (!seen_type
&& ts
!= NULL
3321 && match_type_spec (ts
, 0) == MATCH_YES
3322 && gfc_match_space () == MATCH_YES
)
3329 if (gfc_match ("elemental% ") == MATCH_YES
)
3331 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
3337 if (gfc_match ("pure% ") == MATCH_YES
)
3339 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
3345 if (gfc_match ("recursive% ") == MATCH_YES
)
3347 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
3353 /* At this point, the next item is not a prefix. */
3358 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
3361 copy_prefix (symbol_attribute
*dest
, locus
*where
)
3363 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
3366 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
3369 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
3376 /* Match a formal argument list. */
3379 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
3381 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
3382 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3388 if (gfc_match_char ('(') != MATCH_YES
)
3395 if (gfc_match_char (')') == MATCH_YES
)
3400 if (gfc_match_char ('*') == MATCH_YES
)
3404 m
= gfc_match_name (name
);
3408 if (gfc_get_symbol (name
, NULL
, &sym
))
3412 p
= gfc_get_formal_arglist ();
3424 /* We don't add the VARIABLE flavor because the name could be a
3425 dummy procedure. We don't apply these attributes to formal
3426 arguments of statement functions. */
3427 if (sym
!= NULL
&& !st_flag
3428 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
3429 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
3435 /* The name of a program unit can be in a different namespace,
3436 so check for it explicitly. After the statement is accepted,
3437 the name is checked for especially in gfc_get_symbol(). */
3438 if (gfc_new_block
!= NULL
&& sym
!= NULL
3439 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
3441 gfc_error ("Name '%s' at %C is the name of the procedure",
3447 if (gfc_match_char (')') == MATCH_YES
)
3450 m
= gfc_match_char (',');
3453 gfc_error ("Unexpected junk in formal argument list at %C");
3459 /* Check for duplicate symbols in the formal argument list. */
3462 for (p
= head
; p
->next
; p
= p
->next
)
3467 for (q
= p
->next
; q
; q
= q
->next
)
3468 if (p
->sym
== q
->sym
)
3470 gfc_error ("Duplicate symbol '%s' in formal argument list "
3471 "at %C", p
->sym
->name
);
3479 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
)
3489 gfc_free_formal_arglist (head
);
3494 /* Match a RESULT specification following a function declaration or
3495 ENTRY statement. Also matches the end-of-statement. */
3498 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
3500 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3504 if (gfc_match (" result (") != MATCH_YES
)
3507 m
= gfc_match_name (name
);
3511 /* Get the right paren, and that's it because there could be the
3512 bind(c) attribute after the result clause. */
3513 if (gfc_match_char(')') != MATCH_YES
)
3515 /* TODO: should report the missing right paren here. */
3519 if (strcmp (function
->name
, name
) == 0)
3521 gfc_error ("RESULT variable at %C must be different than function name");
3525 if (gfc_get_symbol (name
, NULL
, &r
))
3528 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
3529 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
3538 /* Match a function suffix, which could be a combination of a result
3539 clause and BIND(C), either one, or neither. The draft does not
3540 require them to come in a specific order. */
3543 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
3545 match is_bind_c
; /* Found bind(c). */
3546 match is_result
; /* Found result clause. */
3547 match found_match
; /* Status of whether we've found a good match. */
3548 int peek_char
; /* Character we're going to peek at. */
3550 /* Initialize to having found nothing. */
3551 found_match
= MATCH_NO
;
3552 is_bind_c
= MATCH_NO
;
3553 is_result
= MATCH_NO
;
3555 /* Get the next char to narrow between result and bind(c). */
3556 gfc_gobble_whitespace ();
3557 peek_char
= gfc_peek_char ();
3562 /* Look for result clause. */
3563 is_result
= match_result (sym
, result
);
3564 if (is_result
== MATCH_YES
)
3566 /* Now see if there is a bind(c) after it. */
3567 is_bind_c
= gfc_match_bind_c (sym
);
3568 /* We've found the result clause and possibly bind(c). */
3569 found_match
= MATCH_YES
;
3572 /* This should only be MATCH_ERROR. */
3573 found_match
= is_result
;
3576 /* Look for bind(c) first. */
3577 is_bind_c
= gfc_match_bind_c (sym
);
3578 if (is_bind_c
== MATCH_YES
)
3580 /* Now see if a result clause followed it. */
3581 is_result
= match_result (sym
, result
);
3582 found_match
= MATCH_YES
;
3586 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
3587 found_match
= MATCH_ERROR
;
3591 gfc_error ("Unexpected junk after function declaration at %C");
3592 found_match
= MATCH_ERROR
;
3596 if (is_bind_c
== MATCH_YES
)
3597 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1)
3605 /* Match a function declaration. */
3608 gfc_match_function_decl (void)
3610 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3611 gfc_symbol
*sym
, *result
;
3615 match found_match
; /* Status returned by match func. */
3617 if (gfc_current_state () != COMP_NONE
3618 && gfc_current_state () != COMP_INTERFACE
3619 && gfc_current_state () != COMP_CONTAINS
)
3622 gfc_clear_ts (¤t_ts
);
3624 old_loc
= gfc_current_locus
;
3626 m
= match_prefix (¤t_ts
);
3629 gfc_current_locus
= old_loc
;
3633 if (gfc_match ("function% %n", name
) != MATCH_YES
)
3635 gfc_current_locus
= old_loc
;
3638 if (get_proc_name (name
, &sym
, false))
3640 gfc_new_block
= sym
;
3642 m
= gfc_match_formal_arglist (sym
, 0, 0);
3645 gfc_error ("Expected formal argument list in function "
3646 "definition at %C");
3650 else if (m
== MATCH_ERROR
)
3655 /* According to the draft, the bind(c) and result clause can
3656 come in either order after the formal_arg_list (i.e., either
3657 can be first, both can exist together or by themselves or neither
3658 one). Therefore, the match_result can't match the end of the
3659 string, and check for the bind(c) or result clause in either order. */
3660 found_match
= gfc_match_eos ();
3662 /* Make sure that it isn't already declared as BIND(C). If it is, it
3663 must have been marked BIND(C) with a BIND(C) attribute and that is
3664 not allowed for procedures. */
3665 if (sym
->attr
.is_bind_c
== 1)
3667 sym
->attr
.is_bind_c
= 0;
3668 if (sym
->old_symbol
!= NULL
)
3669 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3670 "variables or common blocks",
3671 &(sym
->old_symbol
->declared_at
));
3673 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3674 "variables or common blocks", &gfc_current_locus
);
3677 if (found_match
!= MATCH_YES
)
3679 /* If we haven't found the end-of-statement, look for a suffix. */
3680 suffix_match
= gfc_match_suffix (sym
, &result
);
3681 if (suffix_match
== MATCH_YES
)
3682 /* Need to get the eos now. */
3683 found_match
= gfc_match_eos ();
3685 found_match
= suffix_match
;
3688 if(found_match
!= MATCH_YES
)
3692 /* Make changes to the symbol. */
3695 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3698 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
3699 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
3702 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
3703 && !sym
->attr
.implicit_type
)
3705 gfc_error ("Function '%s' at %C already has a type of %s", name
,
3706 gfc_basic_typename (sym
->ts
.type
));
3712 sym
->ts
= current_ts
;
3717 result
->ts
= current_ts
;
3718 sym
->result
= result
;
3725 gfc_current_locus
= old_loc
;
3730 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
3731 pass the name of the entry, rather than the gfc_current_block name, and
3732 to return false upon finding an existing global entry. */
3735 add_global_entry (const char *name
, int sub
)
3739 s
= gfc_get_gsymbol(name
);
3742 || (s
->type
!= GSYM_UNKNOWN
3743 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3744 global_used(s
, NULL
);
3747 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3748 s
->where
= gfc_current_locus
;
3756 /* Match an ENTRY statement. */
3759 gfc_match_entry (void)
3764 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3765 gfc_compile_state state
;
3769 bool module_procedure
;
3771 m
= gfc_match_name (name
);
3775 state
= gfc_current_state ();
3776 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
3781 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
3784 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
3786 case COMP_BLOCK_DATA
:
3787 gfc_error ("ENTRY statement at %C cannot appear within "
3790 case COMP_INTERFACE
:
3791 gfc_error ("ENTRY statement at %C cannot appear within "
3795 gfc_error ("ENTRY statement at %C cannot appear within "
3796 "a DERIVED TYPE block");
3799 gfc_error ("ENTRY statement at %C cannot appear within "
3800 "an IF-THEN block");
3803 gfc_error ("ENTRY statement at %C cannot appear within "
3807 gfc_error ("ENTRY statement at %C cannot appear within "
3811 gfc_error ("ENTRY statement at %C cannot appear within "
3815 gfc_error ("ENTRY statement at %C cannot appear within "
3819 gfc_error ("ENTRY statement at %C cannot appear within "
3820 "a contained subprogram");
3823 gfc_internal_error ("gfc_match_entry(): Bad state");
3828 module_procedure
= gfc_current_ns
->parent
!= NULL
3829 && gfc_current_ns
->parent
->proc_name
3830 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
3833 if (gfc_current_ns
->parent
!= NULL
3834 && gfc_current_ns
->parent
->proc_name
3835 && !module_procedure
)
3837 gfc_error("ENTRY statement at %C cannot appear in a "
3838 "contained procedure");
3842 /* Module function entries need special care in get_proc_name
3843 because previous references within the function will have
3844 created symbols attached to the current namespace. */
3845 if (get_proc_name (name
, &entry
,
3846 gfc_current_ns
->parent
!= NULL
3848 && gfc_current_ns
->proc_name
->attr
.function
))
3851 proc
= gfc_current_block ();
3853 if (state
== COMP_SUBROUTINE
)
3855 /* An entry in a subroutine. */
3856 if (!add_global_entry (name
, 1))
3859 m
= gfc_match_formal_arglist (entry
, 0, 1);
3863 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
3864 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
3869 /* An entry in a function.
3870 We need to take special care because writing
3875 ENTRY f() RESULT (r)
3877 ENTRY f RESULT (r). */
3878 if (!add_global_entry (name
, 0))
3881 old_loc
= gfc_current_locus
;
3882 if (gfc_match_eos () == MATCH_YES
)
3884 gfc_current_locus
= old_loc
;
3885 /* Match the empty argument list, and add the interface to
3887 m
= gfc_match_formal_arglist (entry
, 0, 1);
3890 m
= gfc_match_formal_arglist (entry
, 0, 0);
3897 if (gfc_match_eos () == MATCH_YES
)
3899 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
3900 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
3903 entry
->result
= entry
;
3907 m
= match_result (proc
, &result
);
3909 gfc_syntax_error (ST_ENTRY
);
3913 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
3914 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
3915 || gfc_add_function (&entry
->attr
, result
->name
, NULL
)
3919 entry
->result
= result
;
3923 if (gfc_match_eos () != MATCH_YES
)
3925 gfc_syntax_error (ST_ENTRY
);
3929 entry
->attr
.recursive
= proc
->attr
.recursive
;
3930 entry
->attr
.elemental
= proc
->attr
.elemental
;
3931 entry
->attr
.pure
= proc
->attr
.pure
;
3933 el
= gfc_get_entry_list ();
3935 el
->next
= gfc_current_ns
->entries
;
3936 gfc_current_ns
->entries
= el
;
3938 el
->id
= el
->next
->id
+ 1;
3942 new_st
.op
= EXEC_ENTRY
;
3943 new_st
.ext
.entry
= el
;
3949 /* Match a subroutine statement, including optional prefixes. */
3952 gfc_match_subroutine (void)
3954 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3960 if (gfc_current_state () != COMP_NONE
3961 && gfc_current_state () != COMP_INTERFACE
3962 && gfc_current_state () != COMP_CONTAINS
)
3965 m
= match_prefix (NULL
);
3969 m
= gfc_match ("subroutine% %n", name
);
3973 if (get_proc_name (name
, &sym
, false))
3975 gfc_new_block
= sym
;
3977 /* Check what next non-whitespace character is so we can tell if there
3978 where the required parens if we have a BIND(C). */
3979 gfc_gobble_whitespace ();
3980 peek_char
= gfc_peek_char ();
3982 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3985 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
3988 /* Make sure that it isn't already declared as BIND(C). If it is, it
3989 must have been marked BIND(C) with a BIND(C) attribute and that is
3990 not allowed for procedures. */
3991 if (sym
->attr
.is_bind_c
== 1)
3993 sym
->attr
.is_bind_c
= 0;
3994 if (sym
->old_symbol
!= NULL
)
3995 gfc_error_now ("BIND(C) attribute at %L can only be used for "
3996 "variables or common blocks",
3997 &(sym
->old_symbol
->declared_at
));
3999 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4000 "variables or common blocks", &gfc_current_locus
);
4003 /* Here, we are just checking if it has the bind(c) attribute, and if
4004 so, then we need to make sure it's all correct. If it doesn't,
4005 we still need to continue matching the rest of the subroutine line. */
4006 is_bind_c
= gfc_match_bind_c (sym
);
4007 if (is_bind_c
== MATCH_ERROR
)
4009 /* There was an attempt at the bind(c), but it was wrong. An
4010 error message should have been printed w/in the gfc_match_bind_c
4011 so here we'll just return the MATCH_ERROR. */
4015 if (is_bind_c
== MATCH_YES
)
4017 if (peek_char
!= '(')
4019 gfc_error ("Missing required parentheses before BIND(C) at %C");
4022 if (gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1)
4027 if (gfc_match_eos () != MATCH_YES
)
4029 gfc_syntax_error (ST_SUBROUTINE
);
4033 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
4040 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4041 given, and set the binding label in either the given symbol (if not
4042 NULL), or in the current_ts. The symbol may be NULL because we may
4043 encounter the BIND(C) before the declaration itself. Return
4044 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4045 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4046 or MATCH_YES if the specifier was correct and the binding label and
4047 bind(c) fields were set correctly for the given symbol or the
4051 gfc_match_bind_c (gfc_symbol
*sym
)
4053 /* binding label, if exists */
4054 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
4057 int has_name_equals
= 0;
4059 /* Initialize the flag that specifies whether we encountered a NAME=
4060 specifier or not. */
4061 has_name_equals
= 0;
4063 /* Init the first char to nil so we can catch if we don't have
4064 the label (name attr) or the symbol name yet. */
4065 binding_label
[0] = '\0';
4067 /* This much we have to be able to match, in this order, if
4068 there is a bind(c) label. */
4069 if (gfc_match (" bind ( c ") != MATCH_YES
)
4072 /* Now see if there is a binding label, or if we've reached the
4073 end of the bind(c) attribute without one. */
4074 if (gfc_match_char (',') == MATCH_YES
)
4076 if (gfc_match (" name = ") != MATCH_YES
)
4078 gfc_error ("Syntax error in NAME= specifier for binding label "
4080 /* should give an error message here */
4084 has_name_equals
= 1;
4086 /* Get the opening quote. */
4087 double_quote
= MATCH_YES
;
4088 single_quote
= MATCH_YES
;
4089 double_quote
= gfc_match_char ('"');
4090 if (double_quote
!= MATCH_YES
)
4091 single_quote
= gfc_match_char ('\'');
4092 if (double_quote
!= MATCH_YES
&& single_quote
!= MATCH_YES
)
4094 gfc_error ("Syntax error in NAME= specifier for binding label "
4099 /* Grab the binding label, using functions that will not lower
4100 case the names automatically. */
4101 if (gfc_match_name_C (binding_label
) != MATCH_YES
)
4104 /* Get the closing quotation. */
4105 if (double_quote
== MATCH_YES
)
4107 if (gfc_match_char ('"') != MATCH_YES
)
4109 gfc_error ("Missing closing quote '\"' for binding label at %C");
4110 /* User started string with '"' so looked to match it. */
4116 if (gfc_match_char ('\'') != MATCH_YES
)
4118 gfc_error ("Missing closing quote '\'' for binding label at %C");
4119 /* User started string with "'" char. */
4125 /* Get the required right paren. */
4126 if (gfc_match_char (')') != MATCH_YES
)
4128 gfc_error ("Missing closing paren for binding label at %C");
4132 /* Save the binding label to the symbol. If sym is null, we're
4133 probably matching the typespec attributes of a declaration and
4134 haven't gotten the name yet, and therefore, no symbol yet. */
4135 if (binding_label
[0] != '\0')
4139 strncpy (sym
->binding_label
, binding_label
,
4140 strlen (binding_label
)+1);
4143 strncpy (curr_binding_label
, binding_label
,
4144 strlen (binding_label
) + 1);
4148 /* No binding label, but if symbol isn't null, we
4149 can set the label for it here. */
4150 /* TODO: If the name= was given and no binding label (name=""), we simply
4151 will let fortran mangle the symbol name as it usually would.
4152 However, this could still let C call it if the user looked up the
4153 symbol in the object file. Should the name set during mangling in
4154 trans-decl.c be marked with characters that are invalid for C to
4156 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
4157 strncpy (sym
->binding_label
, sym
->name
, strlen (sym
->name
) + 1);
4164 /* Return nonzero if we're currently compiling a contained procedure. */
4167 contained_procedure (void)
4171 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
4172 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
4173 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
4179 /* Set the kind of each enumerator. The kind is selected such that it is
4180 interoperable with the corresponding C enumeration type, making
4181 sure that -fshort-enums is honored. */
4186 enumerator_history
*current_history
= NULL
;
4190 if (max_enum
== NULL
|| enum_history
== NULL
)
4193 if (!gfc_option
.fshort_enums
)
4199 kind
= gfc_integer_kinds
[i
++].kind
;
4201 while (kind
< gfc_c_int_kind
4202 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
4205 current_history
= enum_history
;
4206 while (current_history
!= NULL
)
4208 current_history
->sym
->ts
.kind
= kind
;
4209 current_history
= current_history
->next
;
4214 /* Match any of the various end-block statements. Returns the type of
4215 END to the caller. The END INTERFACE, END IF, END DO and END
4216 SELECT statements cannot be replaced by a single END statement. */
4219 gfc_match_end (gfc_statement
*st
)
4221 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4222 gfc_compile_state state
;
4224 const char *block_name
;
4229 old_loc
= gfc_current_locus
;
4230 if (gfc_match ("end") != MATCH_YES
)
4233 state
= gfc_current_state ();
4234 block_name
= gfc_current_block () == NULL
4235 ? NULL
: gfc_current_block ()->name
;
4237 if (state
== COMP_CONTAINS
)
4239 state
= gfc_state_stack
->previous
->state
;
4240 block_name
= gfc_state_stack
->previous
->sym
== NULL
4241 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
4248 *st
= ST_END_PROGRAM
;
4249 target
= " program";
4253 case COMP_SUBROUTINE
:
4254 *st
= ST_END_SUBROUTINE
;
4255 target
= " subroutine";
4256 eos_ok
= !contained_procedure ();
4260 *st
= ST_END_FUNCTION
;
4261 target
= " function";
4262 eos_ok
= !contained_procedure ();
4265 case COMP_BLOCK_DATA
:
4266 *st
= ST_END_BLOCK_DATA
;
4267 target
= " block data";
4272 *st
= ST_END_MODULE
;
4277 case COMP_INTERFACE
:
4278 *st
= ST_END_INTERFACE
;
4279 target
= " interface";
4302 *st
= ST_END_SELECT
;
4308 *st
= ST_END_FORALL
;
4323 last_initializer
= NULL
;
4325 gfc_free_enum_history ();
4329 gfc_error ("Unexpected END statement at %C");
4333 if (gfc_match_eos () == MATCH_YES
)
4337 /* We would have required END [something]. */
4338 gfc_error ("%s statement expected at %L",
4339 gfc_ascii_statement (*st
), &old_loc
);
4346 /* Verify that we've got the sort of end-block that we're expecting. */
4347 if (gfc_match (target
) != MATCH_YES
)
4349 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
4353 /* If we're at the end, make sure a block name wasn't required. */
4354 if (gfc_match_eos () == MATCH_YES
)
4357 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
4358 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
)
4361 if (gfc_current_block () == NULL
)
4364 gfc_error ("Expected block name of '%s' in %s statement at %C",
4365 block_name
, gfc_ascii_statement (*st
));
4370 /* END INTERFACE has a special handler for its several possible endings. */
4371 if (*st
== ST_END_INTERFACE
)
4372 return gfc_match_end_interface ();
4374 /* We haven't hit the end of statement, so what is left must be an
4376 m
= gfc_match_space ();
4378 m
= gfc_match_name (name
);
4381 gfc_error ("Expected terminating name at %C");
4385 if (block_name
== NULL
)
4388 if (strcmp (name
, block_name
) != 0)
4390 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
4391 gfc_ascii_statement (*st
));
4395 if (gfc_match_eos () == MATCH_YES
)
4399 gfc_syntax_error (*st
);
4402 gfc_current_locus
= old_loc
;
4408 /***************** Attribute declaration statements ****************/
4410 /* Set the attribute of a single variable. */
4415 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4423 m
= gfc_match_name (name
);
4427 if (find_special (name
, &sym
))
4430 var_locus
= gfc_current_locus
;
4432 /* Deal with possible array specification for certain attributes. */
4433 if (current_attr
.dimension
4434 || current_attr
.allocatable
4435 || current_attr
.pointer
4436 || current_attr
.target
)
4438 m
= gfc_match_array_spec (&as
);
4439 if (m
== MATCH_ERROR
)
4442 if (current_attr
.dimension
&& m
== MATCH_NO
)
4444 gfc_error ("Missing array specification at %L in DIMENSION "
4445 "statement", &var_locus
);
4450 if ((current_attr
.allocatable
|| current_attr
.pointer
)
4451 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
4453 gfc_error ("Array specification must be deferred at %L", &var_locus
);
4459 /* Update symbol table. DIMENSION attribute is set
4460 in gfc_set_array_spec(). */
4461 if (current_attr
.dimension
== 0
4462 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
4468 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
4474 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
4476 /* Fix the array spec. */
4477 m
= gfc_mod_pointee_as (sym
->as
);
4478 if (m
== MATCH_ERROR
)
4482 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
4488 if ((current_attr
.external
|| current_attr
.intrinsic
)
4489 && sym
->attr
.flavor
!= FL_PROCEDURE
4490 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
4499 gfc_free_array_spec (as
);
4504 /* Generic attribute declaration subroutine. Used for attributes that
4505 just have a list of names. */
4512 /* Gobble the optional double colon, by simply ignoring the result
4522 if (gfc_match_eos () == MATCH_YES
)
4528 if (gfc_match_char (',') != MATCH_YES
)
4530 gfc_error ("Unexpected character in variable list at %C");
4540 /* This routine matches Cray Pointer declarations of the form:
4541 pointer ( <pointer>, <pointee> )
4543 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
4544 The pointer, if already declared, should be an integer. Otherwise, we
4545 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
4546 be either a scalar, or an array declaration. No space is allocated for
4547 the pointee. For the statement
4548 pointer (ipt, ar(10))
4549 any subsequent uses of ar will be translated (in C-notation) as
4550 ar(i) => ((<type> *) ipt)(i)
4551 After gimplification, pointee variable will disappear in the code. */
4554 cray_pointer_decl (void)
4558 gfc_symbol
*cptr
; /* Pointer symbol. */
4559 gfc_symbol
*cpte
; /* Pointee symbol. */
4565 if (gfc_match_char ('(') != MATCH_YES
)
4567 gfc_error ("Expected '(' at %C");
4571 /* Match pointer. */
4572 var_locus
= gfc_current_locus
;
4573 gfc_clear_attr (¤t_attr
);
4574 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
4575 current_ts
.type
= BT_INTEGER
;
4576 current_ts
.kind
= gfc_index_integer_kind
;
4578 m
= gfc_match_symbol (&cptr
, 0);
4581 gfc_error ("Expected variable name at %C");
4585 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
4588 gfc_set_sym_referenced (cptr
);
4590 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
4592 cptr
->ts
.type
= BT_INTEGER
;
4593 cptr
->ts
.kind
= gfc_index_integer_kind
;
4595 else if (cptr
->ts
.type
!= BT_INTEGER
)
4597 gfc_error ("Cray pointer at %C must be an integer");
4600 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
4601 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
4602 " memory addresses require %d bytes",
4603 cptr
->ts
.kind
, gfc_index_integer_kind
);
4605 if (gfc_match_char (',') != MATCH_YES
)
4607 gfc_error ("Expected \",\" at %C");
4611 /* Match Pointee. */
4612 var_locus
= gfc_current_locus
;
4613 gfc_clear_attr (¤t_attr
);
4614 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
4615 current_ts
.type
= BT_UNKNOWN
;
4616 current_ts
.kind
= 0;
4618 m
= gfc_match_symbol (&cpte
, 0);
4621 gfc_error ("Expected variable name at %C");
4625 /* Check for an optional array spec. */
4626 m
= gfc_match_array_spec (&as
);
4627 if (m
== MATCH_ERROR
)
4629 gfc_free_array_spec (as
);
4632 else if (m
== MATCH_NO
)
4634 gfc_free_array_spec (as
);
4638 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
4641 gfc_set_sym_referenced (cpte
);
4643 if (cpte
->as
== NULL
)
4645 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
4646 gfc_internal_error ("Couldn't set Cray pointee array spec.");
4648 else if (as
!= NULL
)
4650 gfc_error ("Duplicate array spec for Cray pointee at %C");
4651 gfc_free_array_spec (as
);
4657 if (cpte
->as
!= NULL
)
4659 /* Fix array spec. */
4660 m
= gfc_mod_pointee_as (cpte
->as
);
4661 if (m
== MATCH_ERROR
)
4665 /* Point the Pointee at the Pointer. */
4666 cpte
->cp_pointer
= cptr
;
4668 if (gfc_match_char (')') != MATCH_YES
)
4670 gfc_error ("Expected \")\" at %C");
4673 m
= gfc_match_char (',');
4675 done
= true; /* Stop searching for more declarations. */
4679 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
4680 || gfc_match_eos () != MATCH_YES
)
4682 gfc_error ("Expected \",\" or end of statement at %C");
4690 gfc_match_external (void)
4693 gfc_clear_attr (¤t_attr
);
4694 current_attr
.external
= 1;
4696 return attr_decl ();
4701 gfc_match_intent (void)
4705 intent
= match_intent_spec ();
4706 if (intent
== INTENT_UNKNOWN
)
4709 gfc_clear_attr (¤t_attr
);
4710 current_attr
.intent
= intent
;
4712 return attr_decl ();
4717 gfc_match_intrinsic (void)
4720 gfc_clear_attr (¤t_attr
);
4721 current_attr
.intrinsic
= 1;
4723 return attr_decl ();
4728 gfc_match_optional (void)
4731 gfc_clear_attr (¤t_attr
);
4732 current_attr
.optional
= 1;
4734 return attr_decl ();
4739 gfc_match_pointer (void)
4741 gfc_gobble_whitespace ();
4742 if (gfc_peek_char () == '(')
4744 if (!gfc_option
.flag_cray_pointer
)
4746 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
4750 return cray_pointer_decl ();
4754 gfc_clear_attr (¤t_attr
);
4755 current_attr
.pointer
= 1;
4757 return attr_decl ();
4763 gfc_match_allocatable (void)
4765 gfc_clear_attr (¤t_attr
);
4766 current_attr
.allocatable
= 1;
4768 return attr_decl ();
4773 gfc_match_dimension (void)
4775 gfc_clear_attr (¤t_attr
);
4776 current_attr
.dimension
= 1;
4778 return attr_decl ();
4783 gfc_match_target (void)
4785 gfc_clear_attr (¤t_attr
);
4786 current_attr
.target
= 1;
4788 return attr_decl ();
4792 /* Match the list of entities being specified in a PUBLIC or PRIVATE
4796 access_attr_decl (gfc_statement st
)
4798 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4799 interface_type type
;
4802 gfc_intrinsic_op
operator;
4805 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4810 m
= gfc_match_generic_spec (&type
, name
, &operator);
4813 if (m
== MATCH_ERROR
)
4818 case INTERFACE_NAMELESS
:
4821 case INTERFACE_GENERIC
:
4822 if (gfc_get_symbol (name
, NULL
, &sym
))
4825 if (gfc_add_access (&sym
->attr
, (st
== ST_PUBLIC
)
4826 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
4827 sym
->name
, NULL
) == FAILURE
)
4832 case INTERFACE_INTRINSIC_OP
:
4833 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
4835 gfc_current_ns
->operator_access
[operator] =
4836 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
4840 gfc_error ("Access specification of the %s operator at %C has "
4841 "already been specified", gfc_op2string (operator));
4847 case INTERFACE_USER_OP
:
4848 uop
= gfc_get_uop (name
);
4850 if (uop
->access
== ACCESS_UNKNOWN
)
4852 uop
->access
= (st
== ST_PUBLIC
)
4853 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
4857 gfc_error ("Access specification of the .%s. operator at %C "
4858 "has already been specified", sym
->name
);
4865 if (gfc_match_char (',') == MATCH_NO
)
4869 if (gfc_match_eos () != MATCH_YES
)
4874 gfc_syntax_error (st
);
4882 gfc_match_protected (void)
4887 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4889 gfc_error ("PROTECTED at %C only allowed in specification "
4890 "part of a module");
4895 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED statement at %C")
4899 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4904 if (gfc_match_eos () == MATCH_YES
)
4909 m
= gfc_match_symbol (&sym
, 0);
4913 if (gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
)
4926 if (gfc_match_eos () == MATCH_YES
)
4928 if (gfc_match_char (',') != MATCH_YES
)
4935 gfc_error ("Syntax error in PROTECTED statement at %C");
4940 /* The PRIVATE statement is a bit weird in that it can be an attribute
4941 declaration, but also works as a standlone statement inside of a
4942 type declaration or a module. */
4945 gfc_match_private (gfc_statement
*st
)
4948 if (gfc_match ("private") != MATCH_YES
)
4951 if (gfc_current_state () != COMP_MODULE
4952 && (gfc_current_state () != COMP_DERIVED
4953 || !gfc_state_stack
->previous
4954 || gfc_state_stack
->previous
->state
!= COMP_MODULE
))
4956 gfc_error ("PRIVATE statement at %C is only allowed in the "
4957 "specification part of a module");
4961 if (gfc_current_state () == COMP_DERIVED
)
4963 if (gfc_match_eos () == MATCH_YES
)
4969 gfc_syntax_error (ST_PRIVATE
);
4973 if (gfc_match_eos () == MATCH_YES
)
4980 return access_attr_decl (ST_PRIVATE
);
4985 gfc_match_public (gfc_statement
*st
)
4988 if (gfc_match ("public") != MATCH_YES
)
4991 if (gfc_current_state () != COMP_MODULE
)
4993 gfc_error ("PUBLIC statement at %C is only allowed in the "
4994 "specification part of a module");
4998 if (gfc_match_eos () == MATCH_YES
)
5005 return access_attr_decl (ST_PUBLIC
);
5009 /* Workhorse for gfc_match_parameter. */
5018 m
= gfc_match_symbol (&sym
, 0);
5020 gfc_error ("Expected variable name at %C in PARAMETER statement");
5025 if (gfc_match_char ('=') == MATCH_NO
)
5027 gfc_error ("Expected = sign in PARAMETER statement at %C");
5031 m
= gfc_match_init_expr (&init
);
5033 gfc_error ("Expected expression at %C in PARAMETER statement");
5037 if (sym
->ts
.type
== BT_UNKNOWN
5038 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
5044 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
5045 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
5051 if (sym
->ts
.type
== BT_CHARACTER
5052 && sym
->ts
.cl
!= NULL
5053 && sym
->ts
.cl
->length
!= NULL
5054 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
5055 && init
->expr_type
== EXPR_CONSTANT
5056 && init
->ts
.type
== BT_CHARACTER
5057 && init
->ts
.kind
== 1)
5058 gfc_set_constant_character_len (
5059 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
, false);
5065 gfc_free_expr (init
);
5070 /* Match a parameter statement, with the weird syntax that these have. */
5073 gfc_match_parameter (void)
5077 if (gfc_match_char ('(') == MATCH_NO
)
5086 if (gfc_match (" )%t") == MATCH_YES
)
5089 if (gfc_match_char (',') != MATCH_YES
)
5091 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5101 /* Save statements have a special syntax. */
5104 gfc_match_save (void)
5106 char n
[GFC_MAX_SYMBOL_LEN
+1];
5111 if (gfc_match_eos () == MATCH_YES
)
5113 if (gfc_current_ns
->seen_save
)
5115 if (gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
5116 "follows previous SAVE statement")
5121 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
5125 if (gfc_current_ns
->save_all
)
5127 if (gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
5128 "blanket SAVE statement")
5137 m
= gfc_match_symbol (&sym
, 0);
5141 if (gfc_add_save (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5153 m
= gfc_match (" / %n /", &n
);
5154 if (m
== MATCH_ERROR
)
5159 c
= gfc_get_common (n
, 0);
5162 gfc_current_ns
->seen_save
= 1;
5165 if (gfc_match_eos () == MATCH_YES
)
5167 if (gfc_match_char (',') != MATCH_YES
)
5174 gfc_error ("Syntax error in SAVE statement at %C");
5180 gfc_match_value (void)
5185 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE statement at %C")
5189 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
5194 if (gfc_match_eos () == MATCH_YES
)
5199 m
= gfc_match_symbol (&sym
, 0);
5203 if (gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5216 if (gfc_match_eos () == MATCH_YES
)
5218 if (gfc_match_char (',') != MATCH_YES
)
5225 gfc_error ("Syntax error in VALUE statement at %C");
5231 gfc_match_volatile (void)
5236 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VOLATILE statement at %C")
5240 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
5245 if (gfc_match_eos () == MATCH_YES
)
5250 /* VOLATILE is special because it can be added to host-associated
5252 m
= gfc_match_symbol (&sym
, 1);
5256 if (gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
)
5269 if (gfc_match_eos () == MATCH_YES
)
5271 if (gfc_match_char (',') != MATCH_YES
)
5278 gfc_error ("Syntax error in VOLATILE statement at %C");
5283 /* Match a module procedure statement. Note that we have to modify
5284 symbols in the parent's namespace because the current one was there
5285 to receive symbols that are in an interface's formal argument list. */
5288 gfc_match_modproc (void)
5290 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5293 gfc_namespace
*module_ns
;
5295 if (gfc_state_stack
->state
!= COMP_INTERFACE
5296 || gfc_state_stack
->previous
== NULL
5297 || current_interface
.type
== INTERFACE_NAMELESS
)
5299 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5304 module_ns
= gfc_current_ns
->parent
;
5305 for (; module_ns
; module_ns
= module_ns
->parent
)
5306 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5309 if (module_ns
== NULL
)
5314 m
= gfc_match_name (name
);
5320 if (gfc_get_symbol (name
, module_ns
, &sym
))
5323 if (sym
->attr
.proc
!= PROC_MODULE
5324 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
5325 sym
->name
, NULL
) == FAILURE
)
5328 if (gfc_add_interface (sym
) == FAILURE
)
5331 sym
->attr
.mod_proc
= 1;
5333 if (gfc_match_eos () == MATCH_YES
)
5335 if (gfc_match_char (',') != MATCH_YES
)
5342 gfc_syntax_error (ST_MODULE_PROC
);
5347 /* Match the optional attribute specifiers for a type declaration.
5348 Return MATCH_ERROR if an error is encountered in one of the handled
5349 attributes (public, private, bind(c)), MATCH_NO if what's found is
5350 not a handled attribute, and MATCH_YES otherwise. TODO: More error
5351 checking on attribute conflicts needs to be done. */
5354 gfc_get_type_attr_spec (symbol_attribute
*attr
)
5356 /* See if the derived type is marked as private. */
5357 if (gfc_match (" , private") == MATCH_YES
)
5359 if (gfc_current_state () != COMP_MODULE
)
5361 gfc_error ("Derived type at %C can only be PRIVATE in the "
5362 "specification part of a module");
5366 if (gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
5369 else if (gfc_match (" , public") == MATCH_YES
)
5371 if (gfc_current_state () != COMP_MODULE
)
5373 gfc_error ("Derived type at %C can only be PUBLIC in the "
5374 "specification part of a module");
5378 if (gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
5381 else if(gfc_match(" , bind ( c )") == MATCH_YES
)
5383 /* If the type is defined to be bind(c) it then needs to make
5384 sure that all fields are interoperable. This will
5385 need to be a semantic check on the finished derived type.
5386 See 15.2.3 (lines 9-12) of F2003 draft. */
5387 if (gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0) != SUCCESS
)
5390 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
5395 /* If we get here, something matched. */
5400 /* Match the beginning of a derived type declaration. If a type name
5401 was the result of a function, then it is possible to have a symbol
5402 already to be known as a derived type yet have no components. */
5405 gfc_match_derived_decl (void)
5407 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5408 symbol_attribute attr
;
5411 match is_type_attr_spec
= MATCH_NO
;
5413 if (gfc_current_state () == COMP_DERIVED
)
5416 gfc_clear_attr (&attr
);
5420 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
);
5421 if (is_type_attr_spec
== MATCH_ERROR
)
5423 } while (is_type_attr_spec
== MATCH_YES
);
5425 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
5427 gfc_error ("Expected :: in TYPE definition at %C");
5431 m
= gfc_match (" %n%t", name
);
5435 /* Make sure the name isn't the name of an intrinsic type. The
5436 'double {precision,complex}' types don't get past the name
5437 matcher, unless they're written as a single word or in fixed
5439 if (strcmp (name
, "integer") == 0
5440 || strcmp (name
, "real") == 0
5441 || strcmp (name
, "character") == 0
5442 || strcmp (name
, "logical") == 0
5443 || strcmp (name
, "complex") == 0
5444 || strcmp (name
, "doubleprecision") == 0
5445 || strcmp (name
, "doublecomplex") == 0)
5447 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5452 if (gfc_get_symbol (name
, NULL
, &sym
))
5455 if (sym
->ts
.type
!= BT_UNKNOWN
)
5457 gfc_error ("Derived type name '%s' at %C already has a basic type "
5458 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
5462 /* The symbol may already have the derived attribute without the
5463 components. The ways this can happen is via a function
5464 definition, an INTRINSIC statement or a subtype in another
5465 derived type that is a pointer. The first part of the AND clause
5466 is true if a the symbol is not the return value of a function. */
5467 if (sym
->attr
.flavor
!= FL_DERIVED
5468 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
5471 if (sym
->components
!= NULL
)
5473 gfc_error ("Derived type definition of '%s' at %C has already been "
5474 "defined", sym
->name
);
5478 if (attr
.access
!= ACCESS_UNKNOWN
5479 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
5482 /* See if the derived type was labeled as bind(c). */
5483 if (attr
.is_bind_c
!= 0)
5484 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
5486 gfc_new_block
= sym
;
5492 /* Cray Pointees can be declared as:
5493 pointer (ipt, a (n,m,...,*))
5494 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
5495 cheat and set a constant bound of 1 for the last dimension, if this
5496 is the case. Since there is no bounds-checking for Cray Pointees,
5497 this will be okay. */
5500 gfc_mod_pointee_as (gfc_array_spec
*as
)
5502 as
->cray_pointee
= true; /* This will be useful to know later. */
5503 if (as
->type
== AS_ASSUMED_SIZE
)
5505 as
->type
= AS_EXPLICIT
;
5506 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
5507 as
->cp_was_assumed
= true;
5509 else if (as
->type
== AS_ASSUMED_SHAPE
)
5511 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
5518 /* Match the enum definition statement, here we are trying to match
5519 the first line of enum definition statement.
5520 Returns MATCH_YES if match is found. */
5523 gfc_match_enum (void)
5527 m
= gfc_match_eos ();
5531 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENUM and ENUMERATOR at %C")
5539 /* Match a variable name with an optional initializer. When this
5540 subroutine is called, a variable is expected to be parsed next.
5541 Depending on what is happening at the moment, updates either the
5542 symbol table or the current interface. */
5545 enumerator_decl (void)
5547 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5548 gfc_expr
*initializer
;
5549 gfc_array_spec
*as
= NULL
;
5557 old_locus
= gfc_current_locus
;
5559 /* When we get here, we've just matched a list of attributes and
5560 maybe a type and a double colon. The next thing we expect to see
5561 is the name of the symbol. */
5562 m
= gfc_match_name (name
);
5566 var_locus
= gfc_current_locus
;
5568 /* OK, we've successfully matched the declaration. Now put the
5569 symbol in the current namespace. If we fail to create the symbol,
5571 if (build_sym (name
, NULL
, &as
, &var_locus
) == FAILURE
)
5577 /* The double colon must be present in order to have initializers.
5578 Otherwise the statement is ambiguous with an assignment statement. */
5581 if (gfc_match_char ('=') == MATCH_YES
)
5583 m
= gfc_match_init_expr (&initializer
);
5586 gfc_error ("Expected an initialization expression at %C");
5595 /* If we do not have an initializer, the initialization value of the
5596 previous enumerator (stored in last_initializer) is incremented
5597 by 1 and is used to initialize the current enumerator. */
5598 if (initializer
== NULL
)
5599 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
5601 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
5603 gfc_error("ENUMERATOR %L not initialized with integer expression",
5606 gfc_free_enum_history ();
5610 /* Store this current initializer, for the next enumerator variable
5611 to be parsed. add_init_expr_to_sym() zeros initializer, so we
5612 use last_initializer below. */
5613 last_initializer
= initializer
;
5614 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
5616 /* Maintain enumerator history. */
5617 gfc_find_symbol (name
, NULL
, 0, &sym
);
5618 create_enum_history (sym
, last_initializer
);
5620 return (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
5623 /* Free stuff up and return. */
5624 gfc_free_expr (initializer
);
5630 /* Match the enumerator definition statement. */
5633 gfc_match_enumerator_def (void)
5638 gfc_clear_ts (¤t_ts
);
5640 m
= gfc_match (" enumerator");
5644 m
= gfc_match (" :: ");
5645 if (m
== MATCH_ERROR
)
5648 colon_seen
= (m
== MATCH_YES
);
5650 if (gfc_current_state () != COMP_ENUM
)
5652 gfc_error ("ENUM definition statement expected before %C");
5653 gfc_free_enum_history ();
5657 (¤t_ts
)->type
= BT_INTEGER
;
5658 (¤t_ts
)->kind
= gfc_c_int_kind
;
5660 gfc_clear_attr (¤t_attr
);
5661 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
5670 m
= enumerator_decl ();
5671 if (m
== MATCH_ERROR
)
5676 if (gfc_match_eos () == MATCH_YES
)
5678 if (gfc_match_char (',') != MATCH_YES
)
5682 if (gfc_current_state () == COMP_ENUM
)
5684 gfc_free_enum_history ();
5685 gfc_error ("Syntax error in ENUMERATOR definition at %C");
5690 gfc_free_array_spec (current_as
);