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 /* Free all data in a namespace. */
133 gfc_free_data_all (gfc_namespace
* ns
)
146 static match
var_element (gfc_data_variable
*);
148 /* Match a list of variables terminated by an iterator and a right
152 var_list (gfc_data_variable
* parent
)
154 gfc_data_variable
*tail
, var
;
157 m
= var_element (&var
);
158 if (m
== MATCH_ERROR
)
163 tail
= gfc_get_data_variable ();
170 if (gfc_match_char (',') != MATCH_YES
)
173 m
= gfc_match_iterator (&parent
->iter
, 1);
176 if (m
== MATCH_ERROR
)
179 m
= var_element (&var
);
180 if (m
== MATCH_ERROR
)
185 tail
->next
= gfc_get_data_variable ();
191 if (gfc_match_char (')') != MATCH_YES
)
196 gfc_syntax_error (ST_DATA
);
201 /* Match a single element in a data variable list, which can be a
202 variable-iterator list. */
205 var_element (gfc_data_variable
* new)
210 memset (new, 0, sizeof (gfc_data_variable
));
212 if (gfc_match_char ('(') == MATCH_YES
)
213 return var_list (new);
215 m
= gfc_match_variable (&new->expr
, 0);
219 sym
= new->expr
->symtree
->n
.sym
;
221 if (!sym
->attr
.function
&& gfc_current_ns
->parent
&& gfc_current_ns
->parent
== sym
->ns
)
223 gfc_error ("Host associated variable '%s' may not be in the DATA "
224 "statement at %C", sym
->name
);
228 if (gfc_current_state () != COMP_BLOCK_DATA
229 && sym
->attr
.in_common
230 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
231 "common block variable '%s' in DATA statement at %C",
232 sym
->name
) == FAILURE
)
235 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
242 /* Match the top-level list of data variables. */
245 top_var_list (gfc_data
* d
)
247 gfc_data_variable var
, *tail
, *new;
254 m
= var_element (&var
);
257 if (m
== MATCH_ERROR
)
260 new = gfc_get_data_variable ();
270 if (gfc_match_char ('/') == MATCH_YES
)
272 if (gfc_match_char (',') != MATCH_YES
)
279 gfc_syntax_error (ST_DATA
);
280 gfc_free_data_all (gfc_current_ns
);
286 match_data_constant (gfc_expr
** result
)
288 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
293 m
= gfc_match_literal_constant (&expr
, 1);
300 if (m
== MATCH_ERROR
)
303 m
= gfc_match_null (result
);
307 m
= gfc_match_name (name
);
311 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
315 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
317 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
321 else if (sym
->attr
.flavor
== FL_DERIVED
)
322 return gfc_match_structure_constructor (sym
, result
);
324 *result
= gfc_copy_expr (sym
->value
);
329 /* Match a list of values in a DATA statement. The leading '/' has
330 already been seen at this point. */
333 top_val_list (gfc_data
* data
)
335 gfc_data_value
*new, *tail
;
344 m
= match_data_constant (&expr
);
347 if (m
== MATCH_ERROR
)
350 new = gfc_get_data_value ();
359 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
367 msg
= gfc_extract_int (expr
, &tmp
);
368 gfc_free_expr (expr
);
376 m
= match_data_constant (&tail
->expr
);
379 if (m
== MATCH_ERROR
)
383 if (gfc_match_char ('/') == MATCH_YES
)
385 if (gfc_match_char (',') == MATCH_NO
)
392 gfc_syntax_error (ST_DATA
);
393 gfc_free_data_all (gfc_current_ns
);
398 /* Matches an old style initialization. */
401 match_old_style_init (const char *name
)
408 /* Set up data structure to hold initializers. */
409 gfc_find_sym_tree (name
, NULL
, 0, &st
);
412 newdata
= gfc_get_data ();
413 newdata
->var
= gfc_get_data_variable ();
414 newdata
->var
->expr
= gfc_get_variable_expr (st
);
415 newdata
->where
= gfc_current_locus
;
417 /* Match initial value list. This also eats the terminal
419 m
= top_val_list (newdata
);
428 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
433 /* Mark the variable as having appeared in a data statement. */
434 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
440 /* Chain in namespace list of DATA initializers. */
441 newdata
->next
= gfc_current_ns
->data
;
442 gfc_current_ns
->data
= newdata
;
447 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
448 we are matching a DATA statement and are therefore issuing an error
449 if we encounter something unexpected, if not, we're trying to match
450 an old-style initialization expression of the form INTEGER I /2/. */
453 gfc_match_data (void)
460 new = gfc_get_data ();
461 new->where
= gfc_current_locus
;
463 m
= top_var_list (new);
467 m
= top_val_list (new);
471 new->next
= gfc_current_ns
->data
;
472 gfc_current_ns
->data
= new;
474 if (gfc_match_eos () == MATCH_YES
)
477 gfc_match_char (','); /* Optional comma */
482 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
494 /************************ Declaration statements *********************/
496 /* Match an intent specification. Since this can only happen after an
497 INTENT word, a legal intent-spec must follow. */
500 match_intent_spec (void)
503 if (gfc_match (" ( in out )") == MATCH_YES
)
505 if (gfc_match (" ( in )") == MATCH_YES
)
507 if (gfc_match (" ( out )") == MATCH_YES
)
510 gfc_error ("Bad INTENT specification at %C");
511 return INTENT_UNKNOWN
;
515 /* Matches a character length specification, which is either a
516 specification expression or a '*'. */
519 char_len_param_value (gfc_expr
** expr
)
522 if (gfc_match_char ('*') == MATCH_YES
)
528 return gfc_match_expr (expr
);
532 /* A character length is a '*' followed by a literal integer or a
533 char_len_param_value in parenthesis. */
536 match_char_length (gfc_expr
** expr
)
541 m
= gfc_match_char ('*');
545 m
= gfc_match_small_literal_int (&length
, NULL
);
546 if (m
== MATCH_ERROR
)
551 *expr
= gfc_int_expr (length
);
555 if (gfc_match_char ('(') == MATCH_NO
)
558 m
= char_len_param_value (expr
);
559 if (m
== MATCH_ERROR
)
564 if (gfc_match_char (')') == MATCH_NO
)
566 gfc_free_expr (*expr
);
574 gfc_error ("Syntax error in character length specification at %C");
579 /* Special subroutine for finding a symbol. Check if the name is found
580 in the current name space. If not, and we're compiling a function or
581 subroutine and the parent compilation unit is an interface, then check
582 to see if the name we've been given is the name of the interface
583 (located in another namespace). */
586 find_special (const char *name
, gfc_symbol
** result
)
591 i
= gfc_get_symbol (name
, NULL
, result
);
595 if (gfc_current_state () != COMP_SUBROUTINE
596 && gfc_current_state () != COMP_FUNCTION
)
599 s
= gfc_state_stack
->previous
;
603 if (s
->state
!= COMP_INTERFACE
)
606 goto end
; /* Nameless interface */
608 if (strcmp (name
, s
->sym
->name
) == 0)
619 /* Special subroutine for getting a symbol node associated with a
620 procedure name, used in SUBROUTINE and FUNCTION statements. The
621 symbol is created in the parent using with symtree node in the
622 child unit pointing to the symbol. If the current namespace has no
623 parent, then the symbol is just created in the current unit. */
626 get_proc_name (const char *name
, gfc_symbol
** result
,
627 bool module_fcn_entry
)
633 /* Module functions have to be left in their own namespace because
634 they have potentially (almost certainly!) already been referenced.
635 In this sense, they are rather like external functions. This is
636 fixed up in resolve.c(resolve_entries), where the symbol name-
637 space is set to point to the master function, so that the fake
638 result mechanism can work. */
639 if (module_fcn_entry
)
640 rc
= gfc_get_symbol (name
, NULL
, result
);
642 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
645 gfc_current_ns
->refs
++;
647 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
649 /* Trap another encompassed procedure with the same name. All
650 these conditions are necessary to avoid picking up an entry
651 whose name clashes with that of the encompassing procedure;
652 this is handled using gsymbols to register unique,globally
654 if (sym
->attr
.flavor
!= 0
655 && sym
->attr
.proc
!= 0
656 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
657 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
658 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
659 name
, &sym
->declared_at
);
661 /* Trap declarations of attributes in encompassing scope. The
662 signature for this is that ts.kind is set. Legitimate
663 references only set ts.type. */
664 if (sym
->ts
.kind
!= 0
665 && !sym
->attr
.implicit_type
666 && sym
->attr
.proc
== 0
667 && gfc_current_ns
->parent
!= NULL
668 && sym
->attr
.access
== 0
669 && !module_fcn_entry
)
670 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
671 " and must not have attributes declared at %L",
672 name
, &sym
->declared_at
);
675 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
678 /* Module function entries will already have a symtree in
679 the current namespace but will need one at module level. */
680 if (module_fcn_entry
)
681 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
683 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
688 /* See if the procedure should be a module procedure */
690 if (((sym
->ns
->proc_name
!= NULL
691 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
692 && sym
->attr
.proc
!= PROC_MODULE
) || module_fcn_entry
)
693 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
694 sym
->name
, NULL
) == FAILURE
)
701 /* Function called by variable_decl() that adds a name to the symbol
705 build_sym (const char *name
, gfc_charlen
* cl
,
706 gfc_array_spec
** as
, locus
* var_locus
)
708 symbol_attribute attr
;
711 /* if (find_special (name, &sym)) */
712 if (gfc_get_symbol (name
, NULL
, &sym
))
715 /* Start updating the symbol table. Add basic type attribute
717 if (current_ts
.type
!= BT_UNKNOWN
718 &&(sym
->attr
.implicit_type
== 0
719 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
720 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
723 if (sym
->ts
.type
== BT_CHARACTER
)
726 /* Add dimension attribute if present. */
727 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
731 /* Add attribute to symbol. The copy is so that we can reset the
732 dimension attribute. */
736 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
742 /* Set character constant to the given length. The constant will be padded or
746 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
751 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
752 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
754 slen
= expr
->value
.character
.length
;
757 s
= gfc_getmem (len
+ 1);
758 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
760 memset (&s
[slen
], ' ', len
- slen
);
762 gfc_free (expr
->value
.character
.string
);
763 expr
->value
.character
.string
= s
;
764 expr
->value
.character
.length
= len
;
769 /* Function to create and update the enumerator history
770 using the information passed as arguments.
771 Pointer "max_enum" is also updated, to point to
772 enum history node containing largest initializer.
774 SYM points to the symbol node of enumerator.
775 INIT points to its enumerator value. */
778 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
780 enumerator_history
*new_enum_history
;
781 gcc_assert (sym
!= NULL
&& init
!= NULL
);
783 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
785 new_enum_history
->sym
= sym
;
786 new_enum_history
->initializer
= init
;
787 new_enum_history
->next
= NULL
;
789 if (enum_history
== NULL
)
791 enum_history
= new_enum_history
;
792 max_enum
= enum_history
;
796 new_enum_history
->next
= enum_history
;
797 enum_history
= new_enum_history
;
799 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
800 new_enum_history
->initializer
->value
.integer
) < 0)
801 max_enum
= new_enum_history
;
806 /* Function to free enum kind history. */
809 gfc_free_enum_history(void)
811 enumerator_history
*current
= enum_history
;
812 enumerator_history
*next
;
814 while (current
!= NULL
)
816 next
= current
->next
;
825 /* Function called by variable_decl() that adds an initialization
826 expression to a symbol. */
829 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
832 symbol_attribute attr
;
837 if (find_special (name
, &sym
))
842 /* If this symbol is confirming an implicit parameter type,
843 then an initialization expression is not allowed. */
844 if (attr
.flavor
== FL_PARAMETER
845 && sym
->value
!= NULL
848 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
857 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
864 /* An initializer is required for PARAMETER declarations. */
865 if (attr
.flavor
== FL_PARAMETER
)
867 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
873 /* If a variable appears in a DATA block, it cannot have an
878 ("Variable '%s' at %C with an initializer already appears "
879 "in a DATA statement", sym
->name
);
883 /* Check if the assignment can happen. This has to be put off
884 until later for a derived type variable. */
885 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
886 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
889 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
891 /* Update symbol character length according initializer. */
892 if (sym
->ts
.cl
->length
== NULL
)
894 /* If there are multiple CHARACTER variables declared on
895 the same line, we don't want them to share the same
897 sym
->ts
.cl
= gfc_get_charlen ();
898 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
899 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
901 if (sym
->attr
.flavor
== FL_PARAMETER
902 && init
->expr_type
== EXPR_ARRAY
)
903 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
905 /* Update initializer character length according symbol. */
906 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
908 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
911 if (init
->expr_type
== EXPR_CONSTANT
)
912 gfc_set_constant_character_len (len
, init
);
913 else if (init
->expr_type
== EXPR_ARRAY
)
915 gfc_free_expr (init
->ts
.cl
->length
);
916 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
917 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
918 gfc_set_constant_character_len (len
, p
->expr
);
923 /* Add initializer. Make sure we keep the ranks sane. */
924 if (sym
->attr
.dimension
&& init
->rank
== 0)
925 init
->rank
= sym
->as
->rank
;
931 /* Maintain enumerator history. */
932 if (gfc_current_state () == COMP_ENUM
)
933 create_enum_history (sym
, init
);
939 /* Function called by variable_decl() that adds a name to a structure
943 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
944 gfc_array_spec
** as
)
948 /* If the current symbol is of the same derived type that we're
949 constructing, it must have the pointer attribute. */
950 if (current_ts
.type
== BT_DERIVED
951 && current_ts
.derived
== gfc_current_block ()
952 && current_attr
.pointer
== 0)
954 gfc_error ("Component at %C must have the POINTER attribute");
958 if (gfc_current_block ()->attr
.pointer
961 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
963 gfc_error ("Array component of structure at %C must have explicit "
964 "or deferred shape");
969 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
974 gfc_set_component_attr (c
, ¤t_attr
);
976 c
->initializer
= *init
;
984 /* Check array components. */
989 gfc_error ("Allocatable component at %C must be an array");
998 if (c
->as
->type
!= AS_DEFERRED
)
1000 gfc_error ("Pointer array component of structure at %C must have a "
1005 else if (c
->allocatable
)
1007 if (c
->as
->type
!= AS_DEFERRED
)
1009 gfc_error ("Allocatable component of structure at %C must have a "
1016 if (c
->as
->type
!= AS_EXPLICIT
)
1019 ("Array component of structure at %C must have an explicit "
1029 /* Match a 'NULL()', and possibly take care of some side effects. */
1032 gfc_match_null (gfc_expr
** result
)
1038 m
= gfc_match (" null ( )");
1042 /* The NULL symbol now has to be/become an intrinsic function. */
1043 if (gfc_get_symbol ("null", NULL
, &sym
))
1045 gfc_error ("NULL() initialization at %C is ambiguous");
1049 gfc_intrinsic_symbol (sym
);
1051 if (sym
->attr
.proc
!= PROC_INTRINSIC
1052 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1053 sym
->name
, NULL
) == FAILURE
1054 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1057 e
= gfc_get_expr ();
1058 e
->where
= gfc_current_locus
;
1059 e
->expr_type
= EXPR_NULL
;
1060 e
->ts
.type
= BT_UNKNOWN
;
1068 /* Match a variable name with an optional initializer. When this
1069 subroutine is called, a variable is expected to be parsed next.
1070 Depending on what is happening at the moment, updates either the
1071 symbol table or the current interface. */
1074 variable_decl (int elem
)
1076 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1077 gfc_expr
*initializer
, *char_len
;
1079 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1090 old_locus
= gfc_current_locus
;
1092 /* When we get here, we've just matched a list of attributes and
1093 maybe a type and a double colon. The next thing we expect to see
1094 is the name of the symbol. */
1095 m
= gfc_match_name (name
);
1099 var_locus
= gfc_current_locus
;
1101 /* Now we could see the optional array spec. or character length. */
1102 m
= gfc_match_array_spec (&as
);
1103 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1104 cp_as
= gfc_copy_array_spec (as
);
1105 else if (m
== MATCH_ERROR
)
1109 as
= gfc_copy_array_spec (current_as
);
1110 else if (gfc_current_state () == COMP_ENUM
)
1112 gfc_error ("Enumerator cannot be array at %C");
1113 gfc_free_enum_history ();
1122 if (current_ts
.type
== BT_CHARACTER
)
1124 switch (match_char_length (&char_len
))
1127 cl
= gfc_get_charlen ();
1128 cl
->next
= gfc_current_ns
->cl_list
;
1129 gfc_current_ns
->cl_list
= cl
;
1131 cl
->length
= char_len
;
1134 /* Non-constant lengths need to be copied after the first
1137 if (elem
> 1 && current_ts
.cl
->length
1138 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1140 cl
= gfc_get_charlen ();
1141 cl
->next
= gfc_current_ns
->cl_list
;
1142 gfc_current_ns
->cl_list
= cl
;
1143 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1155 /* If this symbol has already shown up in a Cray Pointer declaration,
1156 then we want to set the type & bail out. */
1157 if (gfc_option
.flag_cray_pointer
)
1159 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1160 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1162 sym
->ts
.type
= current_ts
.type
;
1163 sym
->ts
.kind
= current_ts
.kind
;
1165 sym
->ts
.derived
= current_ts
.derived
;
1168 /* Check to see if we have an array specification. */
1171 if (sym
->as
!= NULL
)
1173 gfc_error ("Duplicate array spec for Cray pointee at %C");
1174 gfc_free_array_spec (cp_as
);
1180 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1181 gfc_internal_error ("Couldn't set pointee array spec.");
1183 /* Fix the array spec. */
1184 m
= gfc_mod_pointee_as (sym
->as
);
1185 if (m
== MATCH_ERROR
)
1193 gfc_free_array_spec (cp_as
);
1198 /* OK, we've successfully matched the declaration. Now put the
1199 symbol in the current namespace, because it might be used in the
1200 optional initialization expression for this symbol, e.g. this is
1203 integer, parameter :: i = huge(i)
1205 This is only true for parameters or variables of a basic type.
1206 For components of derived types, it is not true, so we don't
1207 create a symbol for those yet. If we fail to create the symbol,
1209 if (gfc_current_state () != COMP_DERIVED
1210 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1216 /* An interface body specifies all of the procedure's characteristics and these
1217 shall be consistent with those specified in the procedure definition, except
1218 that the interface may specify a procedure that is not pure if the procedure
1219 is defined to be pure(12.3.2). */
1220 if (current_ts
.type
== BT_DERIVED
1221 && gfc_current_ns
->proc_name
1222 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1223 && current_ts
.derived
->ns
!= gfc_current_ns
1224 && !gfc_current_ns
->has_import_set
)
1226 gfc_error ("the type of '%s' at %C has not been declared within the "
1232 /* In functions that have a RESULT variable defined, the function
1233 name always refers to function calls. Therefore, the name is
1234 not allowed to appear in specification statements. */
1235 if (gfc_current_state () == COMP_FUNCTION
1236 && gfc_current_block () != NULL
1237 && gfc_current_block ()->result
!= NULL
1238 && gfc_current_block ()->result
!= gfc_current_block ()
1239 && strcmp (gfc_current_block ()->name
, name
) == 0)
1241 gfc_error ("Function name '%s' not allowed at %C", name
);
1246 /* We allow old-style initializations of the form
1247 integer i /2/, j(4) /3*3, 1/
1248 (if no colon has been seen). These are different from data
1249 statements in that initializers are only allowed to apply to the
1250 variable immediately preceding, i.e.
1252 is not allowed. Therefore we have to do some work manually, that
1253 could otherwise be left to the matchers for DATA statements. */
1255 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1257 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1258 "initialization at %C") == FAILURE
)
1261 return match_old_style_init (name
);
1264 /* The double colon must be present in order to have initializers.
1265 Otherwise the statement is ambiguous with an assignment statement. */
1268 if (gfc_match (" =>") == MATCH_YES
)
1271 if (!current_attr
.pointer
)
1273 gfc_error ("Initialization at %C isn't for a pointer variable");
1278 m
= gfc_match_null (&initializer
);
1281 gfc_error ("Pointer initialization requires a NULL() at %C");
1285 if (gfc_pure (NULL
))
1288 ("Initialization of pointer at %C is not allowed in a "
1297 else if (gfc_match_char ('=') == MATCH_YES
)
1299 if (current_attr
.pointer
)
1302 ("Pointer initialization at %C requires '=>', not '='");
1307 m
= gfc_match_init_expr (&initializer
);
1310 gfc_error ("Expected an initialization expression at %C");
1314 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1317 ("Initialization of variable at %C is not allowed in a "
1327 if (initializer
!= NULL
&& current_attr
.allocatable
1328 && gfc_current_state () == COMP_DERIVED
)
1330 gfc_error ("Initialization of allocatable component at %C is not allowed");
1335 /* Check if we are parsing an enumeration and if the current enumerator
1336 variable has an initializer or not. If it does not have an
1337 initializer, the initialization value of the previous enumerator
1338 (stored in last_initializer) is incremented by 1 and is used to
1339 initialize the current enumerator. */
1340 if (gfc_current_state () == COMP_ENUM
)
1342 if (initializer
== NULL
)
1343 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1345 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1347 gfc_error("ENUMERATOR %L not initialized with integer expression",
1350 gfc_free_enum_history ();
1354 /* Store this current initializer, for the next enumerator
1355 variable to be parsed. */
1356 last_initializer
= initializer
;
1359 /* Add the initializer. Note that it is fine if initializer is
1360 NULL here, because we sometimes also need to check if a
1361 declaration *must* have an initialization expression. */
1362 if (gfc_current_state () != COMP_DERIVED
)
1363 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1366 if (current_ts
.type
== BT_DERIVED
1367 && !current_attr
.pointer
1369 initializer
= gfc_default_initializer (¤t_ts
);
1370 t
= build_struct (name
, cl
, &initializer
, &as
);
1373 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1376 /* Free stuff up and return. */
1377 gfc_free_expr (initializer
);
1378 gfc_free_array_spec (as
);
1384 /* Match an extended-f77 kind specification. */
1387 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1392 if (gfc_match_char ('*') != MATCH_YES
)
1395 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1399 original_kind
= ts
->kind
;
1401 /* Massage the kind numbers for complex types. */
1402 if (ts
->type
== BT_COMPLEX
)
1406 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1407 gfc_basic_typename (ts
->type
), original_kind
);
1413 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1415 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1416 gfc_basic_typename (ts
->type
), original_kind
);
1420 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1421 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1428 /* Match a kind specification. Since kinds are generally optional, we
1429 usually return MATCH_NO if something goes wrong. If a "kind="
1430 string is found, then we know we have an error. */
1433 gfc_match_kind_spec (gfc_typespec
* ts
)
1443 where
= gfc_current_locus
;
1445 if (gfc_match_char ('(') == MATCH_NO
)
1448 /* Also gobbles optional text. */
1449 if (gfc_match (" kind = ") == MATCH_YES
)
1452 n
= gfc_match_init_expr (&e
);
1454 gfc_error ("Expected initialization expression at %C");
1460 gfc_error ("Expected scalar initialization expression at %C");
1465 msg
= gfc_extract_int (e
, &ts
->kind
);
1476 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1478 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1479 gfc_basic_typename (ts
->type
));
1485 if (gfc_match_char (')') != MATCH_YES
)
1487 gfc_error ("Missing right parenthesis at %C");
1495 gfc_current_locus
= where
;
1500 /* Match the various kind/length specifications in a CHARACTER
1501 declaration. We don't return MATCH_NO. */
1504 match_char_spec (gfc_typespec
* ts
)
1506 int i
, kind
, seen_length
;
1511 kind
= gfc_default_character_kind
;
1515 /* Try the old-style specification first. */
1516 old_char_selector
= 0;
1518 m
= match_char_length (&len
);
1522 old_char_selector
= 1;
1527 m
= gfc_match_char ('(');
1530 m
= MATCH_YES
; /* character without length is a single char */
1534 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1535 if (gfc_match (" kind =") == MATCH_YES
)
1537 m
= gfc_match_small_int (&kind
);
1538 if (m
== MATCH_ERROR
)
1543 if (gfc_match (" , len =") == MATCH_NO
)
1546 m
= char_len_param_value (&len
);
1549 if (m
== MATCH_ERROR
)
1556 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1557 if (gfc_match (" len =") == MATCH_YES
)
1559 m
= char_len_param_value (&len
);
1562 if (m
== MATCH_ERROR
)
1566 if (gfc_match_char (')') == MATCH_YES
)
1569 if (gfc_match (" , kind =") != MATCH_YES
)
1572 gfc_match_small_int (&kind
);
1574 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1576 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1583 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1584 m
= char_len_param_value (&len
);
1587 if (m
== MATCH_ERROR
)
1591 m
= gfc_match_char (')');
1595 if (gfc_match_char (',') != MATCH_YES
)
1598 gfc_match (" kind ="); /* Gobble optional text */
1600 m
= gfc_match_small_int (&kind
);
1601 if (m
== MATCH_ERROR
)
1607 /* Require a right-paren at this point. */
1608 m
= gfc_match_char (')');
1613 gfc_error ("Syntax error in CHARACTER declaration at %C");
1617 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1619 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1625 gfc_free_expr (len
);
1629 /* Do some final massaging of the length values. */
1630 cl
= gfc_get_charlen ();
1631 cl
->next
= gfc_current_ns
->cl_list
;
1632 gfc_current_ns
->cl_list
= cl
;
1634 if (seen_length
== 0)
1635 cl
->length
= gfc_int_expr (1);
1638 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1642 gfc_free_expr (len
);
1643 cl
->length
= gfc_int_expr (0);
1654 /* Matches a type specification. If successful, sets the ts structure
1655 to the matched specification. This is necessary for FUNCTION and
1656 IMPLICIT statements.
1658 If implicit_flag is nonzero, then we don't check for the optional
1659 kind specification. Not doing so is needed for matching an IMPLICIT
1660 statement correctly. */
1663 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1665 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1672 if (gfc_match (" byte") == MATCH_YES
)
1674 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1678 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1680 gfc_error ("BYTE type used at %C "
1681 "is not available on the target machine");
1685 ts
->type
= BT_INTEGER
;
1690 if (gfc_match (" integer") == MATCH_YES
)
1692 ts
->type
= BT_INTEGER
;
1693 ts
->kind
= gfc_default_integer_kind
;
1697 if (gfc_match (" character") == MATCH_YES
)
1699 ts
->type
= BT_CHARACTER
;
1700 if (implicit_flag
== 0)
1701 return match_char_spec (ts
);
1706 if (gfc_match (" real") == MATCH_YES
)
1709 ts
->kind
= gfc_default_real_kind
;
1713 if (gfc_match (" double precision") == MATCH_YES
)
1716 ts
->kind
= gfc_default_double_kind
;
1720 if (gfc_match (" complex") == MATCH_YES
)
1722 ts
->type
= BT_COMPLEX
;
1723 ts
->kind
= gfc_default_complex_kind
;
1727 if (gfc_match (" double complex") == MATCH_YES
)
1729 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1730 "conform to the Fortran 95 standard") == FAILURE
)
1733 ts
->type
= BT_COMPLEX
;
1734 ts
->kind
= gfc_default_double_kind
;
1738 if (gfc_match (" logical") == MATCH_YES
)
1740 ts
->type
= BT_LOGICAL
;
1741 ts
->kind
= gfc_default_logical_kind
;
1745 m
= gfc_match (" type ( %n )", name
);
1749 /* Search for the name but allow the components to be defined later. */
1750 if (gfc_get_ha_symbol (name
, &sym
))
1752 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1756 if (sym
->attr
.flavor
!= FL_DERIVED
1757 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1760 ts
->type
= BT_DERIVED
;
1767 /* For all types except double, derived and character, look for an
1768 optional kind specifier. MATCH_NO is actually OK at this point. */
1769 if (implicit_flag
== 1)
1772 if (gfc_current_form
== FORM_FREE
)
1774 c
= gfc_peek_char();
1775 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1776 && c
!= ':' && c
!= ',')
1780 m
= gfc_match_kind_spec (ts
);
1781 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1782 m
= gfc_match_old_kind_spec (ts
);
1785 m
= MATCH_YES
; /* No kind specifier found. */
1791 /* Match an IMPLICIT NONE statement. Actually, this statement is
1792 already matched in parse.c, or we would not end up here in the
1793 first place. So the only thing we need to check, is if there is
1794 trailing garbage. If not, the match is successful. */
1797 gfc_match_implicit_none (void)
1800 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1804 /* Match the letter range(s) of an IMPLICIT statement. */
1807 match_implicit_range (void)
1809 int c
, c1
, c2
, inner
;
1812 cur_loc
= gfc_current_locus
;
1814 gfc_gobble_whitespace ();
1815 c
= gfc_next_char ();
1818 gfc_error ("Missing character range in IMPLICIT at %C");
1825 gfc_gobble_whitespace ();
1826 c1
= gfc_next_char ();
1830 gfc_gobble_whitespace ();
1831 c
= gfc_next_char ();
1836 inner
= 0; /* Fall through */
1843 gfc_gobble_whitespace ();
1844 c2
= gfc_next_char ();
1848 gfc_gobble_whitespace ();
1849 c
= gfc_next_char ();
1851 if ((c
!= ',') && (c
!= ')'))
1864 gfc_error ("Letters must be in alphabetic order in "
1865 "IMPLICIT statement at %C");
1869 /* See if we can add the newly matched range to the pending
1870 implicits from this IMPLICIT statement. We do not check for
1871 conflicts with whatever earlier IMPLICIT statements may have
1872 set. This is done when we've successfully finished matching
1874 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1881 gfc_syntax_error (ST_IMPLICIT
);
1883 gfc_current_locus
= cur_loc
;
1888 /* Match an IMPLICIT statement, storing the types for
1889 gfc_set_implicit() if the statement is accepted by the parser.
1890 There is a strange looking, but legal syntactic construction
1891 possible. It looks like:
1893 IMPLICIT INTEGER (a-b) (c-d)
1895 This is legal if "a-b" is a constant expression that happens to
1896 equal one of the legal kinds for integers. The real problem
1897 happens with an implicit specification that looks like:
1899 IMPLICIT INTEGER (a-b)
1901 In this case, a typespec matcher that is "greedy" (as most of the
1902 matchers are) gobbles the character range as a kindspec, leaving
1903 nothing left. We therefore have to go a bit more slowly in the
1904 matching process by inhibiting the kindspec checking during
1905 typespec matching and checking for a kind later. */
1908 gfc_match_implicit (void)
1915 /* We don't allow empty implicit statements. */
1916 if (gfc_match_eos () == MATCH_YES
)
1918 gfc_error ("Empty IMPLICIT statement at %C");
1924 /* First cleanup. */
1925 gfc_clear_new_implicit ();
1927 /* A basic type is mandatory here. */
1928 m
= match_type_spec (&ts
, 1);
1929 if (m
== MATCH_ERROR
)
1934 cur_loc
= gfc_current_locus
;
1935 m
= match_implicit_range ();
1939 /* We may have <TYPE> (<RANGE>). */
1940 gfc_gobble_whitespace ();
1941 c
= gfc_next_char ();
1942 if ((c
== '\n') || (c
== ','))
1944 /* Check for CHARACTER with no length parameter. */
1945 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1947 ts
.kind
= gfc_default_character_kind
;
1948 ts
.cl
= gfc_get_charlen ();
1949 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1950 gfc_current_ns
->cl_list
= ts
.cl
;
1951 ts
.cl
->length
= gfc_int_expr (1);
1954 /* Record the Successful match. */
1955 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1960 gfc_current_locus
= cur_loc
;
1963 /* Discard the (incorrectly) matched range. */
1964 gfc_clear_new_implicit ();
1966 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1967 if (ts
.type
== BT_CHARACTER
)
1968 m
= match_char_spec (&ts
);
1971 m
= gfc_match_kind_spec (&ts
);
1974 m
= gfc_match_old_kind_spec (&ts
);
1975 if (m
== MATCH_ERROR
)
1981 if (m
== MATCH_ERROR
)
1984 m
= match_implicit_range ();
1985 if (m
== MATCH_ERROR
)
1990 gfc_gobble_whitespace ();
1991 c
= gfc_next_char ();
1992 if ((c
!= '\n') && (c
!= ','))
1995 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2003 gfc_syntax_error (ST_IMPLICIT
);
2010 gfc_match_import (void)
2012 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2017 if (gfc_current_ns
->proc_name
== NULL
||
2018 gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
2020 gfc_error ("IMPORT statement at %C only permitted in "
2021 "an INTERFACE body");
2025 if (gfc_notify_std (GFC_STD_F2003
,
2026 "Fortran 2003: IMPORT statement at %C")
2030 if (gfc_match_eos () == MATCH_YES
)
2032 /* All host variables should be imported. */
2033 gfc_current_ns
->has_import_set
= 1;
2037 if (gfc_match (" ::") == MATCH_YES
)
2039 if (gfc_match_eos () == MATCH_YES
)
2041 gfc_error ("Expecting list of named entities at %C");
2048 m
= gfc_match (" %n", name
);
2052 if (gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
2054 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2060 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2061 "at %C - does not exist.", name
);
2065 if (gfc_find_symtree (gfc_current_ns
->sym_root
,name
))
2067 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2072 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
2075 sym
->ns
= gfc_current_ns
;
2087 if (gfc_match_eos () == MATCH_YES
)
2089 if (gfc_match_char (',') != MATCH_YES
)
2096 gfc_error ("Syntax error in IMPORT statement at %C");
2100 /* Matches an attribute specification including array specs. If
2101 successful, leaves the variables current_attr and current_as
2102 holding the specification. Also sets the colon_seen variable for
2103 later use by matchers associated with initializations.
2105 This subroutine is a little tricky in the sense that we don't know
2106 if we really have an attr-spec until we hit the double colon.
2107 Until that time, we can only return MATCH_NO. This forces us to
2108 check for duplicate specification at this level. */
2111 match_attr_spec (void)
2114 /* Modifiers that can exist in a type statement. */
2116 { GFC_DECL_BEGIN
= 0,
2117 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2118 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2119 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
2120 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
2121 DECL_COLON
, DECL_NONE
,
2122 GFC_DECL_END
/* Sentinel */
2126 /* GFC_DECL_END is the sentinel, index starts at 0. */
2127 #define NUM_DECL GFC_DECL_END
2129 static mstring decls
[] = {
2130 minit (", allocatable", DECL_ALLOCATABLE
),
2131 minit (", dimension", DECL_DIMENSION
),
2132 minit (", external", DECL_EXTERNAL
),
2133 minit (", intent ( in )", DECL_IN
),
2134 minit (", intent ( out )", DECL_OUT
),
2135 minit (", intent ( in out )", DECL_INOUT
),
2136 minit (", intrinsic", DECL_INTRINSIC
),
2137 minit (", optional", DECL_OPTIONAL
),
2138 minit (", parameter", DECL_PARAMETER
),
2139 minit (", pointer", DECL_POINTER
),
2140 minit (", protected", DECL_PROTECTED
),
2141 minit (", private", DECL_PRIVATE
),
2142 minit (", public", DECL_PUBLIC
),
2143 minit (", save", DECL_SAVE
),
2144 minit (", target", DECL_TARGET
),
2145 minit (", value", DECL_VALUE
),
2146 minit (", volatile", DECL_VOLATILE
),
2147 minit ("::", DECL_COLON
),
2148 minit (NULL
, DECL_NONE
)
2151 locus start
, seen_at
[NUM_DECL
];
2158 gfc_clear_attr (¤t_attr
);
2159 start
= gfc_current_locus
;
2164 /* See if we get all of the keywords up to the final double colon. */
2165 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2170 d
= (decl_types
) gfc_match_strings (decls
);
2171 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2174 if (gfc_current_state () == COMP_ENUM
)
2176 gfc_error ("Enumerator cannot have attributes %C");
2181 seen_at
[d
] = gfc_current_locus
;
2183 if (d
== DECL_DIMENSION
)
2185 m
= gfc_match_array_spec (¤t_as
);
2189 gfc_error ("Missing dimension specification at %C");
2193 if (m
== MATCH_ERROR
)
2198 /* If we are parsing an enumeration and have ensured that no other
2199 attributes are present we can now set the parameter attribute. */
2200 if (gfc_current_state () == COMP_ENUM
)
2202 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
2210 /* No double colon, so assume that we've been looking at something
2211 else the whole time. */
2218 /* Since we've seen a double colon, we have to be looking at an
2219 attr-spec. This means that we can now issue errors. */
2220 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2225 case DECL_ALLOCATABLE
:
2226 attr
= "ALLOCATABLE";
2228 case DECL_DIMENSION
:
2235 attr
= "INTENT (IN)";
2238 attr
= "INTENT (OUT)";
2241 attr
= "INTENT (IN OUT)";
2243 case DECL_INTRINSIC
:
2249 case DECL_PARAMETER
:
2255 case DECL_PROTECTED
:
2277 attr
= NULL
; /* This shouldn't happen */
2280 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2285 /* Now that we've dealt with duplicate attributes, add the attributes
2286 to the current attribute. */
2287 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2292 if (gfc_current_state () == COMP_DERIVED
2293 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2294 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2296 if (d
== DECL_ALLOCATABLE
)
2298 if (gfc_notify_std (GFC_STD_F2003
,
2299 "Fortran 2003: ALLOCATABLE "
2300 "attribute at %C in a TYPE "
2301 "definition") == FAILURE
)
2309 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2316 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2317 && gfc_current_state () != COMP_MODULE
)
2319 if (d
== DECL_PRIVATE
)
2324 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2332 case DECL_ALLOCATABLE
:
2333 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2336 case DECL_DIMENSION
:
2337 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2341 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2345 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2349 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2353 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2356 case DECL_INTRINSIC
:
2357 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2361 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2364 case DECL_PARAMETER
:
2365 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2369 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2372 case DECL_PROTECTED
:
2373 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2375 gfc_error ("PROTECTED at %C only allowed in specification "
2376 "part of a module");
2381 if (gfc_notify_std (GFC_STD_F2003
,
2382 "Fortran 2003: PROTECTED attribute at %C")
2386 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
2390 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2395 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2400 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2404 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2408 if (gfc_notify_std (GFC_STD_F2003
,
2409 "Fortran 2003: VALUE attribute at %C")
2413 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
2417 if (gfc_notify_std (GFC_STD_F2003
,
2418 "Fortran 2003: VOLATILE attribute at %C")
2422 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
2426 gfc_internal_error ("match_attr_spec(): Bad attribute");
2440 gfc_current_locus
= start
;
2441 gfc_free_array_spec (current_as
);
2447 /* Match a data declaration statement. */
2450 gfc_match_data_decl (void)
2456 m
= match_type_spec (¤t_ts
, 0);
2460 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2462 sym
= gfc_use_derived (current_ts
.derived
);
2470 current_ts
.derived
= sym
;
2473 m
= match_attr_spec ();
2474 if (m
== MATCH_ERROR
)
2480 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2483 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2486 gfc_find_symbol (current_ts
.derived
->name
,
2487 current_ts
.derived
->ns
->parent
, 1, &sym
);
2489 /* Any symbol that we find had better be a type definition
2490 which has its components defined. */
2491 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2492 && current_ts
.derived
->components
!= NULL
)
2495 /* Now we have an error, which we signal, and then fix up
2496 because the knock-on is plain and simple confusing. */
2497 gfc_error_now ("Derived type at %C has not been previously defined "
2498 "and so cannot appear in a derived type definition");
2499 current_attr
.pointer
= 1;
2504 /* If we have an old-style character declaration, and no new-style
2505 attribute specifications, then there a comma is optional between
2506 the type specification and the variable list. */
2507 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2508 gfc_match_char (',');
2510 /* Give the types/attributes to symbols that follow. Give the element
2511 a number so that repeat character length expressions can be copied. */
2515 m
= variable_decl (elem
++);
2516 if (m
== MATCH_ERROR
)
2521 if (gfc_match_eos () == MATCH_YES
)
2523 if (gfc_match_char (',') != MATCH_YES
)
2527 if (gfc_error_flag_test () == 0)
2528 gfc_error ("Syntax error in data declaration at %C");
2531 gfc_free_data_all (gfc_current_ns
);
2534 gfc_free_array_spec (current_as
);
2540 /* Match a prefix associated with a function or subroutine
2541 declaration. If the typespec pointer is nonnull, then a typespec
2542 can be matched. Note that if nothing matches, MATCH_YES is
2543 returned (the null string was matched). */
2546 match_prefix (gfc_typespec
* ts
)
2550 gfc_clear_attr (¤t_attr
);
2554 if (!seen_type
&& ts
!= NULL
2555 && match_type_spec (ts
, 0) == MATCH_YES
2556 && gfc_match_space () == MATCH_YES
)
2563 if (gfc_match ("elemental% ") == MATCH_YES
)
2565 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2571 if (gfc_match ("pure% ") == MATCH_YES
)
2573 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2579 if (gfc_match ("recursive% ") == MATCH_YES
)
2581 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2587 /* At this point, the next item is not a prefix. */
2592 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2595 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2598 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2601 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2604 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2611 /* Match a formal argument list. */
2614 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2616 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2617 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2623 if (gfc_match_char ('(') != MATCH_YES
)
2630 if (gfc_match_char (')') == MATCH_YES
)
2635 if (gfc_match_char ('*') == MATCH_YES
)
2639 m
= gfc_match_name (name
);
2643 if (gfc_get_symbol (name
, NULL
, &sym
))
2647 p
= gfc_get_formal_arglist ();
2659 /* We don't add the VARIABLE flavor because the name could be a
2660 dummy procedure. We don't apply these attributes to formal
2661 arguments of statement functions. */
2662 if (sym
!= NULL
&& !st_flag
2663 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2664 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2670 /* The name of a program unit can be in a different namespace,
2671 so check for it explicitly. After the statement is accepted,
2672 the name is checked for especially in gfc_get_symbol(). */
2673 if (gfc_new_block
!= NULL
&& sym
!= NULL
2674 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2676 gfc_error ("Name '%s' at %C is the name of the procedure",
2682 if (gfc_match_char (')') == MATCH_YES
)
2685 m
= gfc_match_char (',');
2688 gfc_error ("Unexpected junk in formal argument list at %C");
2694 /* Check for duplicate symbols in the formal argument list. */
2697 for (p
= head
; p
->next
; p
= p
->next
)
2702 for (q
= p
->next
; q
; q
= q
->next
)
2703 if (p
->sym
== q
->sym
)
2706 ("Duplicate symbol '%s' in formal argument list at %C",
2715 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2725 gfc_free_formal_arglist (head
);
2730 /* Match a RESULT specification following a function declaration or
2731 ENTRY statement. Also matches the end-of-statement. */
2734 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2736 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2740 if (gfc_match (" result (") != MATCH_YES
)
2743 m
= gfc_match_name (name
);
2747 if (gfc_match (" )%t") != MATCH_YES
)
2749 gfc_error ("Unexpected junk following RESULT variable at %C");
2753 if (strcmp (function
->name
, name
) == 0)
2756 ("RESULT variable at %C must be different than function name");
2760 if (gfc_get_symbol (name
, NULL
, &r
))
2763 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2764 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2773 /* Match a function declaration. */
2776 gfc_match_function_decl (void)
2778 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2779 gfc_symbol
*sym
, *result
;
2783 if (gfc_current_state () != COMP_NONE
2784 && gfc_current_state () != COMP_INTERFACE
2785 && gfc_current_state () != COMP_CONTAINS
)
2788 gfc_clear_ts (¤t_ts
);
2790 old_loc
= gfc_current_locus
;
2792 m
= match_prefix (¤t_ts
);
2795 gfc_current_locus
= old_loc
;
2799 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2801 gfc_current_locus
= old_loc
;
2805 if (get_proc_name (name
, &sym
, false))
2807 gfc_new_block
= sym
;
2809 m
= gfc_match_formal_arglist (sym
, 0, 0);
2812 gfc_error ("Expected formal argument list in function "
2813 "definition at %C");
2817 else if (m
== MATCH_ERROR
)
2822 if (gfc_match_eos () != MATCH_YES
)
2824 /* See if a result variable is present. */
2825 m
= match_result (sym
, &result
);
2827 gfc_error ("Unexpected junk after function declaration at %C");
2836 /* Make changes to the symbol. */
2839 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2842 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2843 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2846 if (current_ts
.type
!= BT_UNKNOWN
2847 && sym
->ts
.type
!= BT_UNKNOWN
2848 && !sym
->attr
.implicit_type
)
2850 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2851 gfc_basic_typename (sym
->ts
.type
));
2857 sym
->ts
= current_ts
;
2862 result
->ts
= current_ts
;
2863 sym
->result
= result
;
2869 gfc_current_locus
= old_loc
;
2873 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2874 name of the entry, rather than the gfc_current_block name, and to return false
2875 upon finding an existing global entry. */
2878 add_global_entry (const char * name
, int sub
)
2882 s
= gfc_get_gsymbol(name
);
2885 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2886 global_used(s
, NULL
);
2889 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2890 s
->where
= gfc_current_locus
;
2897 /* Match an ENTRY statement. */
2900 gfc_match_entry (void)
2905 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2906 gfc_compile_state state
;
2910 bool module_procedure
;
2912 m
= gfc_match_name (name
);
2916 state
= gfc_current_state ();
2917 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2922 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2925 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2927 case COMP_BLOCK_DATA
:
2929 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2931 case COMP_INTERFACE
:
2933 ("ENTRY statement at %C cannot appear within an INTERFACE");
2937 ("ENTRY statement at %C cannot appear "
2938 "within a DERIVED TYPE block");
2942 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2946 ("ENTRY statement at %C cannot appear within a DO block");
2950 ("ENTRY statement at %C cannot appear within a SELECT block");
2954 ("ENTRY statement at %C cannot appear within a FORALL block");
2958 ("ENTRY statement at %C cannot appear within a WHERE block");
2962 ("ENTRY statement at %C cannot appear "
2963 "within a contained subprogram");
2966 gfc_internal_error ("gfc_match_entry(): Bad state");
2971 module_procedure
= gfc_current_ns
->parent
!= NULL
2972 && gfc_current_ns
->parent
->proc_name
2973 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
;
2975 if (gfc_current_ns
->parent
!= NULL
2976 && gfc_current_ns
->parent
->proc_name
2977 && !module_procedure
)
2979 gfc_error("ENTRY statement at %C cannot appear in a "
2980 "contained procedure");
2984 /* Module function entries need special care in get_proc_name
2985 because previous references within the function will have
2986 created symbols attached to the current namespace. */
2987 if (get_proc_name (name
, &entry
,
2988 gfc_current_ns
->parent
!= NULL
2990 && gfc_current_ns
->proc_name
->attr
.function
))
2993 proc
= gfc_current_block ();
2995 if (state
== COMP_SUBROUTINE
)
2997 /* An entry in a subroutine. */
2998 if (!add_global_entry (name
, 1))
3001 m
= gfc_match_formal_arglist (entry
, 0, 1);
3005 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
3006 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
3011 /* An entry in a function.
3012 We need to take special care because writing
3017 ENTRY f() RESULT (r)
3019 ENTRY f RESULT (r). */
3020 if (!add_global_entry (name
, 0))
3023 old_loc
= gfc_current_locus
;
3024 if (gfc_match_eos () == MATCH_YES
)
3026 gfc_current_locus
= old_loc
;
3027 /* Match the empty argument list, and add the interface to
3029 m
= gfc_match_formal_arglist (entry
, 0, 1);
3032 m
= gfc_match_formal_arglist (entry
, 0, 0);
3039 if (gfc_match_eos () == MATCH_YES
)
3041 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
3042 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
3045 entry
->result
= entry
;
3049 m
= match_result (proc
, &result
);
3051 gfc_syntax_error (ST_ENTRY
);
3055 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
3056 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
3057 || gfc_add_function (&entry
->attr
, result
->name
,
3061 entry
->result
= result
;
3064 if (proc
->attr
.recursive
&& result
== NULL
)
3066 gfc_error ("RESULT attribute required in ENTRY statement at %C");
3071 if (gfc_match_eos () != MATCH_YES
)
3073 gfc_syntax_error (ST_ENTRY
);
3077 entry
->attr
.recursive
= proc
->attr
.recursive
;
3078 entry
->attr
.elemental
= proc
->attr
.elemental
;
3079 entry
->attr
.pure
= proc
->attr
.pure
;
3081 el
= gfc_get_entry_list ();
3083 el
->next
= gfc_current_ns
->entries
;
3084 gfc_current_ns
->entries
= el
;
3086 el
->id
= el
->next
->id
+ 1;
3090 new_st
.op
= EXEC_ENTRY
;
3091 new_st
.ext
.entry
= el
;
3097 /* Match a subroutine statement, including optional prefixes. */
3100 gfc_match_subroutine (void)
3102 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3106 if (gfc_current_state () != COMP_NONE
3107 && gfc_current_state () != COMP_INTERFACE
3108 && gfc_current_state () != COMP_CONTAINS
)
3111 m
= match_prefix (NULL
);
3115 m
= gfc_match ("subroutine% %n", name
);
3119 if (get_proc_name (name
, &sym
, false))
3121 gfc_new_block
= sym
;
3123 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3126 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
3129 if (gfc_match_eos () != MATCH_YES
)
3131 gfc_syntax_error (ST_SUBROUTINE
);
3135 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
3142 /* Return nonzero if we're currently compiling a contained procedure. */
3145 contained_procedure (void)
3149 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
3150 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
3151 && s
->previous
!= NULL
3152 && s
->previous
->state
== COMP_CONTAINS
)
3158 /* Set the kind of each enumerator. The kind is selected such that it is
3159 interoperable with the corresponding C enumeration type, making
3160 sure that -fshort-enums is honored. */
3165 enumerator_history
*current_history
= NULL
;
3169 if (max_enum
== NULL
|| enum_history
== NULL
)
3172 if (!gfc_option
.fshort_enums
)
3178 kind
= gfc_integer_kinds
[i
++].kind
;
3180 while (kind
< gfc_c_int_kind
3181 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
3184 current_history
= enum_history
;
3185 while (current_history
!= NULL
)
3187 current_history
->sym
->ts
.kind
= kind
;
3188 current_history
= current_history
->next
;
3192 /* Match any of the various end-block statements. Returns the type of
3193 END to the caller. The END INTERFACE, END IF, END DO and END
3194 SELECT statements cannot be replaced by a single END statement. */
3197 gfc_match_end (gfc_statement
* st
)
3199 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3200 gfc_compile_state state
;
3202 const char *block_name
;
3207 old_loc
= gfc_current_locus
;
3208 if (gfc_match ("end") != MATCH_YES
)
3211 state
= gfc_current_state ();
3213 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
3215 if (state
== COMP_CONTAINS
)
3217 state
= gfc_state_stack
->previous
->state
;
3218 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
3219 : gfc_state_stack
->previous
->sym
->name
;
3226 *st
= ST_END_PROGRAM
;
3227 target
= " program";
3231 case COMP_SUBROUTINE
:
3232 *st
= ST_END_SUBROUTINE
;
3233 target
= " subroutine";
3234 eos_ok
= !contained_procedure ();
3238 *st
= ST_END_FUNCTION
;
3239 target
= " function";
3240 eos_ok
= !contained_procedure ();
3243 case COMP_BLOCK_DATA
:
3244 *st
= ST_END_BLOCK_DATA
;
3245 target
= " block data";
3250 *st
= ST_END_MODULE
;
3255 case COMP_INTERFACE
:
3256 *st
= ST_END_INTERFACE
;
3257 target
= " interface";
3280 *st
= ST_END_SELECT
;
3286 *st
= ST_END_FORALL
;
3301 last_initializer
= NULL
;
3303 gfc_free_enum_history ();
3307 gfc_error ("Unexpected END statement at %C");
3311 if (gfc_match_eos () == MATCH_YES
)
3315 /* We would have required END [something] */
3316 gfc_error ("%s statement expected at %L",
3317 gfc_ascii_statement (*st
), &old_loc
);
3324 /* Verify that we've got the sort of end-block that we're expecting. */
3325 if (gfc_match (target
) != MATCH_YES
)
3327 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3331 /* If we're at the end, make sure a block name wasn't required. */
3332 if (gfc_match_eos () == MATCH_YES
)
3335 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3338 if (gfc_current_block () == NULL
)
3341 gfc_error ("Expected block name of '%s' in %s statement at %C",
3342 block_name
, gfc_ascii_statement (*st
));
3347 /* END INTERFACE has a special handler for its several possible endings. */
3348 if (*st
== ST_END_INTERFACE
)
3349 return gfc_match_end_interface ();
3351 /* We haven't hit the end of statement, so what is left must be an end-name. */
3352 m
= gfc_match_space ();
3354 m
= gfc_match_name (name
);
3357 gfc_error ("Expected terminating name at %C");
3361 if (block_name
== NULL
)
3364 if (strcmp (name
, block_name
) != 0)
3366 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3367 gfc_ascii_statement (*st
));
3371 if (gfc_match_eos () == MATCH_YES
)
3375 gfc_syntax_error (*st
);
3378 gfc_current_locus
= old_loc
;
3384 /***************** Attribute declaration statements ****************/
3386 /* Set the attribute of a single variable. */
3391 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3399 m
= gfc_match_name (name
);
3403 if (find_special (name
, &sym
))
3406 var_locus
= gfc_current_locus
;
3408 /* Deal with possible array specification for certain attributes. */
3409 if (current_attr
.dimension
3410 || current_attr
.allocatable
3411 || current_attr
.pointer
3412 || current_attr
.target
)
3414 m
= gfc_match_array_spec (&as
);
3415 if (m
== MATCH_ERROR
)
3418 if (current_attr
.dimension
&& m
== MATCH_NO
)
3421 ("Missing array specification at %L in DIMENSION statement",
3427 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3428 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3430 gfc_error ("Array specification must be deferred at %L",
3437 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3438 if (current_attr
.dimension
== 0
3439 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3445 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3451 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3453 /* Fix the array spec. */
3454 m
= gfc_mod_pointee_as (sym
->as
);
3455 if (m
== MATCH_ERROR
)
3459 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
3465 if ((current_attr
.external
|| current_attr
.intrinsic
)
3466 && sym
->attr
.flavor
!= FL_PROCEDURE
3467 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3476 gfc_free_array_spec (as
);
3481 /* Generic attribute declaration subroutine. Used for attributes that
3482 just have a list of names. */
3489 /* Gobble the optional double colon, by simply ignoring the result
3499 if (gfc_match_eos () == MATCH_YES
)
3505 if (gfc_match_char (',') != MATCH_YES
)
3507 gfc_error ("Unexpected character in variable list at %C");
3517 /* This routine matches Cray Pointer declarations of the form:
3518 pointer ( <pointer>, <pointee> )
3520 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3521 The pointer, if already declared, should be an integer. Otherwise, we
3522 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3523 be either a scalar, or an array declaration. No space is allocated for
3524 the pointee. For the statement
3525 pointer (ipt, ar(10))
3526 any subsequent uses of ar will be translated (in C-notation) as
3527 ar(i) => ((<type> *) ipt)(i)
3528 After gimplification, pointee variable will disappear in the code. */
3531 cray_pointer_decl (void)
3535 gfc_symbol
*cptr
; /* Pointer symbol. */
3536 gfc_symbol
*cpte
; /* Pointee symbol. */
3542 if (gfc_match_char ('(') != MATCH_YES
)
3544 gfc_error ("Expected '(' at %C");
3548 /* Match pointer. */
3549 var_locus
= gfc_current_locus
;
3550 gfc_clear_attr (¤t_attr
);
3551 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3552 current_ts
.type
= BT_INTEGER
;
3553 current_ts
.kind
= gfc_index_integer_kind
;
3555 m
= gfc_match_symbol (&cptr
, 0);
3558 gfc_error ("Expected variable name at %C");
3562 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3565 gfc_set_sym_referenced (cptr
);
3567 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3569 cptr
->ts
.type
= BT_INTEGER
;
3570 cptr
->ts
.kind
= gfc_index_integer_kind
;
3572 else if (cptr
->ts
.type
!= BT_INTEGER
)
3574 gfc_error ("Cray pointer at %C must be an integer");
3577 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3578 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3579 " memory addresses require %d bytes",
3581 gfc_index_integer_kind
);
3583 if (gfc_match_char (',') != MATCH_YES
)
3585 gfc_error ("Expected \",\" at %C");
3589 /* Match Pointee. */
3590 var_locus
= gfc_current_locus
;
3591 gfc_clear_attr (¤t_attr
);
3592 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3593 current_ts
.type
= BT_UNKNOWN
;
3594 current_ts
.kind
= 0;
3596 m
= gfc_match_symbol (&cpte
, 0);
3599 gfc_error ("Expected variable name at %C");
3603 /* Check for an optional array spec. */
3604 m
= gfc_match_array_spec (&as
);
3605 if (m
== MATCH_ERROR
)
3607 gfc_free_array_spec (as
);
3610 else if (m
== MATCH_NO
)
3612 gfc_free_array_spec (as
);
3616 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3619 gfc_set_sym_referenced (cpte
);
3621 if (cpte
->as
== NULL
)
3623 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3624 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3626 else if (as
!= NULL
)
3628 gfc_error ("Duplicate array spec for Cray pointee at %C");
3629 gfc_free_array_spec (as
);
3635 if (cpte
->as
!= NULL
)
3637 /* Fix array spec. */
3638 m
= gfc_mod_pointee_as (cpte
->as
);
3639 if (m
== MATCH_ERROR
)
3643 /* Point the Pointee at the Pointer. */
3644 cpte
->cp_pointer
= cptr
;
3646 if (gfc_match_char (')') != MATCH_YES
)
3648 gfc_error ("Expected \")\" at %C");
3651 m
= gfc_match_char (',');
3653 done
= true; /* Stop searching for more declarations. */
3657 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3658 || gfc_match_eos () != MATCH_YES
)
3660 gfc_error ("Expected \",\" or end of statement at %C");
3668 gfc_match_external (void)
3671 gfc_clear_attr (¤t_attr
);
3672 current_attr
.external
= 1;
3674 return attr_decl ();
3680 gfc_match_intent (void)
3684 intent
= match_intent_spec ();
3685 if (intent
== INTENT_UNKNOWN
)
3688 gfc_clear_attr (¤t_attr
);
3689 current_attr
.intent
= intent
;
3691 return attr_decl ();
3696 gfc_match_intrinsic (void)
3699 gfc_clear_attr (¤t_attr
);
3700 current_attr
.intrinsic
= 1;
3702 return attr_decl ();
3707 gfc_match_optional (void)
3710 gfc_clear_attr (¤t_attr
);
3711 current_attr
.optional
= 1;
3713 return attr_decl ();
3718 gfc_match_pointer (void)
3720 gfc_gobble_whitespace ();
3721 if (gfc_peek_char () == '(')
3723 if (!gfc_option
.flag_cray_pointer
)
3725 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3729 return cray_pointer_decl ();
3733 gfc_clear_attr (¤t_attr
);
3734 current_attr
.pointer
= 1;
3736 return attr_decl ();
3742 gfc_match_allocatable (void)
3745 gfc_clear_attr (¤t_attr
);
3746 current_attr
.allocatable
= 1;
3748 return attr_decl ();
3753 gfc_match_dimension (void)
3756 gfc_clear_attr (¤t_attr
);
3757 current_attr
.dimension
= 1;
3759 return attr_decl ();
3764 gfc_match_target (void)
3767 gfc_clear_attr (¤t_attr
);
3768 current_attr
.target
= 1;
3770 return attr_decl ();
3774 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3778 access_attr_decl (gfc_statement st
)
3780 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3781 interface_type type
;
3784 gfc_intrinsic_op
operator;
3787 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3792 m
= gfc_match_generic_spec (&type
, name
, &operator);
3795 if (m
== MATCH_ERROR
)
3800 case INTERFACE_NAMELESS
:
3803 case INTERFACE_GENERIC
:
3804 if (gfc_get_symbol (name
, NULL
, &sym
))
3807 if (gfc_add_access (&sym
->attr
,
3809 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3810 sym
->name
, NULL
) == FAILURE
)
3815 case INTERFACE_INTRINSIC_OP
:
3816 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3818 gfc_current_ns
->operator_access
[operator] =
3819 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3823 gfc_error ("Access specification of the %s operator at %C has "
3824 "already been specified", gfc_op2string (operator));
3830 case INTERFACE_USER_OP
:
3831 uop
= gfc_get_uop (name
);
3833 if (uop
->access
== ACCESS_UNKNOWN
)
3836 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3841 ("Access specification of the .%s. operator at %C has "
3842 "already been specified", sym
->name
);
3849 if (gfc_match_char (',') == MATCH_NO
)
3853 if (gfc_match_eos () != MATCH_YES
)
3858 gfc_syntax_error (st
);
3866 gfc_match_protected (void)
3871 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3873 gfc_error ("PROTECTED at %C only allowed in specification "
3874 "part of a module");
3879 if (gfc_notify_std (GFC_STD_F2003
,
3880 "Fortran 2003: PROTECTED statement at %C")
3884 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3889 if (gfc_match_eos () == MATCH_YES
)
3894 m
= gfc_match_symbol (&sym
, 0);
3898 if (gfc_add_protected (&sym
->attr
, sym
->name
,
3899 &gfc_current_locus
) == FAILURE
)
3911 if (gfc_match_eos () == MATCH_YES
)
3913 if (gfc_match_char (',') != MATCH_YES
)
3920 gfc_error ("Syntax error in PROTECTED statement at %C");
3926 /* The PRIVATE statement is a bit weird in that it can be a attribute
3927 declaration, but also works as a standlone statement inside of a
3928 type declaration or a module. */
3931 gfc_match_private (gfc_statement
* st
)
3934 if (gfc_match ("private") != MATCH_YES
)
3937 if (gfc_current_state () == COMP_DERIVED
)
3939 if (gfc_match_eos () == MATCH_YES
)
3945 gfc_syntax_error (ST_PRIVATE
);
3949 if (gfc_match_eos () == MATCH_YES
)
3956 return access_attr_decl (ST_PRIVATE
);
3961 gfc_match_public (gfc_statement
* st
)
3964 if (gfc_match ("public") != MATCH_YES
)
3967 if (gfc_match_eos () == MATCH_YES
)
3974 return access_attr_decl (ST_PUBLIC
);
3978 /* Workhorse for gfc_match_parameter. */
3987 m
= gfc_match_symbol (&sym
, 0);
3989 gfc_error ("Expected variable name at %C in PARAMETER statement");
3994 if (gfc_match_char ('=') == MATCH_NO
)
3996 gfc_error ("Expected = sign in PARAMETER statement at %C");
4000 m
= gfc_match_init_expr (&init
);
4002 gfc_error ("Expected expression at %C in PARAMETER statement");
4006 if (sym
->ts
.type
== BT_UNKNOWN
4007 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
4013 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
4014 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
4020 if (sym
->ts
.type
== BT_CHARACTER
4021 && sym
->ts
.cl
!= NULL
4022 && sym
->ts
.cl
->length
!= NULL
4023 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
4024 && init
->expr_type
== EXPR_CONSTANT
4025 && init
->ts
.type
== BT_CHARACTER
4026 && init
->ts
.kind
== 1)
4027 gfc_set_constant_character_len (
4028 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
4034 gfc_free_expr (init
);
4039 /* Match a parameter statement, with the weird syntax that these have. */
4042 gfc_match_parameter (void)
4046 if (gfc_match_char ('(') == MATCH_NO
)
4055 if (gfc_match (" )%t") == MATCH_YES
)
4058 if (gfc_match_char (',') != MATCH_YES
)
4060 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4070 /* Save statements have a special syntax. */
4073 gfc_match_save (void)
4075 char n
[GFC_MAX_SYMBOL_LEN
+1];
4080 if (gfc_match_eos () == MATCH_YES
)
4082 if (gfc_current_ns
->seen_save
)
4084 if (gfc_notify_std (GFC_STD_LEGACY
,
4085 "Blanket SAVE statement at %C follows previous "
4091 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
4095 if (gfc_current_ns
->save_all
)
4097 if (gfc_notify_std (GFC_STD_LEGACY
,
4098 "SAVE statement at %C follows blanket SAVE statement")
4107 m
= gfc_match_symbol (&sym
, 0);
4111 if (gfc_add_save (&sym
->attr
, sym
->name
,
4112 &gfc_current_locus
) == FAILURE
)
4123 m
= gfc_match (" / %n /", &n
);
4124 if (m
== MATCH_ERROR
)
4129 c
= gfc_get_common (n
, 0);
4132 gfc_current_ns
->seen_save
= 1;
4135 if (gfc_match_eos () == MATCH_YES
)
4137 if (gfc_match_char (',') != MATCH_YES
)
4144 gfc_error ("Syntax error in SAVE statement at %C");
4150 gfc_match_value (void)
4155 if (gfc_notify_std (GFC_STD_F2003
,
4156 "Fortran 2003: VALUE statement at %C")
4160 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4165 if (gfc_match_eos () == MATCH_YES
)
4170 m
= gfc_match_symbol (&sym
, 0);
4174 if (gfc_add_value (&sym
->attr
, sym
->name
,
4175 &gfc_current_locus
) == FAILURE
)
4187 if (gfc_match_eos () == MATCH_YES
)
4189 if (gfc_match_char (',') != MATCH_YES
)
4196 gfc_error ("Syntax error in VALUE statement at %C");
4201 gfc_match_volatile (void)
4206 if (gfc_notify_std (GFC_STD_F2003
,
4207 "Fortran 2003: VOLATILE statement at %C")
4211 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4216 if (gfc_match_eos () == MATCH_YES
)
4221 m
= gfc_match_symbol (&sym
, 0);
4225 if (gfc_add_volatile (&sym
->attr
, sym
->name
,
4226 &gfc_current_locus
) == FAILURE
)
4238 if (gfc_match_eos () == MATCH_YES
)
4240 if (gfc_match_char (',') != MATCH_YES
)
4247 gfc_error ("Syntax error in VOLATILE statement at %C");
4253 /* Match a module procedure statement. Note that we have to modify
4254 symbols in the parent's namespace because the current one was there
4255 to receive symbols that are in an interface's formal argument list. */
4258 gfc_match_modproc (void)
4260 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4264 if (gfc_state_stack
->state
!= COMP_INTERFACE
4265 || gfc_state_stack
->previous
== NULL
4266 || current_interface
.type
== INTERFACE_NAMELESS
)
4269 ("MODULE PROCEDURE at %C must be in a generic module interface");
4275 m
= gfc_match_name (name
);
4281 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
4284 if (sym
->attr
.proc
!= PROC_MODULE
4285 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
4286 sym
->name
, NULL
) == FAILURE
)
4289 if (gfc_add_interface (sym
) == FAILURE
)
4292 sym
->attr
.mod_proc
= 1;
4294 if (gfc_match_eos () == MATCH_YES
)
4296 if (gfc_match_char (',') != MATCH_YES
)
4303 gfc_syntax_error (ST_MODULE_PROC
);
4308 /* Match the beginning of a derived type declaration. If a type name
4309 was the result of a function, then it is possible to have a symbol
4310 already to be known as a derived type yet have no components. */
4313 gfc_match_derived_decl (void)
4315 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4316 symbol_attribute attr
;
4320 if (gfc_current_state () == COMP_DERIVED
)
4323 gfc_clear_attr (&attr
);
4326 if (gfc_match (" , private") == MATCH_YES
)
4328 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4331 ("Derived type at %C can only be PRIVATE within a MODULE");
4335 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
4340 if (gfc_match (" , public") == MATCH_YES
)
4342 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4344 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4348 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
4353 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
4355 gfc_error ("Expected :: in TYPE definition at %C");
4359 m
= gfc_match (" %n%t", name
);
4363 /* Make sure the name isn't the name of an intrinsic type. The
4364 'double precision' type doesn't get past the name matcher. */
4365 if (strcmp (name
, "integer") == 0
4366 || strcmp (name
, "real") == 0
4367 || strcmp (name
, "character") == 0
4368 || strcmp (name
, "logical") == 0
4369 || strcmp (name
, "complex") == 0)
4372 ("Type name '%s' at %C cannot be the same as an intrinsic type",
4377 if (gfc_get_symbol (name
, NULL
, &sym
))
4380 if (sym
->ts
.type
!= BT_UNKNOWN
)
4382 gfc_error ("Derived type name '%s' at %C already has a basic type "
4383 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
4387 /* The symbol may already have the derived attribute without the
4388 components. The ways this can happen is via a function
4389 definition, an INTRINSIC statement or a subtype in another
4390 derived type that is a pointer. The first part of the AND clause
4391 is true if a the symbol is not the return value of a function. */
4392 if (sym
->attr
.flavor
!= FL_DERIVED
4393 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
4396 if (sym
->components
!= NULL
)
4399 ("Derived type definition of '%s' at %C has already been defined",
4404 if (attr
.access
!= ACCESS_UNKNOWN
4405 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
4408 gfc_new_block
= sym
;
4414 /* Cray Pointees can be declared as:
4415 pointer (ipt, a (n,m,...,*))
4416 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4417 cheat and set a constant bound of 1 for the last dimension, if this
4418 is the case. Since there is no bounds-checking for Cray Pointees,
4419 this will be okay. */
4422 gfc_mod_pointee_as (gfc_array_spec
*as
)
4424 as
->cray_pointee
= true; /* This will be useful to know later. */
4425 if (as
->type
== AS_ASSUMED_SIZE
)
4427 as
->type
= AS_EXPLICIT
;
4428 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4429 as
->cp_was_assumed
= true;
4431 else if (as
->type
== AS_ASSUMED_SHAPE
)
4433 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4440 /* Match the enum definition statement, here we are trying to match
4441 the first line of enum definition statement.
4442 Returns MATCH_YES if match is found. */
4445 gfc_match_enum (void)
4449 m
= gfc_match_eos ();
4453 if (gfc_notify_std (GFC_STD_F2003
,
4454 "Fortran 2003: ENUM AND ENUMERATOR at %C")
4462 /* Match the enumerator definition statement. */
4465 gfc_match_enumerator_def (void)
4470 gfc_clear_ts (¤t_ts
);
4472 m
= gfc_match (" enumerator");
4476 if (gfc_current_state () != COMP_ENUM
)
4478 gfc_error ("ENUM definition statement expected before %C");
4479 gfc_free_enum_history ();
4483 (¤t_ts
)->type
= BT_INTEGER
;
4484 (¤t_ts
)->kind
= gfc_c_int_kind
;
4486 m
= match_attr_spec ();
4487 if (m
== MATCH_ERROR
)
4496 m
= variable_decl (elem
++);
4497 if (m
== MATCH_ERROR
)
4502 if (gfc_match_eos () == MATCH_YES
)
4504 if (gfc_match_char (',') != MATCH_YES
)
4508 if (gfc_current_state () == COMP_ENUM
)
4510 gfc_free_enum_history ();
4511 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4516 gfc_free_array_spec (current_as
);