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
)
390 /* Set up data structure to hold initializers. */
391 gfc_find_sym_tree (name
, NULL
, 0, &st
);
393 newdata
= gfc_get_data ();
394 newdata
->var
= gfc_get_data_variable ();
395 newdata
->var
->expr
= gfc_get_variable_expr (st
);
397 /* Match initial value list. This also eats the terminal
399 m
= top_val_list (newdata
);
408 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
413 /* Chain in namespace list of DATA initializers. */
414 newdata
->next
= gfc_current_ns
->data
;
415 gfc_current_ns
->data
= newdata
;
420 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
421 we are matching a DATA statement and are therefore issuing an error
422 if we encounter something unexpected, if not, we're trying to match
423 an old-style initialization expression of the form INTEGER I /2/. */
426 gfc_match_data (void)
433 new = gfc_get_data ();
434 new->where
= gfc_current_locus
;
436 m
= top_var_list (new);
440 m
= top_val_list (new);
444 new->next
= gfc_current_ns
->data
;
445 gfc_current_ns
->data
= new;
447 if (gfc_match_eos () == MATCH_YES
)
450 gfc_match_char (','); /* Optional comma */
455 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
467 /************************ Declaration statements *********************/
469 /* Match an intent specification. Since this can only happen after an
470 INTENT word, a legal intent-spec must follow. */
473 match_intent_spec (void)
476 if (gfc_match (" ( in out )") == MATCH_YES
)
478 if (gfc_match (" ( in )") == MATCH_YES
)
480 if (gfc_match (" ( out )") == MATCH_YES
)
483 gfc_error ("Bad INTENT specification at %C");
484 return INTENT_UNKNOWN
;
488 /* Matches a character length specification, which is either a
489 specification expression or a '*'. */
492 char_len_param_value (gfc_expr
** expr
)
495 if (gfc_match_char ('*') == MATCH_YES
)
501 return gfc_match_expr (expr
);
505 /* A character length is a '*' followed by a literal integer or a
506 char_len_param_value in parenthesis. */
509 match_char_length (gfc_expr
** expr
)
514 m
= gfc_match_char ('*');
518 m
= gfc_match_small_literal_int (&length
, NULL
);
519 if (m
== MATCH_ERROR
)
524 *expr
= gfc_int_expr (length
);
528 if (gfc_match_char ('(') == MATCH_NO
)
531 m
= char_len_param_value (expr
);
532 if (m
== MATCH_ERROR
)
537 if (gfc_match_char (')') == MATCH_NO
)
539 gfc_free_expr (*expr
);
547 gfc_error ("Syntax error in character length specification at %C");
552 /* Special subroutine for finding a symbol. Check if the name is found
553 in the current name space. If not, and we're compiling a function or
554 subroutine and the parent compilation unit is an interface, then check
555 to see if the name we've been given is the name of the interface
556 (located in another namespace). */
559 find_special (const char *name
, gfc_symbol
** result
)
564 i
= gfc_get_symbol (name
, NULL
, result
);
568 if (gfc_current_state () != COMP_SUBROUTINE
569 && gfc_current_state () != COMP_FUNCTION
)
572 s
= gfc_state_stack
->previous
;
576 if (s
->state
!= COMP_INTERFACE
)
579 goto end
; /* Nameless interface */
581 if (strcmp (name
, s
->sym
->name
) == 0)
592 /* Special subroutine for getting a symbol node associated with a
593 procedure name, used in SUBROUTINE and FUNCTION statements. The
594 symbol is created in the parent using with symtree node in the
595 child unit pointing to the symbol. If the current namespace has no
596 parent, then the symbol is just created in the current unit. */
599 get_proc_name (const char *name
, gfc_symbol
** result
)
605 if (gfc_current_ns
->parent
== NULL
)
606 rc
= gfc_get_symbol (name
, NULL
, result
);
608 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
612 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
614 /* Trap another encompassed procedure with the same name. All
615 these conditions are necessary to avoid picking up an entry
616 whose name clashes with that of the encompassing procedure;
617 this is handled using gsymbols to register unique,globally
619 if (sym
->attr
.flavor
!= 0
620 && sym
->attr
.proc
!= 0
622 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
623 name
, &sym
->declared_at
);
625 /* Trap declarations of attributes in encompassing scope. The
626 signature for this is that ts.kind is set. Legitimate
627 references only set ts.type. */
628 if (sym
->ts
.kind
!= 0
629 && sym
->attr
.proc
== 0
630 && gfc_current_ns
->parent
!= NULL
631 && sym
->attr
.access
== 0)
632 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
633 " and must not have attributes declared at %L",
634 name
, &sym
->declared_at
);
637 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
640 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
645 /* See if the procedure should be a module procedure */
647 if (sym
->ns
->proc_name
!= NULL
648 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
649 && sym
->attr
.proc
!= PROC_MODULE
650 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
651 sym
->name
, NULL
) == FAILURE
)
658 /* Function called by variable_decl() that adds a name to the symbol
662 build_sym (const char *name
, gfc_charlen
* cl
,
663 gfc_array_spec
** as
, locus
* var_locus
)
665 symbol_attribute attr
;
668 /* if (find_special (name, &sym)) */
669 if (gfc_get_symbol (name
, NULL
, &sym
))
672 /* Start updating the symbol table. Add basic type attribute
674 if (current_ts
.type
!= BT_UNKNOWN
675 &&(sym
->attr
.implicit_type
== 0
676 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
677 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
680 if (sym
->ts
.type
== BT_CHARACTER
)
683 /* Add dimension attribute if present. */
684 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
688 /* Add attribute to symbol. The copy is so that we can reset the
689 dimension attribute. */
693 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
699 /* Set character constant to the given length. The constant will be padded or
703 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
708 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
709 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
711 slen
= expr
->value
.character
.length
;
714 s
= gfc_getmem (len
);
715 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
717 memset (&s
[slen
], ' ', len
- slen
);
718 gfc_free (expr
->value
.character
.string
);
719 expr
->value
.character
.string
= s
;
720 expr
->value
.character
.length
= len
;
725 /* Function to create and update the enumerator history
726 using the information passed as arguments.
727 Pointer "max_enum" is also updated, to point to
728 enum history node containing largest initializer.
730 SYM points to the symbol node of enumerator.
731 INIT points to its enumerator value. */
734 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
736 enumerator_history
*new_enum_history
;
737 gcc_assert (sym
!= NULL
&& init
!= NULL
);
739 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
741 new_enum_history
->sym
= sym
;
742 new_enum_history
->initializer
= init
;
743 new_enum_history
->next
= NULL
;
745 if (enum_history
== NULL
)
747 enum_history
= new_enum_history
;
748 max_enum
= enum_history
;
752 new_enum_history
->next
= enum_history
;
753 enum_history
= new_enum_history
;
755 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
756 new_enum_history
->initializer
->value
.integer
) < 0)
757 max_enum
= new_enum_history
;
762 /* Function to free enum kind history. */
765 gfc_free_enum_history(void)
767 enumerator_history
*current
= enum_history
;
768 enumerator_history
*next
;
770 while (current
!= NULL
)
772 next
= current
->next
;
781 /* Function called by variable_decl() that adds an initialization
782 expression to a symbol. */
785 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
788 symbol_attribute attr
;
793 if (find_special (name
, &sym
))
798 /* If this symbol is confirming an implicit parameter type,
799 then an initialization expression is not allowed. */
800 if (attr
.flavor
== FL_PARAMETER
801 && sym
->value
!= NULL
804 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
813 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
820 /* An initializer is required for PARAMETER declarations. */
821 if (attr
.flavor
== FL_PARAMETER
)
823 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
829 /* If a variable appears in a DATA block, it cannot have an
834 ("Variable '%s' at %C with an initializer already appears "
835 "in a DATA statement", sym
->name
);
839 /* Check if the assignment can happen. This has to be put off
840 until later for a derived type variable. */
841 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
842 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
845 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
847 /* Update symbol character length according initializer. */
848 if (sym
->ts
.cl
->length
== NULL
)
850 /* If there are multiple CHARACTER variables declared on
851 the same line, we don't want them to share the same
853 sym
->ts
.cl
= gfc_get_charlen ();
854 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
855 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
857 if (init
->expr_type
== EXPR_CONSTANT
)
859 gfc_int_expr (init
->value
.character
.length
);
860 else if (init
->expr_type
== EXPR_ARRAY
)
861 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
863 /* Update initializer character length according symbol. */
864 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
866 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
869 if (init
->expr_type
== EXPR_CONSTANT
)
870 gfc_set_constant_character_len (len
, init
);
871 else if (init
->expr_type
== EXPR_ARRAY
)
873 gfc_free_expr (init
->ts
.cl
->length
);
874 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
875 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
876 gfc_set_constant_character_len (len
, p
->expr
);
881 /* Add initializer. Make sure we keep the ranks sane. */
882 if (sym
->attr
.dimension
&& init
->rank
== 0)
883 init
->rank
= sym
->as
->rank
;
889 /* Maintain enumerator history. */
890 if (gfc_current_state () == COMP_ENUM
)
891 create_enum_history (sym
, init
);
897 /* Function called by variable_decl() that adds a name to a structure
901 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
902 gfc_array_spec
** as
)
906 /* If the current symbol is of the same derived type that we're
907 constructing, it must have the pointer attribute. */
908 if (current_ts
.type
== BT_DERIVED
909 && current_ts
.derived
== gfc_current_block ()
910 && current_attr
.pointer
== 0)
912 gfc_error ("Component at %C must have the POINTER attribute");
916 if (gfc_current_block ()->attr
.pointer
919 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
921 gfc_error ("Array component of structure at %C must have explicit "
922 "or deferred shape");
927 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
932 gfc_set_component_attr (c
, ¤t_attr
);
934 c
->initializer
= *init
;
942 /* Check array components. */
948 if (c
->as
->type
!= AS_DEFERRED
)
950 gfc_error ("Pointer array component of structure at %C "
951 "must have a deferred shape");
957 if (c
->as
->type
!= AS_EXPLICIT
)
960 ("Array component of structure at %C must have an explicit "
970 /* Match a 'NULL()', and possibly take care of some side effects. */
973 gfc_match_null (gfc_expr
** result
)
979 m
= gfc_match (" null ( )");
983 /* The NULL symbol now has to be/become an intrinsic function. */
984 if (gfc_get_symbol ("null", NULL
, &sym
))
986 gfc_error ("NULL() initialization at %C is ambiguous");
990 gfc_intrinsic_symbol (sym
);
992 if (sym
->attr
.proc
!= PROC_INTRINSIC
993 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
994 sym
->name
, NULL
) == FAILURE
995 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
999 e
->where
= gfc_current_locus
;
1000 e
->expr_type
= EXPR_NULL
;
1001 e
->ts
.type
= BT_UNKNOWN
;
1009 /* Match a variable name with an optional initializer. When this
1010 subroutine is called, a variable is expected to be parsed next.
1011 Depending on what is happening at the moment, updates either the
1012 symbol table or the current interface. */
1015 variable_decl (int elem
)
1017 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1018 gfc_expr
*initializer
, *char_len
;
1020 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1031 old_locus
= gfc_current_locus
;
1033 /* When we get here, we've just matched a list of attributes and
1034 maybe a type and a double colon. The next thing we expect to see
1035 is the name of the symbol. */
1036 m
= gfc_match_name (name
);
1040 var_locus
= gfc_current_locus
;
1042 /* Now we could see the optional array spec. or character length. */
1043 m
= gfc_match_array_spec (&as
);
1044 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1045 cp_as
= gfc_copy_array_spec (as
);
1046 else if (m
== MATCH_ERROR
)
1050 as
= gfc_copy_array_spec (current_as
);
1051 else if (gfc_current_state () == COMP_ENUM
)
1053 gfc_error ("Enumerator cannot be array at %C");
1054 gfc_free_enum_history ();
1063 if (current_ts
.type
== BT_CHARACTER
)
1065 switch (match_char_length (&char_len
))
1068 cl
= gfc_get_charlen ();
1069 cl
->next
= gfc_current_ns
->cl_list
;
1070 gfc_current_ns
->cl_list
= cl
;
1072 cl
->length
= char_len
;
1075 /* Non-constant lengths need to be copied after the first
1078 if (elem
> 1 && current_ts
.cl
->length
1079 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1081 cl
= gfc_get_charlen ();
1082 cl
->next
= gfc_current_ns
->cl_list
;
1083 gfc_current_ns
->cl_list
= cl
;
1084 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1096 /* If this symbol has already shown up in a Cray Pointer declaration,
1097 then we want to set the type & bail out. */
1098 if (gfc_option
.flag_cray_pointer
)
1100 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1101 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1103 sym
->ts
.type
= current_ts
.type
;
1104 sym
->ts
.kind
= current_ts
.kind
;
1106 sym
->ts
.derived
= current_ts
.derived
;
1109 /* Check to see if we have an array specification. */
1112 if (sym
->as
!= NULL
)
1114 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1115 gfc_free_array_spec (cp_as
);
1121 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1122 gfc_internal_error ("Couldn't set pointee array spec.");
1124 /* Fix the array spec. */
1125 m
= gfc_mod_pointee_as (sym
->as
);
1126 if (m
== MATCH_ERROR
)
1134 gfc_free_array_spec (cp_as
);
1139 /* OK, we've successfully matched the declaration. Now put the
1140 symbol in the current namespace, because it might be used in the
1141 optional initialization expression for this symbol, e.g. this is
1144 integer, parameter :: i = huge(i)
1146 This is only true for parameters or variables of a basic type.
1147 For components of derived types, it is not true, so we don't
1148 create a symbol for those yet. If we fail to create the symbol,
1150 if (gfc_current_state () != COMP_DERIVED
1151 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1157 /* In functions that have a RESULT variable defined, the function
1158 name always refers to function calls. Therefore, the name is
1159 not allowed to appear in specification statements. */
1160 if (gfc_current_state () == COMP_FUNCTION
1161 && gfc_current_block () != NULL
1162 && gfc_current_block ()->result
!= NULL
1163 && gfc_current_block ()->result
!= gfc_current_block ()
1164 && strcmp (gfc_current_block ()->name
, name
) == 0)
1166 gfc_error ("Function name '%s' not allowed at %C", name
);
1171 /* We allow old-style initializations of the form
1172 integer i /2/, j(4) /3*3, 1/
1173 (if no colon has been seen). These are different from data
1174 statements in that initializers are only allowed to apply to the
1175 variable immediately preceding, i.e.
1177 is not allowed. Therefore we have to do some work manually, that
1178 could otherwise be left to the matchers for DATA statements. */
1180 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1182 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1183 "initialization at %C") == FAILURE
)
1186 return match_old_style_init (name
);
1189 /* The double colon must be present in order to have initializers.
1190 Otherwise the statement is ambiguous with an assignment statement. */
1193 if (gfc_match (" =>") == MATCH_YES
)
1196 if (!current_attr
.pointer
)
1198 gfc_error ("Initialization at %C isn't for a pointer variable");
1203 m
= gfc_match_null (&initializer
);
1206 gfc_error ("Pointer initialization requires a NULL at %C");
1210 if (gfc_pure (NULL
))
1213 ("Initialization of pointer at %C is not allowed in a "
1221 initializer
->ts
= current_ts
;
1224 else if (gfc_match_char ('=') == MATCH_YES
)
1226 if (current_attr
.pointer
)
1229 ("Pointer initialization at %C requires '=>', not '='");
1234 m
= gfc_match_init_expr (&initializer
);
1237 gfc_error ("Expected an initialization expression at %C");
1241 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1244 ("Initialization of variable at %C is not allowed in a "
1254 /* Check if we are parsing an enumeration and if the current enumerator
1255 variable has an initializer or not. If it does not have an
1256 initializer, the initialization value of the previous enumerator
1257 (stored in last_initializer) is incremented by 1 and is used to
1258 initialize the current enumerator. */
1259 if (gfc_current_state () == COMP_ENUM
)
1261 if (initializer
== NULL
)
1262 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1264 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1266 gfc_error("ENUMERATOR %L not initialized with integer expression",
1269 gfc_free_enum_history ();
1273 /* Store this current initializer, for the next enumerator
1274 variable to be parsed. */
1275 last_initializer
= initializer
;
1278 /* Add the initializer. Note that it is fine if initializer is
1279 NULL here, because we sometimes also need to check if a
1280 declaration *must* have an initialization expression. */
1281 if (gfc_current_state () != COMP_DERIVED
)
1282 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1285 if (current_ts
.type
== BT_DERIVED
&& !current_attr
.pointer
&& !initializer
)
1286 initializer
= gfc_default_initializer (¤t_ts
);
1287 t
= build_struct (name
, cl
, &initializer
, &as
);
1290 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1293 /* Free stuff up and return. */
1294 gfc_free_expr (initializer
);
1295 gfc_free_array_spec (as
);
1301 /* Match an extended-f77 kind specification. */
1304 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1309 if (gfc_match_char ('*') != MATCH_YES
)
1312 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1316 original_kind
= ts
->kind
;
1318 /* Massage the kind numbers for complex types. */
1319 if (ts
->type
== BT_COMPLEX
)
1323 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1324 gfc_basic_typename (ts
->type
), original_kind
);
1330 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1332 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1333 gfc_basic_typename (ts
->type
), original_kind
);
1337 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1338 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1345 /* Match a kind specification. Since kinds are generally optional, we
1346 usually return MATCH_NO if something goes wrong. If a "kind="
1347 string is found, then we know we have an error. */
1350 gfc_match_kind_spec (gfc_typespec
* ts
)
1360 where
= gfc_current_locus
;
1362 if (gfc_match_char ('(') == MATCH_NO
)
1365 /* Also gobbles optional text. */
1366 if (gfc_match (" kind = ") == MATCH_YES
)
1369 n
= gfc_match_init_expr (&e
);
1371 gfc_error ("Expected initialization expression at %C");
1377 gfc_error ("Expected scalar initialization expression at %C");
1382 msg
= gfc_extract_int (e
, &ts
->kind
);
1393 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1395 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1396 gfc_basic_typename (ts
->type
));
1402 if (gfc_match_char (')') != MATCH_YES
)
1404 gfc_error ("Missing right paren at %C");
1412 gfc_current_locus
= where
;
1417 /* Match the various kind/length specifications in a CHARACTER
1418 declaration. We don't return MATCH_NO. */
1421 match_char_spec (gfc_typespec
* ts
)
1423 int i
, kind
, seen_length
;
1428 kind
= gfc_default_character_kind
;
1432 /* Try the old-style specification first. */
1433 old_char_selector
= 0;
1435 m
= match_char_length (&len
);
1439 old_char_selector
= 1;
1444 m
= gfc_match_char ('(');
1447 m
= MATCH_YES
; /* character without length is a single char */
1451 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1452 if (gfc_match (" kind =") == MATCH_YES
)
1454 m
= gfc_match_small_int (&kind
);
1455 if (m
== MATCH_ERROR
)
1460 if (gfc_match (" , len =") == MATCH_NO
)
1463 m
= char_len_param_value (&len
);
1466 if (m
== MATCH_ERROR
)
1473 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1474 if (gfc_match (" len =") == MATCH_YES
)
1476 m
= char_len_param_value (&len
);
1479 if (m
== MATCH_ERROR
)
1483 if (gfc_match_char (')') == MATCH_YES
)
1486 if (gfc_match (" , kind =") != MATCH_YES
)
1489 gfc_match_small_int (&kind
);
1491 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1493 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1500 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1501 m
= char_len_param_value (&len
);
1504 if (m
== MATCH_ERROR
)
1508 m
= gfc_match_char (')');
1512 if (gfc_match_char (',') != MATCH_YES
)
1515 gfc_match (" kind ="); /* Gobble optional text */
1517 m
= gfc_match_small_int (&kind
);
1518 if (m
== MATCH_ERROR
)
1524 /* Require a right-paren at this point. */
1525 m
= gfc_match_char (')');
1530 gfc_error ("Syntax error in CHARACTER declaration at %C");
1534 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1536 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1542 gfc_free_expr (len
);
1546 /* Do some final massaging of the length values. */
1547 cl
= gfc_get_charlen ();
1548 cl
->next
= gfc_current_ns
->cl_list
;
1549 gfc_current_ns
->cl_list
= cl
;
1551 if (seen_length
== 0)
1552 cl
->length
= gfc_int_expr (1);
1555 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1559 gfc_free_expr (len
);
1560 cl
->length
= gfc_int_expr (0);
1571 /* Matches a type specification. If successful, sets the ts structure
1572 to the matched specification. This is necessary for FUNCTION and
1573 IMPLICIT statements.
1575 If implicit_flag is nonzero, then we don't check for the optional
1576 kind specification. Not doing so is needed for matching an IMPLICIT
1577 statement correctly. */
1580 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1582 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1589 if (gfc_match (" byte") == MATCH_YES
)
1591 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1595 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1597 gfc_error ("BYTE type used at %C "
1598 "is not available on the target machine");
1602 ts
->type
= BT_INTEGER
;
1607 if (gfc_match (" integer") == MATCH_YES
)
1609 ts
->type
= BT_INTEGER
;
1610 ts
->kind
= gfc_default_integer_kind
;
1614 if (gfc_match (" character") == MATCH_YES
)
1616 ts
->type
= BT_CHARACTER
;
1617 if (implicit_flag
== 0)
1618 return match_char_spec (ts
);
1623 if (gfc_match (" real") == MATCH_YES
)
1626 ts
->kind
= gfc_default_real_kind
;
1630 if (gfc_match (" double precision") == MATCH_YES
)
1633 ts
->kind
= gfc_default_double_kind
;
1637 if (gfc_match (" complex") == MATCH_YES
)
1639 ts
->type
= BT_COMPLEX
;
1640 ts
->kind
= gfc_default_complex_kind
;
1644 if (gfc_match (" double complex") == MATCH_YES
)
1646 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1647 "conform to the Fortran 95 standard") == FAILURE
)
1650 ts
->type
= BT_COMPLEX
;
1651 ts
->kind
= gfc_default_double_kind
;
1655 if (gfc_match (" logical") == MATCH_YES
)
1657 ts
->type
= BT_LOGICAL
;
1658 ts
->kind
= gfc_default_logical_kind
;
1662 m
= gfc_match (" type ( %n )", name
);
1666 /* Search for the name but allow the components to be defined later. */
1667 if (gfc_get_ha_symbol (name
, &sym
))
1669 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1673 if (sym
->attr
.flavor
!= FL_DERIVED
1674 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1677 ts
->type
= BT_DERIVED
;
1684 /* For all types except double, derived and character, look for an
1685 optional kind specifier. MATCH_NO is actually OK at this point. */
1686 if (implicit_flag
== 1)
1689 if (gfc_current_form
== FORM_FREE
)
1691 c
= gfc_peek_char();
1692 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1693 && c
!= ':' && c
!= ',')
1697 m
= gfc_match_kind_spec (ts
);
1698 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1699 m
= gfc_match_old_kind_spec (ts
);
1702 m
= MATCH_YES
; /* No kind specifier found. */
1708 /* Match an IMPLICIT NONE statement. Actually, this statement is
1709 already matched in parse.c, or we would not end up here in the
1710 first place. So the only thing we need to check, is if there is
1711 trailing garbage. If not, the match is successful. */
1714 gfc_match_implicit_none (void)
1717 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1721 /* Match the letter range(s) of an IMPLICIT statement. */
1724 match_implicit_range (void)
1726 int c
, c1
, c2
, inner
;
1729 cur_loc
= gfc_current_locus
;
1731 gfc_gobble_whitespace ();
1732 c
= gfc_next_char ();
1735 gfc_error ("Missing character range in IMPLICIT at %C");
1742 gfc_gobble_whitespace ();
1743 c1
= gfc_next_char ();
1747 gfc_gobble_whitespace ();
1748 c
= gfc_next_char ();
1753 inner
= 0; /* Fall through */
1760 gfc_gobble_whitespace ();
1761 c2
= gfc_next_char ();
1765 gfc_gobble_whitespace ();
1766 c
= gfc_next_char ();
1768 if ((c
!= ',') && (c
!= ')'))
1781 gfc_error ("Letters must be in alphabetic order in "
1782 "IMPLICIT statement at %C");
1786 /* See if we can add the newly matched range to the pending
1787 implicits from this IMPLICIT statement. We do not check for
1788 conflicts with whatever earlier IMPLICIT statements may have
1789 set. This is done when we've successfully finished matching
1791 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1798 gfc_syntax_error (ST_IMPLICIT
);
1800 gfc_current_locus
= cur_loc
;
1805 /* Match an IMPLICIT statement, storing the types for
1806 gfc_set_implicit() if the statement is accepted by the parser.
1807 There is a strange looking, but legal syntactic construction
1808 possible. It looks like:
1810 IMPLICIT INTEGER (a-b) (c-d)
1812 This is legal if "a-b" is a constant expression that happens to
1813 equal one of the legal kinds for integers. The real problem
1814 happens with an implicit specification that looks like:
1816 IMPLICIT INTEGER (a-b)
1818 In this case, a typespec matcher that is "greedy" (as most of the
1819 matchers are) gobbles the character range as a kindspec, leaving
1820 nothing left. We therefore have to go a bit more slowly in the
1821 matching process by inhibiting the kindspec checking during
1822 typespec matching and checking for a kind later. */
1825 gfc_match_implicit (void)
1832 /* We don't allow empty implicit statements. */
1833 if (gfc_match_eos () == MATCH_YES
)
1835 gfc_error ("Empty IMPLICIT statement at %C");
1841 /* First cleanup. */
1842 gfc_clear_new_implicit ();
1844 /* A basic type is mandatory here. */
1845 m
= match_type_spec (&ts
, 1);
1846 if (m
== MATCH_ERROR
)
1851 cur_loc
= gfc_current_locus
;
1852 m
= match_implicit_range ();
1856 /* We may have <TYPE> (<RANGE>). */
1857 gfc_gobble_whitespace ();
1858 c
= gfc_next_char ();
1859 if ((c
== '\n') || (c
== ','))
1861 /* Check for CHARACTER with no length parameter. */
1862 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1864 ts
.kind
= gfc_default_character_kind
;
1865 ts
.cl
= gfc_get_charlen ();
1866 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1867 gfc_current_ns
->cl_list
= ts
.cl
;
1868 ts
.cl
->length
= gfc_int_expr (1);
1871 /* Record the Successful match. */
1872 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1877 gfc_current_locus
= cur_loc
;
1880 /* Discard the (incorrectly) matched range. */
1881 gfc_clear_new_implicit ();
1883 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1884 if (ts
.type
== BT_CHARACTER
)
1885 m
= match_char_spec (&ts
);
1888 m
= gfc_match_kind_spec (&ts
);
1891 m
= gfc_match_old_kind_spec (&ts
);
1892 if (m
== MATCH_ERROR
)
1898 if (m
== MATCH_ERROR
)
1901 m
= match_implicit_range ();
1902 if (m
== MATCH_ERROR
)
1907 gfc_gobble_whitespace ();
1908 c
= gfc_next_char ();
1909 if ((c
!= '\n') && (c
!= ','))
1912 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1920 gfc_syntax_error (ST_IMPLICIT
);
1927 /* Matches an attribute specification including array specs. If
1928 successful, leaves the variables current_attr and current_as
1929 holding the specification. Also sets the colon_seen variable for
1930 later use by matchers associated with initializations.
1932 This subroutine is a little tricky in the sense that we don't know
1933 if we really have an attr-spec until we hit the double colon.
1934 Until that time, we can only return MATCH_NO. This forces us to
1935 check for duplicate specification at this level. */
1938 match_attr_spec (void)
1941 /* Modifiers that can exist in a type statement. */
1943 { GFC_DECL_BEGIN
= 0,
1944 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1945 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1946 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1947 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1948 GFC_DECL_END
/* Sentinel */
1952 /* GFC_DECL_END is the sentinel, index starts at 0. */
1953 #define NUM_DECL GFC_DECL_END
1955 static mstring decls
[] = {
1956 minit (", allocatable", DECL_ALLOCATABLE
),
1957 minit (", dimension", DECL_DIMENSION
),
1958 minit (", external", DECL_EXTERNAL
),
1959 minit (", intent ( in )", DECL_IN
),
1960 minit (", intent ( out )", DECL_OUT
),
1961 minit (", intent ( in out )", DECL_INOUT
),
1962 minit (", intrinsic", DECL_INTRINSIC
),
1963 minit (", optional", DECL_OPTIONAL
),
1964 minit (", parameter", DECL_PARAMETER
),
1965 minit (", pointer", DECL_POINTER
),
1966 minit (", private", DECL_PRIVATE
),
1967 minit (", public", DECL_PUBLIC
),
1968 minit (", save", DECL_SAVE
),
1969 minit (", target", DECL_TARGET
),
1970 minit ("::", DECL_COLON
),
1971 minit (NULL
, DECL_NONE
)
1974 locus start
, seen_at
[NUM_DECL
];
1981 gfc_clear_attr (¤t_attr
);
1982 start
= gfc_current_locus
;
1987 /* See if we get all of the keywords up to the final double colon. */
1988 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1993 d
= (decl_types
) gfc_match_strings (decls
);
1994 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1997 if (gfc_current_state () == COMP_ENUM
)
1999 gfc_error ("Enumerator cannot have attributes %C");
2004 seen_at
[d
] = gfc_current_locus
;
2006 if (d
== DECL_DIMENSION
)
2008 m
= gfc_match_array_spec (¤t_as
);
2012 gfc_error ("Missing dimension specification at %C");
2016 if (m
== MATCH_ERROR
)
2021 /* If we are parsing an enumeration and have ensured that no other
2022 attributes are present we can now set the parameter attribute. */
2023 if (gfc_current_state () == COMP_ENUM
)
2025 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
2033 /* No double colon, so assume that we've been looking at something
2034 else the whole time. */
2041 /* Since we've seen a double colon, we have to be looking at an
2042 attr-spec. This means that we can now issue errors. */
2043 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2048 case DECL_ALLOCATABLE
:
2049 attr
= "ALLOCATABLE";
2051 case DECL_DIMENSION
:
2058 attr
= "INTENT (IN)";
2061 attr
= "INTENT (OUT)";
2064 attr
= "INTENT (IN OUT)";
2066 case DECL_INTRINSIC
:
2072 case DECL_PARAMETER
:
2091 attr
= NULL
; /* This shouldn't happen */
2094 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2099 /* Now that we've dealt with duplicate attributes, add the attributes
2100 to the current attribute. */
2101 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2106 if (gfc_current_state () == COMP_DERIVED
2107 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2108 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2111 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2117 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2118 && gfc_current_state () != COMP_MODULE
)
2120 if (d
== DECL_PRIVATE
)
2125 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2133 case DECL_ALLOCATABLE
:
2134 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2137 case DECL_DIMENSION
:
2138 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2142 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2146 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2150 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2154 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2157 case DECL_INTRINSIC
:
2158 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2162 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2165 case DECL_PARAMETER
:
2166 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2170 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2174 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2179 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2184 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2188 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2192 gfc_internal_error ("match_attr_spec(): Bad attribute");
2206 gfc_current_locus
= start
;
2207 gfc_free_array_spec (current_as
);
2213 /* Match a data declaration statement. */
2216 gfc_match_data_decl (void)
2222 m
= match_type_spec (¤t_ts
, 0);
2226 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2228 sym
= gfc_use_derived (current_ts
.derived
);
2236 current_ts
.derived
= sym
;
2239 m
= match_attr_spec ();
2240 if (m
== MATCH_ERROR
)
2246 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2249 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2252 gfc_find_symbol (current_ts
.derived
->name
,
2253 current_ts
.derived
->ns
->parent
, 1, &sym
);
2255 /* Any symbol that we find had better be a type definition
2256 which has its components defined. */
2257 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2258 && current_ts
.derived
->components
!= NULL
)
2261 /* Now we have an error, which we signal, and then fix up
2262 because the knock-on is plain and simple confusing. */
2263 gfc_error_now ("Derived type at %C has not been previously defined "
2264 "and so cannot appear in a derived type definition.");
2265 current_attr
.pointer
= 1;
2270 /* If we have an old-style character declaration, and no new-style
2271 attribute specifications, then there a comma is optional between
2272 the type specification and the variable list. */
2273 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2274 gfc_match_char (',');
2276 /* Give the types/attributes to symbols that follow. Give the element
2277 a number so that repeat character length expressions can be copied. */
2281 m
= variable_decl (elem
++);
2282 if (m
== MATCH_ERROR
)
2287 if (gfc_match_eos () == MATCH_YES
)
2289 if (gfc_match_char (',') != MATCH_YES
)
2293 gfc_error ("Syntax error in data declaration at %C");
2297 gfc_free_array_spec (current_as
);
2303 /* Match a prefix associated with a function or subroutine
2304 declaration. If the typespec pointer is nonnull, then a typespec
2305 can be matched. Note that if nothing matches, MATCH_YES is
2306 returned (the null string was matched). */
2309 match_prefix (gfc_typespec
* ts
)
2313 gfc_clear_attr (¤t_attr
);
2317 if (!seen_type
&& ts
!= NULL
2318 && match_type_spec (ts
, 0) == MATCH_YES
2319 && gfc_match_space () == MATCH_YES
)
2326 if (gfc_match ("elemental% ") == MATCH_YES
)
2328 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2334 if (gfc_match ("pure% ") == MATCH_YES
)
2336 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2342 if (gfc_match ("recursive% ") == MATCH_YES
)
2344 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2350 /* At this point, the next item is not a prefix. */
2355 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2358 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2361 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2364 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2367 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2374 /* Match a formal argument list. */
2377 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2379 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2380 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2386 if (gfc_match_char ('(') != MATCH_YES
)
2393 if (gfc_match_char (')') == MATCH_YES
)
2398 if (gfc_match_char ('*') == MATCH_YES
)
2402 m
= gfc_match_name (name
);
2406 if (gfc_get_symbol (name
, NULL
, &sym
))
2410 p
= gfc_get_formal_arglist ();
2422 /* We don't add the VARIABLE flavor because the name could be a
2423 dummy procedure. We don't apply these attributes to formal
2424 arguments of statement functions. */
2425 if (sym
!= NULL
&& !st_flag
2426 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2427 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2433 /* The name of a program unit can be in a different namespace,
2434 so check for it explicitly. After the statement is accepted,
2435 the name is checked for especially in gfc_get_symbol(). */
2436 if (gfc_new_block
!= NULL
&& sym
!= NULL
2437 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2439 gfc_error ("Name '%s' at %C is the name of the procedure",
2445 if (gfc_match_char (')') == MATCH_YES
)
2448 m
= gfc_match_char (',');
2451 gfc_error ("Unexpected junk in formal argument list at %C");
2457 /* Check for duplicate symbols in the formal argument list. */
2460 for (p
= head
; p
->next
; p
= p
->next
)
2465 for (q
= p
->next
; q
; q
= q
->next
)
2466 if (p
->sym
== q
->sym
)
2469 ("Duplicate symbol '%s' in formal argument list at %C",
2478 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2488 gfc_free_formal_arglist (head
);
2493 /* Match a RESULT specification following a function declaration or
2494 ENTRY statement. Also matches the end-of-statement. */
2497 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2499 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2503 if (gfc_match (" result (") != MATCH_YES
)
2506 m
= gfc_match_name (name
);
2510 if (gfc_match (" )%t") != MATCH_YES
)
2512 gfc_error ("Unexpected junk following RESULT variable at %C");
2516 if (strcmp (function
->name
, name
) == 0)
2519 ("RESULT variable at %C must be different than function name");
2523 if (gfc_get_symbol (name
, NULL
, &r
))
2526 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2527 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2536 /* Match a function declaration. */
2539 gfc_match_function_decl (void)
2541 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2542 gfc_symbol
*sym
, *result
;
2546 if (gfc_current_state () != COMP_NONE
2547 && gfc_current_state () != COMP_INTERFACE
2548 && gfc_current_state () != COMP_CONTAINS
)
2551 gfc_clear_ts (¤t_ts
);
2553 old_loc
= gfc_current_locus
;
2555 m
= match_prefix (¤t_ts
);
2558 gfc_current_locus
= old_loc
;
2562 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2564 gfc_current_locus
= old_loc
;
2568 if (get_proc_name (name
, &sym
))
2570 gfc_new_block
= sym
;
2572 m
= gfc_match_formal_arglist (sym
, 0, 0);
2575 gfc_error ("Expected formal argument list in function "
2576 "definition at %C");
2580 else if (m
== MATCH_ERROR
)
2585 if (gfc_match_eos () != MATCH_YES
)
2587 /* See if a result variable is present. */
2588 m
= match_result (sym
, &result
);
2590 gfc_error ("Unexpected junk after function declaration at %C");
2599 /* Make changes to the symbol. */
2602 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2605 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2606 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2609 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2611 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2612 gfc_basic_typename (sym
->ts
.type
));
2618 sym
->ts
= current_ts
;
2623 result
->ts
= current_ts
;
2624 sym
->result
= result
;
2630 gfc_current_locus
= old_loc
;
2634 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2635 name of the entry, rather than the gfc_current_block name, and to return false
2636 upon finding an existing global entry. */
2639 add_global_entry (const char * name
, int sub
)
2643 s
= gfc_get_gsymbol(name
);
2646 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2647 global_used(s
, NULL
);
2650 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2651 s
->where
= gfc_current_locus
;
2658 /* Match an ENTRY statement. */
2661 gfc_match_entry (void)
2666 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2667 gfc_compile_state state
;
2672 m
= gfc_match_name (name
);
2676 state
= gfc_current_state ();
2677 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2682 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2685 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2687 case COMP_BLOCK_DATA
:
2689 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2691 case COMP_INTERFACE
:
2693 ("ENTRY statement at %C cannot appear within an INTERFACE");
2697 ("ENTRY statement at %C cannot appear "
2698 "within a DERIVED TYPE block");
2702 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2706 ("ENTRY statement at %C cannot appear within a DO block");
2710 ("ENTRY statement at %C cannot appear within a SELECT block");
2714 ("ENTRY statement at %C cannot appear within a FORALL block");
2718 ("ENTRY statement at %C cannot appear within a WHERE block");
2722 ("ENTRY statement at %C cannot appear "
2723 "within a contained subprogram");
2726 gfc_internal_error ("gfc_match_entry(): Bad state");
2731 if (gfc_current_ns
->parent
!= NULL
2732 && gfc_current_ns
->parent
->proc_name
2733 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2735 gfc_error("ENTRY statement at %C cannot appear in a "
2736 "contained procedure");
2740 if (get_proc_name (name
, &entry
))
2743 proc
= gfc_current_block ();
2745 if (state
== COMP_SUBROUTINE
)
2747 /* An entry in a subroutine. */
2748 if (!add_global_entry (name
, 1))
2751 m
= gfc_match_formal_arglist (entry
, 0, 1);
2755 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2756 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2761 /* An entry in a function.
2762 We need to take special care because writing
2767 ENTRY f() RESULT (r)
2769 ENTRY f RESULT (r). */
2770 if (!add_global_entry (name
, 0))
2773 old_loc
= gfc_current_locus
;
2774 if (gfc_match_eos () == MATCH_YES
)
2776 gfc_current_locus
= old_loc
;
2777 /* Match the empty argument list, and add the interface to
2779 m
= gfc_match_formal_arglist (entry
, 0, 1);
2782 m
= gfc_match_formal_arglist (entry
, 0, 0);
2789 if (gfc_match_eos () == MATCH_YES
)
2791 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2792 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2795 entry
->result
= entry
;
2799 m
= match_result (proc
, &result
);
2801 gfc_syntax_error (ST_ENTRY
);
2805 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2806 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2807 || gfc_add_function (&entry
->attr
, result
->name
,
2811 entry
->result
= result
;
2814 if (proc
->attr
.recursive
&& result
== NULL
)
2816 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2821 if (gfc_match_eos () != MATCH_YES
)
2823 gfc_syntax_error (ST_ENTRY
);
2827 entry
->attr
.recursive
= proc
->attr
.recursive
;
2828 entry
->attr
.elemental
= proc
->attr
.elemental
;
2829 entry
->attr
.pure
= proc
->attr
.pure
;
2831 el
= gfc_get_entry_list ();
2833 el
->next
= gfc_current_ns
->entries
;
2834 gfc_current_ns
->entries
= el
;
2836 el
->id
= el
->next
->id
+ 1;
2840 new_st
.op
= EXEC_ENTRY
;
2841 new_st
.ext
.entry
= el
;
2847 /* Match a subroutine statement, including optional prefixes. */
2850 gfc_match_subroutine (void)
2852 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2856 if (gfc_current_state () != COMP_NONE
2857 && gfc_current_state () != COMP_INTERFACE
2858 && gfc_current_state () != COMP_CONTAINS
)
2861 m
= match_prefix (NULL
);
2865 m
= gfc_match ("subroutine% %n", name
);
2869 if (get_proc_name (name
, &sym
))
2871 gfc_new_block
= sym
;
2873 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2876 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2879 if (gfc_match_eos () != MATCH_YES
)
2881 gfc_syntax_error (ST_SUBROUTINE
);
2885 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2892 /* Return nonzero if we're currently compiling a contained procedure. */
2895 contained_procedure (void)
2899 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2900 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2901 && s
->previous
!= NULL
2902 && s
->previous
->state
== COMP_CONTAINS
)
2908 /* Set the kind of each enumerator. The kind is selected such that it is
2909 interoperable with the corresponding C enumeration type, making
2910 sure that -fshort-enums is honored. */
2915 enumerator_history
*current_history
= NULL
;
2919 if (max_enum
== NULL
|| enum_history
== NULL
)
2922 if (!gfc_option
.fshort_enums
)
2928 kind
= gfc_integer_kinds
[i
++].kind
;
2930 while (kind
< gfc_c_int_kind
2931 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
2934 current_history
= enum_history
;
2935 while (current_history
!= NULL
)
2937 current_history
->sym
->ts
.kind
= kind
;
2938 current_history
= current_history
->next
;
2942 /* Match any of the various end-block statements. Returns the type of
2943 END to the caller. The END INTERFACE, END IF, END DO and END
2944 SELECT statements cannot be replaced by a single END statement. */
2947 gfc_match_end (gfc_statement
* st
)
2949 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2950 gfc_compile_state state
;
2952 const char *block_name
;
2957 old_loc
= gfc_current_locus
;
2958 if (gfc_match ("end") != MATCH_YES
)
2961 state
= gfc_current_state ();
2963 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2965 if (state
== COMP_CONTAINS
)
2967 state
= gfc_state_stack
->previous
->state
;
2968 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2969 : gfc_state_stack
->previous
->sym
->name
;
2976 *st
= ST_END_PROGRAM
;
2977 target
= " program";
2981 case COMP_SUBROUTINE
:
2982 *st
= ST_END_SUBROUTINE
;
2983 target
= " subroutine";
2984 eos_ok
= !contained_procedure ();
2988 *st
= ST_END_FUNCTION
;
2989 target
= " function";
2990 eos_ok
= !contained_procedure ();
2993 case COMP_BLOCK_DATA
:
2994 *st
= ST_END_BLOCK_DATA
;
2995 target
= " block data";
3000 *st
= ST_END_MODULE
;
3005 case COMP_INTERFACE
:
3006 *st
= ST_END_INTERFACE
;
3007 target
= " interface";
3030 *st
= ST_END_SELECT
;
3036 *st
= ST_END_FORALL
;
3051 last_initializer
= NULL
;
3053 gfc_free_enum_history ();
3057 gfc_error ("Unexpected END statement at %C");
3061 if (gfc_match_eos () == MATCH_YES
)
3065 /* We would have required END [something] */
3066 gfc_error ("%s statement expected at %L",
3067 gfc_ascii_statement (*st
), &old_loc
);
3074 /* Verify that we've got the sort of end-block that we're expecting. */
3075 if (gfc_match (target
) != MATCH_YES
)
3077 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3081 /* If we're at the end, make sure a block name wasn't required. */
3082 if (gfc_match_eos () == MATCH_YES
)
3085 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3088 if (gfc_current_block () == NULL
)
3091 gfc_error ("Expected block name of '%s' in %s statement at %C",
3092 block_name
, gfc_ascii_statement (*st
));
3097 /* END INTERFACE has a special handler for its several possible endings. */
3098 if (*st
== ST_END_INTERFACE
)
3099 return gfc_match_end_interface ();
3101 /* We haven't hit the end of statement, so what is left must be an end-name. */
3102 m
= gfc_match_space ();
3104 m
= gfc_match_name (name
);
3107 gfc_error ("Expected terminating name at %C");
3111 if (block_name
== NULL
)
3114 if (strcmp (name
, block_name
) != 0)
3116 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3117 gfc_ascii_statement (*st
));
3121 if (gfc_match_eos () == MATCH_YES
)
3125 gfc_syntax_error (*st
);
3128 gfc_current_locus
= old_loc
;
3134 /***************** Attribute declaration statements ****************/
3136 /* Set the attribute of a single variable. */
3141 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3149 m
= gfc_match_name (name
);
3153 if (find_special (name
, &sym
))
3156 var_locus
= gfc_current_locus
;
3158 /* Deal with possible array specification for certain attributes. */
3159 if (current_attr
.dimension
3160 || current_attr
.allocatable
3161 || current_attr
.pointer
3162 || current_attr
.target
)
3164 m
= gfc_match_array_spec (&as
);
3165 if (m
== MATCH_ERROR
)
3168 if (current_attr
.dimension
&& m
== MATCH_NO
)
3171 ("Missing array specification at %L in DIMENSION statement",
3177 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3178 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3180 gfc_error ("Array specification must be deferred at %L",
3187 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3188 if (current_attr
.dimension
== 0
3189 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3195 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3201 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3203 /* Fix the array spec. */
3204 m
= gfc_mod_pointee_as (sym
->as
);
3205 if (m
== MATCH_ERROR
)
3209 if (gfc_add_attribute (&sym
->attr
, &var_locus
, current_attr
.intent
) == FAILURE
)
3215 if ((current_attr
.external
|| current_attr
.intrinsic
)
3216 && sym
->attr
.flavor
!= FL_PROCEDURE
3217 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3226 gfc_free_array_spec (as
);
3231 /* Generic attribute declaration subroutine. Used for attributes that
3232 just have a list of names. */
3239 /* Gobble the optional double colon, by simply ignoring the result
3249 if (gfc_match_eos () == MATCH_YES
)
3255 if (gfc_match_char (',') != MATCH_YES
)
3257 gfc_error ("Unexpected character in variable list at %C");
3267 /* This routine matches Cray Pointer declarations of the form:
3268 pointer ( <pointer>, <pointee> )
3270 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3271 The pointer, if already declared, should be an integer. Otherwise, we
3272 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3273 be either a scalar, or an array declaration. No space is allocated for
3274 the pointee. For the statement
3275 pointer (ipt, ar(10))
3276 any subsequent uses of ar will be translated (in C-notation) as
3277 ar(i) => ((<type> *) ipt)(i)
3278 After gimplification, pointee variable will disappear in the code. */
3281 cray_pointer_decl (void)
3285 gfc_symbol
*cptr
; /* Pointer symbol. */
3286 gfc_symbol
*cpte
; /* Pointee symbol. */
3292 if (gfc_match_char ('(') != MATCH_YES
)
3294 gfc_error ("Expected '(' at %C");
3298 /* Match pointer. */
3299 var_locus
= gfc_current_locus
;
3300 gfc_clear_attr (¤t_attr
);
3301 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3302 current_ts
.type
= BT_INTEGER
;
3303 current_ts
.kind
= gfc_index_integer_kind
;
3305 m
= gfc_match_symbol (&cptr
, 0);
3308 gfc_error ("Expected variable name at %C");
3312 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3315 gfc_set_sym_referenced (cptr
);
3317 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3319 cptr
->ts
.type
= BT_INTEGER
;
3320 cptr
->ts
.kind
= gfc_index_integer_kind
;
3322 else if (cptr
->ts
.type
!= BT_INTEGER
)
3324 gfc_error ("Cray pointer at %C must be an integer.");
3327 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3328 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3329 " memory addresses require %d bytes.",
3331 gfc_index_integer_kind
);
3333 if (gfc_match_char (',') != MATCH_YES
)
3335 gfc_error ("Expected \",\" at %C");
3339 /* Match Pointee. */
3340 var_locus
= gfc_current_locus
;
3341 gfc_clear_attr (¤t_attr
);
3342 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3343 current_ts
.type
= BT_UNKNOWN
;
3344 current_ts
.kind
= 0;
3346 m
= gfc_match_symbol (&cpte
, 0);
3349 gfc_error ("Expected variable name at %C");
3353 /* Check for an optional array spec. */
3354 m
= gfc_match_array_spec (&as
);
3355 if (m
== MATCH_ERROR
)
3357 gfc_free_array_spec (as
);
3360 else if (m
== MATCH_NO
)
3362 gfc_free_array_spec (as
);
3366 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3369 gfc_set_sym_referenced (cpte
);
3371 if (cpte
->as
== NULL
)
3373 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3374 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3376 else if (as
!= NULL
)
3378 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3379 gfc_free_array_spec (as
);
3385 if (cpte
->as
!= NULL
)
3387 /* Fix array spec. */
3388 m
= gfc_mod_pointee_as (cpte
->as
);
3389 if (m
== MATCH_ERROR
)
3393 /* Point the Pointee at the Pointer. */
3394 cpte
->cp_pointer
= cptr
;
3396 if (gfc_match_char (')') != MATCH_YES
)
3398 gfc_error ("Expected \")\" at %C");
3401 m
= gfc_match_char (',');
3403 done
= true; /* Stop searching for more declarations. */
3407 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3408 || gfc_match_eos () != MATCH_YES
)
3410 gfc_error ("Expected \",\" or end of statement at %C");
3418 gfc_match_external (void)
3421 gfc_clear_attr (¤t_attr
);
3422 current_attr
.external
= 1;
3424 return attr_decl ();
3430 gfc_match_intent (void)
3434 intent
= match_intent_spec ();
3435 if (intent
== INTENT_UNKNOWN
)
3438 gfc_clear_attr (¤t_attr
);
3439 current_attr
.intent
= intent
;
3441 return attr_decl ();
3446 gfc_match_intrinsic (void)
3449 gfc_clear_attr (¤t_attr
);
3450 current_attr
.intrinsic
= 1;
3452 return attr_decl ();
3457 gfc_match_optional (void)
3460 gfc_clear_attr (¤t_attr
);
3461 current_attr
.optional
= 1;
3463 return attr_decl ();
3468 gfc_match_pointer (void)
3470 gfc_gobble_whitespace ();
3471 if (gfc_peek_char () == '(')
3473 if (!gfc_option
.flag_cray_pointer
)
3475 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3479 return cray_pointer_decl ();
3483 gfc_clear_attr (¤t_attr
);
3484 current_attr
.pointer
= 1;
3486 return attr_decl ();
3492 gfc_match_allocatable (void)
3495 gfc_clear_attr (¤t_attr
);
3496 current_attr
.allocatable
= 1;
3498 return attr_decl ();
3503 gfc_match_dimension (void)
3506 gfc_clear_attr (¤t_attr
);
3507 current_attr
.dimension
= 1;
3509 return attr_decl ();
3514 gfc_match_target (void)
3517 gfc_clear_attr (¤t_attr
);
3518 current_attr
.target
= 1;
3520 return attr_decl ();
3524 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3528 access_attr_decl (gfc_statement st
)
3530 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3531 interface_type type
;
3534 gfc_intrinsic_op
operator;
3537 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3542 m
= gfc_match_generic_spec (&type
, name
, &operator);
3545 if (m
== MATCH_ERROR
)
3550 case INTERFACE_NAMELESS
:
3553 case INTERFACE_GENERIC
:
3554 if (gfc_get_symbol (name
, NULL
, &sym
))
3557 if (gfc_add_access (&sym
->attr
,
3559 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3560 sym
->name
, NULL
) == FAILURE
)
3565 case INTERFACE_INTRINSIC_OP
:
3566 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3568 gfc_current_ns
->operator_access
[operator] =
3569 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3573 gfc_error ("Access specification of the %s operator at %C has "
3574 "already been specified", gfc_op2string (operator));
3580 case INTERFACE_USER_OP
:
3581 uop
= gfc_get_uop (name
);
3583 if (uop
->access
== ACCESS_UNKNOWN
)
3586 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3591 ("Access specification of the .%s. operator at %C has "
3592 "already been specified", sym
->name
);
3599 if (gfc_match_char (',') == MATCH_NO
)
3603 if (gfc_match_eos () != MATCH_YES
)
3608 gfc_syntax_error (st
);
3615 /* The PRIVATE statement is a bit weird in that it can be a attribute
3616 declaration, but also works as a standlone statement inside of a
3617 type declaration or a module. */
3620 gfc_match_private (gfc_statement
* st
)
3623 if (gfc_match ("private") != MATCH_YES
)
3626 if (gfc_current_state () == COMP_DERIVED
)
3628 if (gfc_match_eos () == MATCH_YES
)
3634 gfc_syntax_error (ST_PRIVATE
);
3638 if (gfc_match_eos () == MATCH_YES
)
3645 return access_attr_decl (ST_PRIVATE
);
3650 gfc_match_public (gfc_statement
* st
)
3653 if (gfc_match ("public") != MATCH_YES
)
3656 if (gfc_match_eos () == MATCH_YES
)
3663 return access_attr_decl (ST_PUBLIC
);
3667 /* Workhorse for gfc_match_parameter. */
3676 m
= gfc_match_symbol (&sym
, 0);
3678 gfc_error ("Expected variable name at %C in PARAMETER statement");
3683 if (gfc_match_char ('=') == MATCH_NO
)
3685 gfc_error ("Expected = sign in PARAMETER statement at %C");
3689 m
= gfc_match_init_expr (&init
);
3691 gfc_error ("Expected expression at %C in PARAMETER statement");
3695 if (sym
->ts
.type
== BT_UNKNOWN
3696 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3702 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3703 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3709 if (sym
->ts
.type
== BT_CHARACTER
3710 && sym
->ts
.cl
!= NULL
3711 && sym
->ts
.cl
->length
!= NULL
3712 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3713 && init
->expr_type
== EXPR_CONSTANT
3714 && init
->ts
.type
== BT_CHARACTER
3715 && init
->ts
.kind
== 1)
3716 gfc_set_constant_character_len (
3717 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3723 gfc_free_expr (init
);
3728 /* Match a parameter statement, with the weird syntax that these have. */
3731 gfc_match_parameter (void)
3735 if (gfc_match_char ('(') == MATCH_NO
)
3744 if (gfc_match (" )%t") == MATCH_YES
)
3747 if (gfc_match_char (',') != MATCH_YES
)
3749 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3759 /* Save statements have a special syntax. */
3762 gfc_match_save (void)
3764 char n
[GFC_MAX_SYMBOL_LEN
+1];
3769 if (gfc_match_eos () == MATCH_YES
)
3771 if (gfc_current_ns
->seen_save
)
3773 if (gfc_notify_std (GFC_STD_LEGACY
,
3774 "Blanket SAVE statement at %C follows previous "
3780 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3784 if (gfc_current_ns
->save_all
)
3786 if (gfc_notify_std (GFC_STD_LEGACY
,
3787 "SAVE statement at %C follows blanket SAVE statement")
3796 m
= gfc_match_symbol (&sym
, 0);
3800 if (gfc_add_save (&sym
->attr
, sym
->name
,
3801 &gfc_current_locus
) == FAILURE
)
3812 m
= gfc_match (" / %n /", &n
);
3813 if (m
== MATCH_ERROR
)
3818 c
= gfc_get_common (n
, 0);
3821 gfc_current_ns
->seen_save
= 1;
3824 if (gfc_match_eos () == MATCH_YES
)
3826 if (gfc_match_char (',') != MATCH_YES
)
3833 gfc_error ("Syntax error in SAVE statement at %C");
3838 /* Match a module procedure statement. Note that we have to modify
3839 symbols in the parent's namespace because the current one was there
3840 to receive symbols that are in an interface's formal argument list. */
3843 gfc_match_modproc (void)
3845 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3849 if (gfc_state_stack
->state
!= COMP_INTERFACE
3850 || gfc_state_stack
->previous
== NULL
3851 || current_interface
.type
== INTERFACE_NAMELESS
)
3854 ("MODULE PROCEDURE at %C must be in a generic module interface");
3860 m
= gfc_match_name (name
);
3866 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3869 if (sym
->attr
.proc
!= PROC_MODULE
3870 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3871 sym
->name
, NULL
) == FAILURE
)
3874 if (gfc_add_interface (sym
) == FAILURE
)
3877 if (gfc_match_eos () == MATCH_YES
)
3879 if (gfc_match_char (',') != MATCH_YES
)
3886 gfc_syntax_error (ST_MODULE_PROC
);
3891 /* Match the beginning of a derived type declaration. If a type name
3892 was the result of a function, then it is possible to have a symbol
3893 already to be known as a derived type yet have no components. */
3896 gfc_match_derived_decl (void)
3898 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3899 symbol_attribute attr
;
3903 if (gfc_current_state () == COMP_DERIVED
)
3906 gfc_clear_attr (&attr
);
3909 if (gfc_match (" , private") == MATCH_YES
)
3911 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3914 ("Derived type at %C can only be PRIVATE within a MODULE");
3918 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3923 if (gfc_match (" , public") == MATCH_YES
)
3925 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3927 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3931 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3936 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3938 gfc_error ("Expected :: in TYPE definition at %C");
3942 m
= gfc_match (" %n%t", name
);
3946 /* Make sure the name isn't the name of an intrinsic type. The
3947 'double precision' type doesn't get past the name matcher. */
3948 if (strcmp (name
, "integer") == 0
3949 || strcmp (name
, "real") == 0
3950 || strcmp (name
, "character") == 0
3951 || strcmp (name
, "logical") == 0
3952 || strcmp (name
, "complex") == 0)
3955 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3960 if (gfc_get_symbol (name
, NULL
, &sym
))
3963 if (sym
->ts
.type
!= BT_UNKNOWN
)
3965 gfc_error ("Derived type name '%s' at %C already has a basic type "
3966 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3970 /* The symbol may already have the derived attribute without the
3971 components. The ways this can happen is via a function
3972 definition, an INTRINSIC statement or a subtype in another
3973 derived type that is a pointer. The first part of the AND clause
3974 is true if a the symbol is not the return value of a function. */
3975 if (sym
->attr
.flavor
!= FL_DERIVED
3976 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3979 if (sym
->components
!= NULL
)
3982 ("Derived type definition of '%s' at %C has already been defined",
3987 if (attr
.access
!= ACCESS_UNKNOWN
3988 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3991 gfc_new_block
= sym
;
3997 /* Cray Pointees can be declared as:
3998 pointer (ipt, a (n,m,...,*))
3999 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4000 cheat and set a constant bound of 1 for the last dimension, if this
4001 is the case. Since there is no bounds-checking for Cray Pointees,
4002 this will be okay. */
4005 gfc_mod_pointee_as (gfc_array_spec
*as
)
4007 as
->cray_pointee
= true; /* This will be useful to know later. */
4008 if (as
->type
== AS_ASSUMED_SIZE
)
4010 as
->type
= AS_EXPLICIT
;
4011 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4012 as
->cp_was_assumed
= true;
4014 else if (as
->type
== AS_ASSUMED_SHAPE
)
4016 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4023 /* Match the enum definition statement, here we are trying to match
4024 the first line of enum definition statement.
4025 Returns MATCH_YES if match is found. */
4028 gfc_match_enum (void)
4032 m
= gfc_match_eos ();
4036 if (gfc_notify_std (GFC_STD_F2003
,
4037 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
4045 /* Match the enumerator definition statement. */
4048 gfc_match_enumerator_def (void)
4053 gfc_clear_ts (¤t_ts
);
4055 m
= gfc_match (" enumerator");
4059 if (gfc_current_state () != COMP_ENUM
)
4061 gfc_error ("ENUM definition statement expected before %C");
4062 gfc_free_enum_history ();
4066 (¤t_ts
)->type
= BT_INTEGER
;
4067 (¤t_ts
)->kind
= gfc_c_int_kind
;
4069 m
= match_attr_spec ();
4070 if (m
== MATCH_ERROR
)
4079 m
= variable_decl (elem
++);
4080 if (m
== MATCH_ERROR
)
4085 if (gfc_match_eos () == MATCH_YES
)
4087 if (gfc_match_char (',') != MATCH_YES
)
4091 if (gfc_current_state () == COMP_ENUM
)
4093 gfc_free_enum_history ();
4094 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4099 gfc_free_array_spec (current_as
);