1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* This flag is set if an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector
;
35 /* When variables acquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts
;
42 static symbol_attribute current_attr
;
43 static gfc_array_spec
*current_as
;
44 static int colon_seen
;
46 /* Initializer of the previous enumerator. */
48 static gfc_expr
*last_initializer
;
50 /* History of all the enumerators is maintained, so that
51 kind values of all the enumerators could be updated depending
52 upon the maximum initialized value. */
54 typedef struct enumerator_history
57 gfc_expr
*initializer
;
58 struct enumerator_history
*next
;
62 /* Header of enum history chain. */
64 static enumerator_history
*enum_history
= NULL
;
66 /* Pointer of enum history node containing largest initializer. */
68 static enumerator_history
*max_enum
= NULL
;
70 /* gfc_new_block points to the symbol of a newly matched block. */
72 gfc_symbol
*gfc_new_block
;
75 /********************* DATA statement subroutines *********************/
77 /* Free a gfc_data_variable structure and everything beneath it. */
80 free_variable (gfc_data_variable
* p
)
87 gfc_free_expr (p
->expr
);
88 gfc_free_iterator (&p
->iter
, 0);
89 free_variable (p
->list
);
96 /* Free a gfc_data_value structure and everything beneath it. */
99 free_value (gfc_data_value
* p
)
106 gfc_free_expr (p
->expr
);
112 /* Free a list of gfc_data structures. */
115 gfc_free_data (gfc_data
* p
)
123 free_variable (p
->var
);
124 free_value (p
->value
);
131 static match
var_element (gfc_data_variable
*);
133 /* Match a list of variables terminated by an iterator and a right
137 var_list (gfc_data_variable
* parent
)
139 gfc_data_variable
*tail
, var
;
142 m
= var_element (&var
);
143 if (m
== MATCH_ERROR
)
148 tail
= gfc_get_data_variable ();
155 if (gfc_match_char (',') != MATCH_YES
)
158 m
= gfc_match_iterator (&parent
->iter
, 1);
161 if (m
== MATCH_ERROR
)
164 m
= var_element (&var
);
165 if (m
== MATCH_ERROR
)
170 tail
->next
= gfc_get_data_variable ();
176 if (gfc_match_char (')') != MATCH_YES
)
181 gfc_syntax_error (ST_DATA
);
186 /* Match a single element in a data variable list, which can be a
187 variable-iterator list. */
190 var_element (gfc_data_variable
* new)
195 memset (new, 0, sizeof (gfc_data_variable
));
197 if (gfc_match_char ('(') == MATCH_YES
)
198 return var_list (new);
200 m
= gfc_match_variable (&new->expr
, 0);
204 sym
= new->expr
->symtree
->n
.sym
;
206 if (!sym
->attr
.function
&& gfc_current_ns
->parent
&& gfc_current_ns
->parent
== sym
->ns
)
208 gfc_error ("Host associated variable '%s' may not be in the DATA "
209 "statement at %C.", sym
->name
);
213 if (gfc_current_state () != COMP_BLOCK_DATA
214 && sym
->attr
.in_common
215 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
216 "common block variable '%s' in DATA statement at %C",
217 sym
->name
) == FAILURE
)
220 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
227 /* Match the top-level list of data variables. */
230 top_var_list (gfc_data
* d
)
232 gfc_data_variable var
, *tail
, *new;
239 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
245 new = gfc_get_data_variable ();
255 if (gfc_match_char ('/') == MATCH_YES
)
257 if (gfc_match_char (',') != MATCH_YES
)
264 gfc_syntax_error (ST_DATA
);
270 match_data_constant (gfc_expr
** result
)
272 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
277 m
= gfc_match_literal_constant (&expr
, 1);
284 if (m
== MATCH_ERROR
)
287 m
= gfc_match_null (result
);
291 m
= gfc_match_name (name
);
295 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
299 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
301 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
305 else if (sym
->attr
.flavor
== FL_DERIVED
)
306 return gfc_match_structure_constructor (sym
, result
);
308 *result
= gfc_copy_expr (sym
->value
);
313 /* Match a list of values in a DATA statement. The leading '/' has
314 already been seen at this point. */
317 top_val_list (gfc_data
* data
)
319 gfc_data_value
*new, *tail
;
328 m
= match_data_constant (&expr
);
331 if (m
== MATCH_ERROR
)
334 new = gfc_get_data_value ();
343 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
351 msg
= gfc_extract_int (expr
, &tmp
);
352 gfc_free_expr (expr
);
360 m
= match_data_constant (&tail
->expr
);
363 if (m
== MATCH_ERROR
)
367 if (gfc_match_char ('/') == MATCH_YES
)
369 if (gfc_match_char (',') == MATCH_NO
)
376 gfc_syntax_error (ST_DATA
);
381 /* Matches an old style initialization. */
384 match_old_style_init (const char *name
)
391 /* Set up data structure to hold initializers. */
392 gfc_find_sym_tree (name
, NULL
, 0, &st
);
395 newdata
= gfc_get_data ();
396 newdata
->var
= gfc_get_data_variable ();
397 newdata
->var
->expr
= gfc_get_variable_expr (st
);
398 newdata
->where
= gfc_current_locus
;
400 /* Match initial value list. This also eats the terminal
402 m
= top_val_list (newdata
);
411 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
416 /* Mark the variable as having appeared in a data statement. */
417 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
423 /* Chain in namespace list of DATA initializers. */
424 newdata
->next
= gfc_current_ns
->data
;
425 gfc_current_ns
->data
= newdata
;
430 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
431 we are matching a DATA statement and are therefore issuing an error
432 if we encounter something unexpected, if not, we're trying to match
433 an old-style initialization expression of the form INTEGER I /2/. */
436 gfc_match_data (void)
443 new = gfc_get_data ();
444 new->where
= gfc_current_locus
;
446 m
= top_var_list (new);
450 m
= top_val_list (new);
454 new->next
= gfc_current_ns
->data
;
455 gfc_current_ns
->data
= new;
457 if (gfc_match_eos () == MATCH_YES
)
460 gfc_match_char (','); /* Optional comma */
465 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
477 /************************ Declaration statements *********************/
479 /* Match an intent specification. Since this can only happen after an
480 INTENT word, a legal intent-spec must follow. */
483 match_intent_spec (void)
486 if (gfc_match (" ( in out )") == MATCH_YES
)
488 if (gfc_match (" ( in )") == MATCH_YES
)
490 if (gfc_match (" ( out )") == MATCH_YES
)
493 gfc_error ("Bad INTENT specification at %C");
494 return INTENT_UNKNOWN
;
498 /* Matches a character length specification, which is either a
499 specification expression or a '*'. */
502 char_len_param_value (gfc_expr
** expr
)
505 if (gfc_match_char ('*') == MATCH_YES
)
511 return gfc_match_expr (expr
);
515 /* A character length is a '*' followed by a literal integer or a
516 char_len_param_value in parenthesis. */
519 match_char_length (gfc_expr
** expr
)
524 m
= gfc_match_char ('*');
528 m
= gfc_match_small_literal_int (&length
, NULL
);
529 if (m
== MATCH_ERROR
)
534 *expr
= gfc_int_expr (length
);
538 if (gfc_match_char ('(') == MATCH_NO
)
541 m
= char_len_param_value (expr
);
542 if (m
== MATCH_ERROR
)
547 if (gfc_match_char (')') == MATCH_NO
)
549 gfc_free_expr (*expr
);
557 gfc_error ("Syntax error in character length specification at %C");
562 /* Special subroutine for finding a symbol. Check if the name is found
563 in the current name space. If not, and we're compiling a function or
564 subroutine and the parent compilation unit is an interface, then check
565 to see if the name we've been given is the name of the interface
566 (located in another namespace). */
569 find_special (const char *name
, gfc_symbol
** result
)
574 i
= gfc_get_symbol (name
, NULL
, result
);
578 if (gfc_current_state () != COMP_SUBROUTINE
579 && gfc_current_state () != COMP_FUNCTION
)
582 s
= gfc_state_stack
->previous
;
586 if (s
->state
!= COMP_INTERFACE
)
589 goto end
; /* Nameless interface */
591 if (strcmp (name
, s
->sym
->name
) == 0)
602 /* Special subroutine for getting a symbol node associated with a
603 procedure name, used in SUBROUTINE and FUNCTION statements. The
604 symbol is created in the parent using with symtree node in the
605 child unit pointing to the symbol. If the current namespace has no
606 parent, then the symbol is just created in the current unit. */
609 get_proc_name (const char *name
, gfc_symbol
** result
,
610 bool module_fcn_entry
)
616 /* Module functions have to be left in their own namespace because
617 they have potentially (almost certainly!) already been referenced.
618 In this sense, they are rather like external functions. This is
619 fixed up in resolve.c(resolve_entries), where the symbol name-
620 space is set to point to the master function, so that the fake
621 result mechanism can work. */
622 if (module_fcn_entry
)
623 rc
= gfc_get_symbol (name
, NULL
, result
);
625 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
629 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
631 /* Trap another encompassed procedure with the same name. All
632 these conditions are necessary to avoid picking up an entry
633 whose name clashes with that of the encompassing procedure;
634 this is handled using gsymbols to register unique,globally
636 if (sym
->attr
.flavor
!= 0
637 && sym
->attr
.proc
!= 0
638 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
639 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
640 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
641 name
, &sym
->declared_at
);
643 /* Trap declarations of attributes in encompassing scope. The
644 signature for this is that ts.kind is set. Legitimate
645 references only set ts.type. */
646 if (sym
->ts
.kind
!= 0
647 && !sym
->attr
.implicit_type
648 && sym
->attr
.proc
== 0
649 && gfc_current_ns
->parent
!= NULL
650 && sym
->attr
.access
== 0
651 && !module_fcn_entry
)
652 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
653 " and must not have attributes declared at %L",
654 name
, &sym
->declared_at
);
657 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
660 /* Module function entries will already have a symtree in
661 the current namespace but will need one at module level. */
662 if (module_fcn_entry
)
663 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
665 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
670 /* See if the procedure should be a module procedure */
672 if (((sym
->ns
->proc_name
!= NULL
673 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
674 && sym
->attr
.proc
!= PROC_MODULE
) || module_fcn_entry
)
675 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
676 sym
->name
, NULL
) == FAILURE
)
683 /* Function called by variable_decl() that adds a name to the symbol
687 build_sym (const char *name
, gfc_charlen
* cl
,
688 gfc_array_spec
** as
, locus
* var_locus
)
690 symbol_attribute attr
;
693 /* if (find_special (name, &sym)) */
694 if (gfc_get_symbol (name
, NULL
, &sym
))
697 /* Start updating the symbol table. Add basic type attribute
699 if (current_ts
.type
!= BT_UNKNOWN
700 &&(sym
->attr
.implicit_type
== 0
701 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
702 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
705 if (sym
->ts
.type
== BT_CHARACTER
)
708 /* Add dimension attribute if present. */
709 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
713 /* Add attribute to symbol. The copy is so that we can reset the
714 dimension attribute. */
718 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
724 /* Set character constant to the given length. The constant will be padded or
728 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
733 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
734 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
736 slen
= expr
->value
.character
.length
;
739 s
= gfc_getmem (len
);
740 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
742 memset (&s
[slen
], ' ', len
- slen
);
743 gfc_free (expr
->value
.character
.string
);
744 expr
->value
.character
.string
= s
;
745 expr
->value
.character
.length
= len
;
750 /* Function to create and update the enumerator history
751 using the information passed as arguments.
752 Pointer "max_enum" is also updated, to point to
753 enum history node containing largest initializer.
755 SYM points to the symbol node of enumerator.
756 INIT points to its enumerator value. */
759 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
761 enumerator_history
*new_enum_history
;
762 gcc_assert (sym
!= NULL
&& init
!= NULL
);
764 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
766 new_enum_history
->sym
= sym
;
767 new_enum_history
->initializer
= init
;
768 new_enum_history
->next
= NULL
;
770 if (enum_history
== NULL
)
772 enum_history
= new_enum_history
;
773 max_enum
= enum_history
;
777 new_enum_history
->next
= enum_history
;
778 enum_history
= new_enum_history
;
780 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
781 new_enum_history
->initializer
->value
.integer
) < 0)
782 max_enum
= new_enum_history
;
787 /* Function to free enum kind history. */
790 gfc_free_enum_history(void)
792 enumerator_history
*current
= enum_history
;
793 enumerator_history
*next
;
795 while (current
!= NULL
)
797 next
= current
->next
;
806 /* Function called by variable_decl() that adds an initialization
807 expression to a symbol. */
810 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
813 symbol_attribute attr
;
818 if (find_special (name
, &sym
))
823 /* If this symbol is confirming an implicit parameter type,
824 then an initialization expression is not allowed. */
825 if (attr
.flavor
== FL_PARAMETER
826 && sym
->value
!= NULL
829 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
838 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
845 /* An initializer is required for PARAMETER declarations. */
846 if (attr
.flavor
== FL_PARAMETER
)
848 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
854 /* If a variable appears in a DATA block, it cannot have an
859 ("Variable '%s' at %C with an initializer already appears "
860 "in a DATA statement", sym
->name
);
864 /* Check if the assignment can happen. This has to be put off
865 until later for a derived type variable. */
866 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
867 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
870 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
872 /* Update symbol character length according initializer. */
873 if (sym
->ts
.cl
->length
== NULL
)
875 /* If there are multiple CHARACTER variables declared on
876 the same line, we don't want them to share the same
878 sym
->ts
.cl
= gfc_get_charlen ();
879 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
880 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
882 if (sym
->attr
.flavor
== FL_PARAMETER
883 && init
->expr_type
== EXPR_ARRAY
)
884 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
886 /* Update initializer character length according symbol. */
887 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
889 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
892 if (init
->expr_type
== EXPR_CONSTANT
)
893 gfc_set_constant_character_len (len
, init
);
894 else if (init
->expr_type
== EXPR_ARRAY
)
896 gfc_free_expr (init
->ts
.cl
->length
);
897 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
898 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
899 gfc_set_constant_character_len (len
, p
->expr
);
904 /* Add initializer. Make sure we keep the ranks sane. */
905 if (sym
->attr
.dimension
&& init
->rank
== 0)
906 init
->rank
= sym
->as
->rank
;
912 /* Maintain enumerator history. */
913 if (gfc_current_state () == COMP_ENUM
)
914 create_enum_history (sym
, init
);
920 /* Function called by variable_decl() that adds a name to a structure
924 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
925 gfc_array_spec
** as
)
929 /* If the current symbol is of the same derived type that we're
930 constructing, it must have the pointer attribute. */
931 if (current_ts
.type
== BT_DERIVED
932 && current_ts
.derived
== gfc_current_block ()
933 && current_attr
.pointer
== 0)
935 gfc_error ("Component at %C must have the POINTER attribute");
939 if (gfc_current_block ()->attr
.pointer
942 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
944 gfc_error ("Array component of structure at %C must have explicit "
945 "or deferred shape");
950 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
955 gfc_set_component_attr (c
, ¤t_attr
);
957 c
->initializer
= *init
;
965 /* Check array components. */
970 gfc_error ("Allocatable component at %C must be an array");
979 if (c
->as
->type
!= AS_DEFERRED
)
981 gfc_error ("Pointer array component of structure at %C must have a "
986 else if (c
->allocatable
)
988 if (c
->as
->type
!= AS_DEFERRED
)
990 gfc_error ("Allocatable component of structure at %C must have a "
997 if (c
->as
->type
!= AS_EXPLICIT
)
1000 ("Array component of structure at %C must have an explicit "
1010 /* Match a 'NULL()', and possibly take care of some side effects. */
1013 gfc_match_null (gfc_expr
** result
)
1019 m
= gfc_match (" null ( )");
1023 /* The NULL symbol now has to be/become an intrinsic function. */
1024 if (gfc_get_symbol ("null", NULL
, &sym
))
1026 gfc_error ("NULL() initialization at %C is ambiguous");
1030 gfc_intrinsic_symbol (sym
);
1032 if (sym
->attr
.proc
!= PROC_INTRINSIC
1033 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1034 sym
->name
, NULL
) == FAILURE
1035 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1038 e
= gfc_get_expr ();
1039 e
->where
= gfc_current_locus
;
1040 e
->expr_type
= EXPR_NULL
;
1041 e
->ts
.type
= BT_UNKNOWN
;
1049 /* Match a variable name with an optional initializer. When this
1050 subroutine is called, a variable is expected to be parsed next.
1051 Depending on what is happening at the moment, updates either the
1052 symbol table or the current interface. */
1055 variable_decl (int elem
)
1057 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1058 gfc_expr
*initializer
, *char_len
;
1060 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1071 old_locus
= gfc_current_locus
;
1073 /* When we get here, we've just matched a list of attributes and
1074 maybe a type and a double colon. The next thing we expect to see
1075 is the name of the symbol. */
1076 m
= gfc_match_name (name
);
1080 var_locus
= gfc_current_locus
;
1082 /* Now we could see the optional array spec. or character length. */
1083 m
= gfc_match_array_spec (&as
);
1084 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1085 cp_as
= gfc_copy_array_spec (as
);
1086 else if (m
== MATCH_ERROR
)
1090 as
= gfc_copy_array_spec (current_as
);
1091 else if (gfc_current_state () == COMP_ENUM
)
1093 gfc_error ("Enumerator cannot be array at %C");
1094 gfc_free_enum_history ();
1103 if (current_ts
.type
== BT_CHARACTER
)
1105 switch (match_char_length (&char_len
))
1108 cl
= gfc_get_charlen ();
1109 cl
->next
= gfc_current_ns
->cl_list
;
1110 gfc_current_ns
->cl_list
= cl
;
1112 cl
->length
= char_len
;
1115 /* Non-constant lengths need to be copied after the first
1118 if (elem
> 1 && current_ts
.cl
->length
1119 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1121 cl
= gfc_get_charlen ();
1122 cl
->next
= gfc_current_ns
->cl_list
;
1123 gfc_current_ns
->cl_list
= cl
;
1124 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1136 /* If this symbol has already shown up in a Cray Pointer declaration,
1137 then we want to set the type & bail out. */
1138 if (gfc_option
.flag_cray_pointer
)
1140 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1141 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1143 sym
->ts
.type
= current_ts
.type
;
1144 sym
->ts
.kind
= current_ts
.kind
;
1146 sym
->ts
.derived
= current_ts
.derived
;
1149 /* Check to see if we have an array specification. */
1152 if (sym
->as
!= NULL
)
1154 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1155 gfc_free_array_spec (cp_as
);
1161 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1162 gfc_internal_error ("Couldn't set pointee array spec.");
1164 /* Fix the array spec. */
1165 m
= gfc_mod_pointee_as (sym
->as
);
1166 if (m
== MATCH_ERROR
)
1174 gfc_free_array_spec (cp_as
);
1179 /* OK, we've successfully matched the declaration. Now put the
1180 symbol in the current namespace, because it might be used in the
1181 optional initialization expression for this symbol, e.g. this is
1184 integer, parameter :: i = huge(i)
1186 This is only true for parameters or variables of a basic type.
1187 For components of derived types, it is not true, so we don't
1188 create a symbol for those yet. If we fail to create the symbol,
1190 if (gfc_current_state () != COMP_DERIVED
1191 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1197 /* An interface body specifies all of the procedure's characteristics and these
1198 shall be consistent with those specified in the procedure definition, except
1199 that the interface may specify a procedure that is not pure if the procedure
1200 is defined to be pure(12.3.2). */
1201 if (current_ts
.type
== BT_DERIVED
1202 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1203 && current_ts
.derived
->ns
!= gfc_current_ns
)
1205 gfc_error ("the type of '%s' at %C has not been declared within the "
1211 /* In functions that have a RESULT variable defined, the function
1212 name always refers to function calls. Therefore, the name is
1213 not allowed to appear in specification statements. */
1214 if (gfc_current_state () == COMP_FUNCTION
1215 && gfc_current_block () != NULL
1216 && gfc_current_block ()->result
!= NULL
1217 && gfc_current_block ()->result
!= gfc_current_block ()
1218 && strcmp (gfc_current_block ()->name
, name
) == 0)
1220 gfc_error ("Function name '%s' not allowed at %C", name
);
1225 /* We allow old-style initializations of the form
1226 integer i /2/, j(4) /3*3, 1/
1227 (if no colon has been seen). These are different from data
1228 statements in that initializers are only allowed to apply to the
1229 variable immediately preceding, i.e.
1231 is not allowed. Therefore we have to do some work manually, that
1232 could otherwise be left to the matchers for DATA statements. */
1234 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1236 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1237 "initialization at %C") == FAILURE
)
1240 return match_old_style_init (name
);
1243 /* The double colon must be present in order to have initializers.
1244 Otherwise the statement is ambiguous with an assignment statement. */
1247 if (gfc_match (" =>") == MATCH_YES
)
1250 if (!current_attr
.pointer
)
1252 gfc_error ("Initialization at %C isn't for a pointer variable");
1257 m
= gfc_match_null (&initializer
);
1260 gfc_error ("Pointer initialization requires a NULL() at %C");
1264 if (gfc_pure (NULL
))
1267 ("Initialization of pointer at %C is not allowed in a "
1276 else if (gfc_match_char ('=') == MATCH_YES
)
1278 if (current_attr
.pointer
)
1281 ("Pointer initialization at %C requires '=>', not '='");
1286 m
= gfc_match_init_expr (&initializer
);
1289 gfc_error ("Expected an initialization expression at %C");
1293 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1296 ("Initialization of variable at %C is not allowed in a "
1306 if (initializer
!= NULL
&& current_attr
.allocatable
1307 && gfc_current_state () == COMP_DERIVED
)
1309 gfc_error ("Initialization of allocatable component at %C is not allowed");
1314 /* Check if we are parsing an enumeration and if the current enumerator
1315 variable has an initializer or not. If it does not have an
1316 initializer, the initialization value of the previous enumerator
1317 (stored in last_initializer) is incremented by 1 and is used to
1318 initialize the current enumerator. */
1319 if (gfc_current_state () == COMP_ENUM
)
1321 if (initializer
== NULL
)
1322 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1324 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1326 gfc_error("ENUMERATOR %L not initialized with integer expression",
1329 gfc_free_enum_history ();
1333 /* Store this current initializer, for the next enumerator
1334 variable to be parsed. */
1335 last_initializer
= initializer
;
1338 /* Add the initializer. Note that it is fine if initializer is
1339 NULL here, because we sometimes also need to check if a
1340 declaration *must* have an initialization expression. */
1341 if (gfc_current_state () != COMP_DERIVED
)
1342 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1345 if (current_ts
.type
== BT_DERIVED
1346 && !current_attr
.pointer
1348 initializer
= gfc_default_initializer (¤t_ts
);
1349 t
= build_struct (name
, cl
, &initializer
, &as
);
1352 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1355 /* Free stuff up and return. */
1356 gfc_free_expr (initializer
);
1357 gfc_free_array_spec (as
);
1363 /* Match an extended-f77 kind specification. */
1366 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1371 if (gfc_match_char ('*') != MATCH_YES
)
1374 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1378 original_kind
= ts
->kind
;
1380 /* Massage the kind numbers for complex types. */
1381 if (ts
->type
== BT_COMPLEX
)
1385 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1386 gfc_basic_typename (ts
->type
), original_kind
);
1392 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1394 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1395 gfc_basic_typename (ts
->type
), original_kind
);
1399 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1400 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1407 /* Match a kind specification. Since kinds are generally optional, we
1408 usually return MATCH_NO if something goes wrong. If a "kind="
1409 string is found, then we know we have an error. */
1412 gfc_match_kind_spec (gfc_typespec
* ts
)
1422 where
= gfc_current_locus
;
1424 if (gfc_match_char ('(') == MATCH_NO
)
1427 /* Also gobbles optional text. */
1428 if (gfc_match (" kind = ") == MATCH_YES
)
1431 n
= gfc_match_init_expr (&e
);
1433 gfc_error ("Expected initialization expression at %C");
1439 gfc_error ("Expected scalar initialization expression at %C");
1444 msg
= gfc_extract_int (e
, &ts
->kind
);
1455 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1457 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1458 gfc_basic_typename (ts
->type
));
1464 if (gfc_match_char (')') != MATCH_YES
)
1466 gfc_error ("Missing right paren at %C");
1474 gfc_current_locus
= where
;
1479 /* Match the various kind/length specifications in a CHARACTER
1480 declaration. We don't return MATCH_NO. */
1483 match_char_spec (gfc_typespec
* ts
)
1485 int i
, kind
, seen_length
;
1490 kind
= gfc_default_character_kind
;
1494 /* Try the old-style specification first. */
1495 old_char_selector
= 0;
1497 m
= match_char_length (&len
);
1501 old_char_selector
= 1;
1506 m
= gfc_match_char ('(');
1509 m
= MATCH_YES
; /* character without length is a single char */
1513 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1514 if (gfc_match (" kind =") == MATCH_YES
)
1516 m
= gfc_match_small_int (&kind
);
1517 if (m
== MATCH_ERROR
)
1522 if (gfc_match (" , len =") == MATCH_NO
)
1525 m
= char_len_param_value (&len
);
1528 if (m
== MATCH_ERROR
)
1535 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1536 if (gfc_match (" len =") == MATCH_YES
)
1538 m
= char_len_param_value (&len
);
1541 if (m
== MATCH_ERROR
)
1545 if (gfc_match_char (')') == MATCH_YES
)
1548 if (gfc_match (" , kind =") != MATCH_YES
)
1551 gfc_match_small_int (&kind
);
1553 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1555 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1562 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1563 m
= char_len_param_value (&len
);
1566 if (m
== MATCH_ERROR
)
1570 m
= gfc_match_char (')');
1574 if (gfc_match_char (',') != MATCH_YES
)
1577 gfc_match (" kind ="); /* Gobble optional text */
1579 m
= gfc_match_small_int (&kind
);
1580 if (m
== MATCH_ERROR
)
1586 /* Require a right-paren at this point. */
1587 m
= gfc_match_char (')');
1592 gfc_error ("Syntax error in CHARACTER declaration at %C");
1596 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1598 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1604 gfc_free_expr (len
);
1608 /* Do some final massaging of the length values. */
1609 cl
= gfc_get_charlen ();
1610 cl
->next
= gfc_current_ns
->cl_list
;
1611 gfc_current_ns
->cl_list
= cl
;
1613 if (seen_length
== 0)
1614 cl
->length
= gfc_int_expr (1);
1617 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1621 gfc_free_expr (len
);
1622 cl
->length
= gfc_int_expr (0);
1633 /* Matches a type specification. If successful, sets the ts structure
1634 to the matched specification. This is necessary for FUNCTION and
1635 IMPLICIT statements.
1637 If implicit_flag is nonzero, then we don't check for the optional
1638 kind specification. Not doing so is needed for matching an IMPLICIT
1639 statement correctly. */
1642 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1644 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1651 if (gfc_match (" byte") == MATCH_YES
)
1653 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1657 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1659 gfc_error ("BYTE type used at %C "
1660 "is not available on the target machine");
1664 ts
->type
= BT_INTEGER
;
1669 if (gfc_match (" integer") == MATCH_YES
)
1671 ts
->type
= BT_INTEGER
;
1672 ts
->kind
= gfc_default_integer_kind
;
1676 if (gfc_match (" character") == MATCH_YES
)
1678 ts
->type
= BT_CHARACTER
;
1679 if (implicit_flag
== 0)
1680 return match_char_spec (ts
);
1685 if (gfc_match (" real") == MATCH_YES
)
1688 ts
->kind
= gfc_default_real_kind
;
1692 if (gfc_match (" double precision") == MATCH_YES
)
1695 ts
->kind
= gfc_default_double_kind
;
1699 if (gfc_match (" complex") == MATCH_YES
)
1701 ts
->type
= BT_COMPLEX
;
1702 ts
->kind
= gfc_default_complex_kind
;
1706 if (gfc_match (" double complex") == MATCH_YES
)
1708 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1709 "conform to the Fortran 95 standard") == FAILURE
)
1712 ts
->type
= BT_COMPLEX
;
1713 ts
->kind
= gfc_default_double_kind
;
1717 if (gfc_match (" logical") == MATCH_YES
)
1719 ts
->type
= BT_LOGICAL
;
1720 ts
->kind
= gfc_default_logical_kind
;
1724 m
= gfc_match (" type ( %n )", name
);
1728 /* Search for the name but allow the components to be defined later. */
1729 if (gfc_get_ha_symbol (name
, &sym
))
1731 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1735 if (sym
->attr
.flavor
!= FL_DERIVED
1736 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1739 ts
->type
= BT_DERIVED
;
1746 /* For all types except double, derived and character, look for an
1747 optional kind specifier. MATCH_NO is actually OK at this point. */
1748 if (implicit_flag
== 1)
1751 if (gfc_current_form
== FORM_FREE
)
1753 c
= gfc_peek_char();
1754 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1755 && c
!= ':' && c
!= ',')
1759 m
= gfc_match_kind_spec (ts
);
1760 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1761 m
= gfc_match_old_kind_spec (ts
);
1764 m
= MATCH_YES
; /* No kind specifier found. */
1770 /* Match an IMPLICIT NONE statement. Actually, this statement is
1771 already matched in parse.c, or we would not end up here in the
1772 first place. So the only thing we need to check, is if there is
1773 trailing garbage. If not, the match is successful. */
1776 gfc_match_implicit_none (void)
1779 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1783 /* Match the letter range(s) of an IMPLICIT statement. */
1786 match_implicit_range (void)
1788 int c
, c1
, c2
, inner
;
1791 cur_loc
= gfc_current_locus
;
1793 gfc_gobble_whitespace ();
1794 c
= gfc_next_char ();
1797 gfc_error ("Missing character range in IMPLICIT at %C");
1804 gfc_gobble_whitespace ();
1805 c1
= gfc_next_char ();
1809 gfc_gobble_whitespace ();
1810 c
= gfc_next_char ();
1815 inner
= 0; /* Fall through */
1822 gfc_gobble_whitespace ();
1823 c2
= gfc_next_char ();
1827 gfc_gobble_whitespace ();
1828 c
= gfc_next_char ();
1830 if ((c
!= ',') && (c
!= ')'))
1843 gfc_error ("Letters must be in alphabetic order in "
1844 "IMPLICIT statement at %C");
1848 /* See if we can add the newly matched range to the pending
1849 implicits from this IMPLICIT statement. We do not check for
1850 conflicts with whatever earlier IMPLICIT statements may have
1851 set. This is done when we've successfully finished matching
1853 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1860 gfc_syntax_error (ST_IMPLICIT
);
1862 gfc_current_locus
= cur_loc
;
1867 /* Match an IMPLICIT statement, storing the types for
1868 gfc_set_implicit() if the statement is accepted by the parser.
1869 There is a strange looking, but legal syntactic construction
1870 possible. It looks like:
1872 IMPLICIT INTEGER (a-b) (c-d)
1874 This is legal if "a-b" is a constant expression that happens to
1875 equal one of the legal kinds for integers. The real problem
1876 happens with an implicit specification that looks like:
1878 IMPLICIT INTEGER (a-b)
1880 In this case, a typespec matcher that is "greedy" (as most of the
1881 matchers are) gobbles the character range as a kindspec, leaving
1882 nothing left. We therefore have to go a bit more slowly in the
1883 matching process by inhibiting the kindspec checking during
1884 typespec matching and checking for a kind later. */
1887 gfc_match_implicit (void)
1894 /* We don't allow empty implicit statements. */
1895 if (gfc_match_eos () == MATCH_YES
)
1897 gfc_error ("Empty IMPLICIT statement at %C");
1903 /* First cleanup. */
1904 gfc_clear_new_implicit ();
1906 /* A basic type is mandatory here. */
1907 m
= match_type_spec (&ts
, 1);
1908 if (m
== MATCH_ERROR
)
1913 cur_loc
= gfc_current_locus
;
1914 m
= match_implicit_range ();
1918 /* We may have <TYPE> (<RANGE>). */
1919 gfc_gobble_whitespace ();
1920 c
= gfc_next_char ();
1921 if ((c
== '\n') || (c
== ','))
1923 /* Check for CHARACTER with no length parameter. */
1924 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1926 ts
.kind
= gfc_default_character_kind
;
1927 ts
.cl
= gfc_get_charlen ();
1928 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1929 gfc_current_ns
->cl_list
= ts
.cl
;
1930 ts
.cl
->length
= gfc_int_expr (1);
1933 /* Record the Successful match. */
1934 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1939 gfc_current_locus
= cur_loc
;
1942 /* Discard the (incorrectly) matched range. */
1943 gfc_clear_new_implicit ();
1945 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1946 if (ts
.type
== BT_CHARACTER
)
1947 m
= match_char_spec (&ts
);
1950 m
= gfc_match_kind_spec (&ts
);
1953 m
= gfc_match_old_kind_spec (&ts
);
1954 if (m
== MATCH_ERROR
)
1960 if (m
== MATCH_ERROR
)
1963 m
= match_implicit_range ();
1964 if (m
== MATCH_ERROR
)
1969 gfc_gobble_whitespace ();
1970 c
= gfc_next_char ();
1971 if ((c
!= '\n') && (c
!= ','))
1974 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1982 gfc_syntax_error (ST_IMPLICIT
);
1989 /* Matches an attribute specification including array specs. If
1990 successful, leaves the variables current_attr and current_as
1991 holding the specification. Also sets the colon_seen variable for
1992 later use by matchers associated with initializations.
1994 This subroutine is a little tricky in the sense that we don't know
1995 if we really have an attr-spec until we hit the double colon.
1996 Until that time, we can only return MATCH_NO. This forces us to
1997 check for duplicate specification at this level. */
2000 match_attr_spec (void)
2003 /* Modifiers that can exist in a type statement. */
2005 { GFC_DECL_BEGIN
= 0,
2006 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2007 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2008 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
2009 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
2010 GFC_DECL_END
/* Sentinel */
2014 /* GFC_DECL_END is the sentinel, index starts at 0. */
2015 #define NUM_DECL GFC_DECL_END
2017 static mstring decls
[] = {
2018 minit (", allocatable", DECL_ALLOCATABLE
),
2019 minit (", dimension", DECL_DIMENSION
),
2020 minit (", external", DECL_EXTERNAL
),
2021 minit (", intent ( in )", DECL_IN
),
2022 minit (", intent ( out )", DECL_OUT
),
2023 minit (", intent ( in out )", DECL_INOUT
),
2024 minit (", intrinsic", DECL_INTRINSIC
),
2025 minit (", optional", DECL_OPTIONAL
),
2026 minit (", parameter", DECL_PARAMETER
),
2027 minit (", pointer", DECL_POINTER
),
2028 minit (", private", DECL_PRIVATE
),
2029 minit (", public", DECL_PUBLIC
),
2030 minit (", save", DECL_SAVE
),
2031 minit (", target", DECL_TARGET
),
2032 minit ("::", DECL_COLON
),
2033 minit (NULL
, DECL_NONE
)
2036 locus start
, seen_at
[NUM_DECL
];
2043 gfc_clear_attr (¤t_attr
);
2044 start
= gfc_current_locus
;
2049 /* See if we get all of the keywords up to the final double colon. */
2050 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2055 d
= (decl_types
) gfc_match_strings (decls
);
2056 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2059 if (gfc_current_state () == COMP_ENUM
)
2061 gfc_error ("Enumerator cannot have attributes %C");
2066 seen_at
[d
] = gfc_current_locus
;
2068 if (d
== DECL_DIMENSION
)
2070 m
= gfc_match_array_spec (¤t_as
);
2074 gfc_error ("Missing dimension specification at %C");
2078 if (m
== MATCH_ERROR
)
2083 /* If we are parsing an enumeration and have ensured that no other
2084 attributes are present we can now set the parameter attribute. */
2085 if (gfc_current_state () == COMP_ENUM
)
2087 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
2095 /* No double colon, so assume that we've been looking at something
2096 else the whole time. */
2103 /* Since we've seen a double colon, we have to be looking at an
2104 attr-spec. This means that we can now issue errors. */
2105 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2110 case DECL_ALLOCATABLE
:
2111 attr
= "ALLOCATABLE";
2113 case DECL_DIMENSION
:
2120 attr
= "INTENT (IN)";
2123 attr
= "INTENT (OUT)";
2126 attr
= "INTENT (IN OUT)";
2128 case DECL_INTRINSIC
:
2134 case DECL_PARAMETER
:
2153 attr
= NULL
; /* This shouldn't happen */
2156 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2161 /* Now that we've dealt with duplicate attributes, add the attributes
2162 to the current attribute. */
2163 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2168 if (gfc_current_state () == COMP_DERIVED
2169 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2170 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2172 if (d
== DECL_ALLOCATABLE
)
2174 if (gfc_notify_std (GFC_STD_F2003
,
2175 "In the selected standard, the ALLOCATABLE "
2176 "attribute at %C is not allowed in a TYPE "
2177 "definition") == FAILURE
)
2185 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2192 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2193 && gfc_current_state () != COMP_MODULE
)
2195 if (d
== DECL_PRIVATE
)
2200 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2208 case DECL_ALLOCATABLE
:
2209 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2212 case DECL_DIMENSION
:
2213 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2217 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2221 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2225 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2229 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2232 case DECL_INTRINSIC
:
2233 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2237 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2240 case DECL_PARAMETER
:
2241 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2245 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2249 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2254 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2259 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2263 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2267 gfc_internal_error ("match_attr_spec(): Bad attribute");
2281 gfc_current_locus
= start
;
2282 gfc_free_array_spec (current_as
);
2288 /* Match a data declaration statement. */
2291 gfc_match_data_decl (void)
2297 m
= match_type_spec (¤t_ts
, 0);
2301 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2303 sym
= gfc_use_derived (current_ts
.derived
);
2311 current_ts
.derived
= sym
;
2314 m
= match_attr_spec ();
2315 if (m
== MATCH_ERROR
)
2321 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2324 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2327 gfc_find_symbol (current_ts
.derived
->name
,
2328 current_ts
.derived
->ns
->parent
, 1, &sym
);
2330 /* Any symbol that we find had better be a type definition
2331 which has its components defined. */
2332 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2333 && current_ts
.derived
->components
!= NULL
)
2336 /* Now we have an error, which we signal, and then fix up
2337 because the knock-on is plain and simple confusing. */
2338 gfc_error_now ("Derived type at %C has not been previously defined "
2339 "and so cannot appear in a derived type definition.");
2340 current_attr
.pointer
= 1;
2345 /* If we have an old-style character declaration, and no new-style
2346 attribute specifications, then there a comma is optional between
2347 the type specification and the variable list. */
2348 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2349 gfc_match_char (',');
2351 /* Give the types/attributes to symbols that follow. Give the element
2352 a number so that repeat character length expressions can be copied. */
2356 m
= variable_decl (elem
++);
2357 if (m
== MATCH_ERROR
)
2362 if (gfc_match_eos () == MATCH_YES
)
2364 if (gfc_match_char (',') != MATCH_YES
)
2368 gfc_error ("Syntax error in data declaration at %C");
2372 gfc_free_array_spec (current_as
);
2378 /* Match a prefix associated with a function or subroutine
2379 declaration. If the typespec pointer is nonnull, then a typespec
2380 can be matched. Note that if nothing matches, MATCH_YES is
2381 returned (the null string was matched). */
2384 match_prefix (gfc_typespec
* ts
)
2388 gfc_clear_attr (¤t_attr
);
2392 if (!seen_type
&& ts
!= NULL
2393 && match_type_spec (ts
, 0) == MATCH_YES
2394 && gfc_match_space () == MATCH_YES
)
2401 if (gfc_match ("elemental% ") == MATCH_YES
)
2403 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2409 if (gfc_match ("pure% ") == MATCH_YES
)
2411 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2417 if (gfc_match ("recursive% ") == MATCH_YES
)
2419 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2425 /* At this point, the next item is not a prefix. */
2430 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2433 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2436 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2439 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2442 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2449 /* Match a formal argument list. */
2452 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2454 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2455 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2461 if (gfc_match_char ('(') != MATCH_YES
)
2468 if (gfc_match_char (')') == MATCH_YES
)
2473 if (gfc_match_char ('*') == MATCH_YES
)
2477 m
= gfc_match_name (name
);
2481 if (gfc_get_symbol (name
, NULL
, &sym
))
2485 p
= gfc_get_formal_arglist ();
2497 /* We don't add the VARIABLE flavor because the name could be a
2498 dummy procedure. We don't apply these attributes to formal
2499 arguments of statement functions. */
2500 if (sym
!= NULL
&& !st_flag
2501 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2502 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2508 /* The name of a program unit can be in a different namespace,
2509 so check for it explicitly. After the statement is accepted,
2510 the name is checked for especially in gfc_get_symbol(). */
2511 if (gfc_new_block
!= NULL
&& sym
!= NULL
2512 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2514 gfc_error ("Name '%s' at %C is the name of the procedure",
2520 if (gfc_match_char (')') == MATCH_YES
)
2523 m
= gfc_match_char (',');
2526 gfc_error ("Unexpected junk in formal argument list at %C");
2532 /* Check for duplicate symbols in the formal argument list. */
2535 for (p
= head
; p
->next
; p
= p
->next
)
2540 for (q
= p
->next
; q
; q
= q
->next
)
2541 if (p
->sym
== q
->sym
)
2544 ("Duplicate symbol '%s' in formal argument list at %C",
2553 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2563 gfc_free_formal_arglist (head
);
2568 /* Match a RESULT specification following a function declaration or
2569 ENTRY statement. Also matches the end-of-statement. */
2572 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2574 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2578 if (gfc_match (" result (") != MATCH_YES
)
2581 m
= gfc_match_name (name
);
2585 if (gfc_match (" )%t") != MATCH_YES
)
2587 gfc_error ("Unexpected junk following RESULT variable at %C");
2591 if (strcmp (function
->name
, name
) == 0)
2594 ("RESULT variable at %C must be different than function name");
2598 if (gfc_get_symbol (name
, NULL
, &r
))
2601 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2602 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2611 /* Match a function declaration. */
2614 gfc_match_function_decl (void)
2616 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2617 gfc_symbol
*sym
, *result
;
2621 if (gfc_current_state () != COMP_NONE
2622 && gfc_current_state () != COMP_INTERFACE
2623 && gfc_current_state () != COMP_CONTAINS
)
2626 gfc_clear_ts (¤t_ts
);
2628 old_loc
= gfc_current_locus
;
2630 m
= match_prefix (¤t_ts
);
2633 gfc_current_locus
= old_loc
;
2637 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2639 gfc_current_locus
= old_loc
;
2643 if (get_proc_name (name
, &sym
, false))
2645 gfc_new_block
= sym
;
2647 m
= gfc_match_formal_arglist (sym
, 0, 0);
2650 gfc_error ("Expected formal argument list in function "
2651 "definition at %C");
2655 else if (m
== MATCH_ERROR
)
2660 if (gfc_match_eos () != MATCH_YES
)
2662 /* See if a result variable is present. */
2663 m
= match_result (sym
, &result
);
2665 gfc_error ("Unexpected junk after function declaration at %C");
2674 /* Make changes to the symbol. */
2677 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2680 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2681 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2684 if (current_ts
.type
!= BT_UNKNOWN
2685 && sym
->ts
.type
!= BT_UNKNOWN
2686 && !sym
->attr
.implicit_type
)
2688 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2689 gfc_basic_typename (sym
->ts
.type
));
2695 sym
->ts
= current_ts
;
2700 result
->ts
= current_ts
;
2701 sym
->result
= result
;
2707 gfc_current_locus
= old_loc
;
2711 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2712 name of the entry, rather than the gfc_current_block name, and to return false
2713 upon finding an existing global entry. */
2716 add_global_entry (const char * name
, int sub
)
2720 s
= gfc_get_gsymbol(name
);
2723 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2724 global_used(s
, NULL
);
2727 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2728 s
->where
= gfc_current_locus
;
2735 /* Match an ENTRY statement. */
2738 gfc_match_entry (void)
2743 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2744 gfc_compile_state state
;
2748 bool module_procedure
;
2750 m
= gfc_match_name (name
);
2754 state
= gfc_current_state ();
2755 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2760 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2763 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2765 case COMP_BLOCK_DATA
:
2767 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2769 case COMP_INTERFACE
:
2771 ("ENTRY statement at %C cannot appear within an INTERFACE");
2775 ("ENTRY statement at %C cannot appear "
2776 "within a DERIVED TYPE block");
2780 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2784 ("ENTRY statement at %C cannot appear within a DO block");
2788 ("ENTRY statement at %C cannot appear within a SELECT block");
2792 ("ENTRY statement at %C cannot appear within a FORALL block");
2796 ("ENTRY statement at %C cannot appear within a WHERE block");
2800 ("ENTRY statement at %C cannot appear "
2801 "within a contained subprogram");
2804 gfc_internal_error ("gfc_match_entry(): Bad state");
2809 module_procedure
= gfc_current_ns
->parent
!= NULL
2810 && gfc_current_ns
->parent
->proc_name
2811 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
;
2813 if (gfc_current_ns
->parent
!= NULL
2814 && gfc_current_ns
->parent
->proc_name
2815 && !module_procedure
)
2817 gfc_error("ENTRY statement at %C cannot appear in a "
2818 "contained procedure");
2822 /* Module function entries need special care in get_proc_name
2823 because previous references within the function will have
2824 created symbols attached to the current namespace. */
2825 if (get_proc_name (name
, &entry
,
2826 gfc_current_ns
->parent
!= NULL
2828 && gfc_current_ns
->proc_name
->attr
.function
))
2831 proc
= gfc_current_block ();
2833 if (state
== COMP_SUBROUTINE
)
2835 /* An entry in a subroutine. */
2836 if (!add_global_entry (name
, 1))
2839 m
= gfc_match_formal_arglist (entry
, 0, 1);
2843 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2844 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2849 /* An entry in a function.
2850 We need to take special care because writing
2855 ENTRY f() RESULT (r)
2857 ENTRY f RESULT (r). */
2858 if (!add_global_entry (name
, 0))
2861 old_loc
= gfc_current_locus
;
2862 if (gfc_match_eos () == MATCH_YES
)
2864 gfc_current_locus
= old_loc
;
2865 /* Match the empty argument list, and add the interface to
2867 m
= gfc_match_formal_arglist (entry
, 0, 1);
2870 m
= gfc_match_formal_arglist (entry
, 0, 0);
2877 if (gfc_match_eos () == MATCH_YES
)
2879 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2880 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2883 entry
->result
= entry
;
2887 m
= match_result (proc
, &result
);
2889 gfc_syntax_error (ST_ENTRY
);
2893 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2894 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2895 || gfc_add_function (&entry
->attr
, result
->name
,
2899 entry
->result
= result
;
2902 if (proc
->attr
.recursive
&& result
== NULL
)
2904 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2909 if (gfc_match_eos () != MATCH_YES
)
2911 gfc_syntax_error (ST_ENTRY
);
2915 entry
->attr
.recursive
= proc
->attr
.recursive
;
2916 entry
->attr
.elemental
= proc
->attr
.elemental
;
2917 entry
->attr
.pure
= proc
->attr
.pure
;
2919 el
= gfc_get_entry_list ();
2921 el
->next
= gfc_current_ns
->entries
;
2922 gfc_current_ns
->entries
= el
;
2924 el
->id
= el
->next
->id
+ 1;
2928 new_st
.op
= EXEC_ENTRY
;
2929 new_st
.ext
.entry
= el
;
2935 /* Match a subroutine statement, including optional prefixes. */
2938 gfc_match_subroutine (void)
2940 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2944 if (gfc_current_state () != COMP_NONE
2945 && gfc_current_state () != COMP_INTERFACE
2946 && gfc_current_state () != COMP_CONTAINS
)
2949 m
= match_prefix (NULL
);
2953 m
= gfc_match ("subroutine% %n", name
);
2957 if (get_proc_name (name
, &sym
, false))
2959 gfc_new_block
= sym
;
2961 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2964 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2967 if (gfc_match_eos () != MATCH_YES
)
2969 gfc_syntax_error (ST_SUBROUTINE
);
2973 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2980 /* Return nonzero if we're currently compiling a contained procedure. */
2983 contained_procedure (void)
2987 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2988 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2989 && s
->previous
!= NULL
2990 && s
->previous
->state
== COMP_CONTAINS
)
2996 /* Set the kind of each enumerator. The kind is selected such that it is
2997 interoperable with the corresponding C enumeration type, making
2998 sure that -fshort-enums is honored. */
3003 enumerator_history
*current_history
= NULL
;
3007 if (max_enum
== NULL
|| enum_history
== NULL
)
3010 if (!gfc_option
.fshort_enums
)
3016 kind
= gfc_integer_kinds
[i
++].kind
;
3018 while (kind
< gfc_c_int_kind
3019 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
3022 current_history
= enum_history
;
3023 while (current_history
!= NULL
)
3025 current_history
->sym
->ts
.kind
= kind
;
3026 current_history
= current_history
->next
;
3030 /* Match any of the various end-block statements. Returns the type of
3031 END to the caller. The END INTERFACE, END IF, END DO and END
3032 SELECT statements cannot be replaced by a single END statement. */
3035 gfc_match_end (gfc_statement
* st
)
3037 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3038 gfc_compile_state state
;
3040 const char *block_name
;
3045 old_loc
= gfc_current_locus
;
3046 if (gfc_match ("end") != MATCH_YES
)
3049 state
= gfc_current_state ();
3051 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
3053 if (state
== COMP_CONTAINS
)
3055 state
= gfc_state_stack
->previous
->state
;
3056 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
3057 : gfc_state_stack
->previous
->sym
->name
;
3064 *st
= ST_END_PROGRAM
;
3065 target
= " program";
3069 case COMP_SUBROUTINE
:
3070 *st
= ST_END_SUBROUTINE
;
3071 target
= " subroutine";
3072 eos_ok
= !contained_procedure ();
3076 *st
= ST_END_FUNCTION
;
3077 target
= " function";
3078 eos_ok
= !contained_procedure ();
3081 case COMP_BLOCK_DATA
:
3082 *st
= ST_END_BLOCK_DATA
;
3083 target
= " block data";
3088 *st
= ST_END_MODULE
;
3093 case COMP_INTERFACE
:
3094 *st
= ST_END_INTERFACE
;
3095 target
= " interface";
3118 *st
= ST_END_SELECT
;
3124 *st
= ST_END_FORALL
;
3139 last_initializer
= NULL
;
3141 gfc_free_enum_history ();
3145 gfc_error ("Unexpected END statement at %C");
3149 if (gfc_match_eos () == MATCH_YES
)
3153 /* We would have required END [something] */
3154 gfc_error ("%s statement expected at %L",
3155 gfc_ascii_statement (*st
), &old_loc
);
3162 /* Verify that we've got the sort of end-block that we're expecting. */
3163 if (gfc_match (target
) != MATCH_YES
)
3165 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3169 /* If we're at the end, make sure a block name wasn't required. */
3170 if (gfc_match_eos () == MATCH_YES
)
3173 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3176 if (gfc_current_block () == NULL
)
3179 gfc_error ("Expected block name of '%s' in %s statement at %C",
3180 block_name
, gfc_ascii_statement (*st
));
3185 /* END INTERFACE has a special handler for its several possible endings. */
3186 if (*st
== ST_END_INTERFACE
)
3187 return gfc_match_end_interface ();
3189 /* We haven't hit the end of statement, so what is left must be an end-name. */
3190 m
= gfc_match_space ();
3192 m
= gfc_match_name (name
);
3195 gfc_error ("Expected terminating name at %C");
3199 if (block_name
== NULL
)
3202 if (strcmp (name
, block_name
) != 0)
3204 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3205 gfc_ascii_statement (*st
));
3209 if (gfc_match_eos () == MATCH_YES
)
3213 gfc_syntax_error (*st
);
3216 gfc_current_locus
= old_loc
;
3222 /***************** Attribute declaration statements ****************/
3224 /* Set the attribute of a single variable. */
3229 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3237 m
= gfc_match_name (name
);
3241 if (find_special (name
, &sym
))
3244 var_locus
= gfc_current_locus
;
3246 /* Deal with possible array specification for certain attributes. */
3247 if (current_attr
.dimension
3248 || current_attr
.allocatable
3249 || current_attr
.pointer
3250 || current_attr
.target
)
3252 m
= gfc_match_array_spec (&as
);
3253 if (m
== MATCH_ERROR
)
3256 if (current_attr
.dimension
&& m
== MATCH_NO
)
3259 ("Missing array specification at %L in DIMENSION statement",
3265 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3266 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3268 gfc_error ("Array specification must be deferred at %L",
3275 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3276 if (current_attr
.dimension
== 0
3277 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3283 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3289 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3291 /* Fix the array spec. */
3292 m
= gfc_mod_pointee_as (sym
->as
);
3293 if (m
== MATCH_ERROR
)
3297 if (gfc_add_attribute (&sym
->attr
, &var_locus
, current_attr
.intent
) == FAILURE
)
3303 if ((current_attr
.external
|| current_attr
.intrinsic
)
3304 && sym
->attr
.flavor
!= FL_PROCEDURE
3305 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3314 gfc_free_array_spec (as
);
3319 /* Generic attribute declaration subroutine. Used for attributes that
3320 just have a list of names. */
3327 /* Gobble the optional double colon, by simply ignoring the result
3337 if (gfc_match_eos () == MATCH_YES
)
3343 if (gfc_match_char (',') != MATCH_YES
)
3345 gfc_error ("Unexpected character in variable list at %C");
3355 /* This routine matches Cray Pointer declarations of the form:
3356 pointer ( <pointer>, <pointee> )
3358 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3359 The pointer, if already declared, should be an integer. Otherwise, we
3360 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3361 be either a scalar, or an array declaration. No space is allocated for
3362 the pointee. For the statement
3363 pointer (ipt, ar(10))
3364 any subsequent uses of ar will be translated (in C-notation) as
3365 ar(i) => ((<type> *) ipt)(i)
3366 After gimplification, pointee variable will disappear in the code. */
3369 cray_pointer_decl (void)
3373 gfc_symbol
*cptr
; /* Pointer symbol. */
3374 gfc_symbol
*cpte
; /* Pointee symbol. */
3380 if (gfc_match_char ('(') != MATCH_YES
)
3382 gfc_error ("Expected '(' at %C");
3386 /* Match pointer. */
3387 var_locus
= gfc_current_locus
;
3388 gfc_clear_attr (¤t_attr
);
3389 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3390 current_ts
.type
= BT_INTEGER
;
3391 current_ts
.kind
= gfc_index_integer_kind
;
3393 m
= gfc_match_symbol (&cptr
, 0);
3396 gfc_error ("Expected variable name at %C");
3400 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3403 gfc_set_sym_referenced (cptr
);
3405 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3407 cptr
->ts
.type
= BT_INTEGER
;
3408 cptr
->ts
.kind
= gfc_index_integer_kind
;
3410 else if (cptr
->ts
.type
!= BT_INTEGER
)
3412 gfc_error ("Cray pointer at %C must be an integer.");
3415 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3416 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3417 " memory addresses require %d bytes.",
3419 gfc_index_integer_kind
);
3421 if (gfc_match_char (',') != MATCH_YES
)
3423 gfc_error ("Expected \",\" at %C");
3427 /* Match Pointee. */
3428 var_locus
= gfc_current_locus
;
3429 gfc_clear_attr (¤t_attr
);
3430 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3431 current_ts
.type
= BT_UNKNOWN
;
3432 current_ts
.kind
= 0;
3434 m
= gfc_match_symbol (&cpte
, 0);
3437 gfc_error ("Expected variable name at %C");
3441 /* Check for an optional array spec. */
3442 m
= gfc_match_array_spec (&as
);
3443 if (m
== MATCH_ERROR
)
3445 gfc_free_array_spec (as
);
3448 else if (m
== MATCH_NO
)
3450 gfc_free_array_spec (as
);
3454 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3457 gfc_set_sym_referenced (cpte
);
3459 if (cpte
->as
== NULL
)
3461 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3462 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3464 else if (as
!= NULL
)
3466 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3467 gfc_free_array_spec (as
);
3473 if (cpte
->as
!= NULL
)
3475 /* Fix array spec. */
3476 m
= gfc_mod_pointee_as (cpte
->as
);
3477 if (m
== MATCH_ERROR
)
3481 /* Point the Pointee at the Pointer. */
3482 cpte
->cp_pointer
= cptr
;
3484 if (gfc_match_char (')') != MATCH_YES
)
3486 gfc_error ("Expected \")\" at %C");
3489 m
= gfc_match_char (',');
3491 done
= true; /* Stop searching for more declarations. */
3495 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3496 || gfc_match_eos () != MATCH_YES
)
3498 gfc_error ("Expected \",\" or end of statement at %C");
3506 gfc_match_external (void)
3509 gfc_clear_attr (¤t_attr
);
3510 current_attr
.external
= 1;
3512 return attr_decl ();
3518 gfc_match_intent (void)
3522 intent
= match_intent_spec ();
3523 if (intent
== INTENT_UNKNOWN
)
3526 gfc_clear_attr (¤t_attr
);
3527 current_attr
.intent
= intent
;
3529 return attr_decl ();
3534 gfc_match_intrinsic (void)
3537 gfc_clear_attr (¤t_attr
);
3538 current_attr
.intrinsic
= 1;
3540 return attr_decl ();
3545 gfc_match_optional (void)
3548 gfc_clear_attr (¤t_attr
);
3549 current_attr
.optional
= 1;
3551 return attr_decl ();
3556 gfc_match_pointer (void)
3558 gfc_gobble_whitespace ();
3559 if (gfc_peek_char () == '(')
3561 if (!gfc_option
.flag_cray_pointer
)
3563 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3567 return cray_pointer_decl ();
3571 gfc_clear_attr (¤t_attr
);
3572 current_attr
.pointer
= 1;
3574 return attr_decl ();
3580 gfc_match_allocatable (void)
3583 gfc_clear_attr (¤t_attr
);
3584 current_attr
.allocatable
= 1;
3586 return attr_decl ();
3591 gfc_match_dimension (void)
3594 gfc_clear_attr (¤t_attr
);
3595 current_attr
.dimension
= 1;
3597 return attr_decl ();
3602 gfc_match_target (void)
3605 gfc_clear_attr (¤t_attr
);
3606 current_attr
.target
= 1;
3608 return attr_decl ();
3612 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3616 access_attr_decl (gfc_statement st
)
3618 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3619 interface_type type
;
3622 gfc_intrinsic_op
operator;
3625 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3630 m
= gfc_match_generic_spec (&type
, name
, &operator);
3633 if (m
== MATCH_ERROR
)
3638 case INTERFACE_NAMELESS
:
3641 case INTERFACE_GENERIC
:
3642 if (gfc_get_symbol (name
, NULL
, &sym
))
3645 if (gfc_add_access (&sym
->attr
,
3647 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3648 sym
->name
, NULL
) == FAILURE
)
3653 case INTERFACE_INTRINSIC_OP
:
3654 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3656 gfc_current_ns
->operator_access
[operator] =
3657 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3661 gfc_error ("Access specification of the %s operator at %C has "
3662 "already been specified", gfc_op2string (operator));
3668 case INTERFACE_USER_OP
:
3669 uop
= gfc_get_uop (name
);
3671 if (uop
->access
== ACCESS_UNKNOWN
)
3674 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3679 ("Access specification of the .%s. operator at %C has "
3680 "already been specified", sym
->name
);
3687 if (gfc_match_char (',') == MATCH_NO
)
3691 if (gfc_match_eos () != MATCH_YES
)
3696 gfc_syntax_error (st
);
3703 /* The PRIVATE statement is a bit weird in that it can be a attribute
3704 declaration, but also works as a standlone statement inside of a
3705 type declaration or a module. */
3708 gfc_match_private (gfc_statement
* st
)
3711 if (gfc_match ("private") != MATCH_YES
)
3714 if (gfc_current_state () == COMP_DERIVED
)
3716 if (gfc_match_eos () == MATCH_YES
)
3722 gfc_syntax_error (ST_PRIVATE
);
3726 if (gfc_match_eos () == MATCH_YES
)
3733 return access_attr_decl (ST_PRIVATE
);
3738 gfc_match_public (gfc_statement
* st
)
3741 if (gfc_match ("public") != MATCH_YES
)
3744 if (gfc_match_eos () == MATCH_YES
)
3751 return access_attr_decl (ST_PUBLIC
);
3755 /* Workhorse for gfc_match_parameter. */
3764 m
= gfc_match_symbol (&sym
, 0);
3766 gfc_error ("Expected variable name at %C in PARAMETER statement");
3771 if (gfc_match_char ('=') == MATCH_NO
)
3773 gfc_error ("Expected = sign in PARAMETER statement at %C");
3777 m
= gfc_match_init_expr (&init
);
3779 gfc_error ("Expected expression at %C in PARAMETER statement");
3783 if (sym
->ts
.type
== BT_UNKNOWN
3784 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3790 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3791 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3797 if (sym
->ts
.type
== BT_CHARACTER
3798 && sym
->ts
.cl
!= NULL
3799 && sym
->ts
.cl
->length
!= NULL
3800 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3801 && init
->expr_type
== EXPR_CONSTANT
3802 && init
->ts
.type
== BT_CHARACTER
3803 && init
->ts
.kind
== 1)
3804 gfc_set_constant_character_len (
3805 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3811 gfc_free_expr (init
);
3816 /* Match a parameter statement, with the weird syntax that these have. */
3819 gfc_match_parameter (void)
3823 if (gfc_match_char ('(') == MATCH_NO
)
3832 if (gfc_match (" )%t") == MATCH_YES
)
3835 if (gfc_match_char (',') != MATCH_YES
)
3837 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3847 /* Save statements have a special syntax. */
3850 gfc_match_save (void)
3852 char n
[GFC_MAX_SYMBOL_LEN
+1];
3857 if (gfc_match_eos () == MATCH_YES
)
3859 if (gfc_current_ns
->seen_save
)
3861 if (gfc_notify_std (GFC_STD_LEGACY
,
3862 "Blanket SAVE statement at %C follows previous "
3868 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3872 if (gfc_current_ns
->save_all
)
3874 if (gfc_notify_std (GFC_STD_LEGACY
,
3875 "SAVE statement at %C follows blanket SAVE statement")
3884 m
= gfc_match_symbol (&sym
, 0);
3888 if (gfc_add_save (&sym
->attr
, sym
->name
,
3889 &gfc_current_locus
) == FAILURE
)
3900 m
= gfc_match (" / %n /", &n
);
3901 if (m
== MATCH_ERROR
)
3906 c
= gfc_get_common (n
, 0);
3909 gfc_current_ns
->seen_save
= 1;
3912 if (gfc_match_eos () == MATCH_YES
)
3914 if (gfc_match_char (',') != MATCH_YES
)
3921 gfc_error ("Syntax error in SAVE statement at %C");
3926 /* Match a module procedure statement. Note that we have to modify
3927 symbols in the parent's namespace because the current one was there
3928 to receive symbols that are in an interface's formal argument list. */
3931 gfc_match_modproc (void)
3933 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3937 if (gfc_state_stack
->state
!= COMP_INTERFACE
3938 || gfc_state_stack
->previous
== NULL
3939 || current_interface
.type
== INTERFACE_NAMELESS
)
3942 ("MODULE PROCEDURE at %C must be in a generic module interface");
3948 m
= gfc_match_name (name
);
3954 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3957 if (sym
->attr
.proc
!= PROC_MODULE
3958 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3959 sym
->name
, NULL
) == FAILURE
)
3962 if (gfc_add_interface (sym
) == FAILURE
)
3965 if (gfc_match_eos () == MATCH_YES
)
3967 if (gfc_match_char (',') != MATCH_YES
)
3974 gfc_syntax_error (ST_MODULE_PROC
);
3979 /* Match the beginning of a derived type declaration. If a type name
3980 was the result of a function, then it is possible to have a symbol
3981 already to be known as a derived type yet have no components. */
3984 gfc_match_derived_decl (void)
3986 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3987 symbol_attribute attr
;
3991 if (gfc_current_state () == COMP_DERIVED
)
3994 gfc_clear_attr (&attr
);
3997 if (gfc_match (" , private") == MATCH_YES
)
3999 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4002 ("Derived type at %C can only be PRIVATE within a MODULE");
4006 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
4011 if (gfc_match (" , public") == MATCH_YES
)
4013 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4015 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4019 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
4024 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
4026 gfc_error ("Expected :: in TYPE definition at %C");
4030 m
= gfc_match (" %n%t", name
);
4034 /* Make sure the name isn't the name of an intrinsic type. The
4035 'double precision' type doesn't get past the name matcher. */
4036 if (strcmp (name
, "integer") == 0
4037 || strcmp (name
, "real") == 0
4038 || strcmp (name
, "character") == 0
4039 || strcmp (name
, "logical") == 0
4040 || strcmp (name
, "complex") == 0)
4043 ("Type name '%s' at %C cannot be the same as an intrinsic type",
4048 if (gfc_get_symbol (name
, NULL
, &sym
))
4051 if (sym
->ts
.type
!= BT_UNKNOWN
)
4053 gfc_error ("Derived type name '%s' at %C already has a basic type "
4054 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
4058 /* The symbol may already have the derived attribute without the
4059 components. The ways this can happen is via a function
4060 definition, an INTRINSIC statement or a subtype in another
4061 derived type that is a pointer. The first part of the AND clause
4062 is true if a the symbol is not the return value of a function. */
4063 if (sym
->attr
.flavor
!= FL_DERIVED
4064 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
4067 if (sym
->components
!= NULL
)
4070 ("Derived type definition of '%s' at %C has already been defined",
4075 if (attr
.access
!= ACCESS_UNKNOWN
4076 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
4079 gfc_new_block
= sym
;
4085 /* Cray Pointees can be declared as:
4086 pointer (ipt, a (n,m,...,*))
4087 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4088 cheat and set a constant bound of 1 for the last dimension, if this
4089 is the case. Since there is no bounds-checking for Cray Pointees,
4090 this will be okay. */
4093 gfc_mod_pointee_as (gfc_array_spec
*as
)
4095 as
->cray_pointee
= true; /* This will be useful to know later. */
4096 if (as
->type
== AS_ASSUMED_SIZE
)
4098 as
->type
= AS_EXPLICIT
;
4099 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4100 as
->cp_was_assumed
= true;
4102 else if (as
->type
== AS_ASSUMED_SHAPE
)
4104 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4111 /* Match the enum definition statement, here we are trying to match
4112 the first line of enum definition statement.
4113 Returns MATCH_YES if match is found. */
4116 gfc_match_enum (void)
4120 m
= gfc_match_eos ();
4124 if (gfc_notify_std (GFC_STD_F2003
,
4125 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
4133 /* Match the enumerator definition statement. */
4136 gfc_match_enumerator_def (void)
4141 gfc_clear_ts (¤t_ts
);
4143 m
= gfc_match (" enumerator");
4147 if (gfc_current_state () != COMP_ENUM
)
4149 gfc_error ("ENUM definition statement expected before %C");
4150 gfc_free_enum_history ();
4154 (¤t_ts
)->type
= BT_INTEGER
;
4155 (¤t_ts
)->kind
= gfc_c_int_kind
;
4157 m
= match_attr_spec ();
4158 if (m
== MATCH_ERROR
)
4167 m
= variable_decl (elem
++);
4168 if (m
== MATCH_ERROR
)
4173 if (gfc_match_eos () == MATCH_YES
)
4175 if (gfc_match_char (',') != MATCH_YES
)
4179 if (gfc_current_state () == COMP_ENUM
)
4181 gfc_free_enum_history ();
4182 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4187 gfc_free_array_spec (current_as
);