1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004 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, 59 Temple Place - Suite 330, Boston, MA
30 /* This flag is set if a an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector
;
35 /* When variables aquire 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 /* gfc_new_block points to the symbol of a newly matched block. */
48 gfc_symbol
*gfc_new_block
;
51 /* Match an intent specification. Since this can only happen after an
52 INTENT word, a legal intent-spec must follow. */
55 match_intent_spec (void)
58 if (gfc_match (" ( in out )") == MATCH_YES
)
60 if (gfc_match (" ( in )") == MATCH_YES
)
62 if (gfc_match (" ( out )") == MATCH_YES
)
65 gfc_error ("Bad INTENT specification at %C");
66 return INTENT_UNKNOWN
;
70 /* Matches a character length specification, which is either a
71 specification expression or a '*'. */
74 char_len_param_value (gfc_expr
** expr
)
77 if (gfc_match_char ('*') == MATCH_YES
)
83 return gfc_match_expr (expr
);
87 /* A character length is a '*' followed by a literal integer or a
88 char_len_param_value in parenthesis. */
91 match_char_length (gfc_expr
** expr
)
96 m
= gfc_match_char ('*');
100 m
= gfc_match_small_literal_int (&length
);
101 if (m
== MATCH_ERROR
)
106 *expr
= gfc_int_expr (length
);
110 if (gfc_match_char ('(') == MATCH_NO
)
113 m
= char_len_param_value (expr
);
114 if (m
== MATCH_ERROR
)
119 if (gfc_match_char (')') == MATCH_NO
)
121 gfc_free_expr (*expr
);
129 gfc_error ("Syntax error in character length specification at %C");
134 /* Special subroutine for finding a symbol. If we're compiling a
135 function or subroutine and the parent compilation unit is an
136 interface, then check to see if the name we've been given is the
137 name of the interface (located in another namespace). If so,
138 return that symbol. If not, use gfc_get_symbol(). */
141 find_special (const char *name
, gfc_symbol
** result
)
145 if (gfc_current_state () != COMP_SUBROUTINE
146 && gfc_current_state () != COMP_FUNCTION
)
149 s
= gfc_state_stack
->previous
;
153 if (s
->state
!= COMP_INTERFACE
)
156 goto normal
; /* Nameless interface */
158 if (strcmp (name
, s
->sym
->name
) == 0)
165 return gfc_get_symbol (name
, NULL
, result
);
169 /* Special subroutine for getting a symbol node associated with a
170 procedure name, used in SUBROUTINE and FUNCTION statements. The
171 symbol is created in the parent using with symtree node in the
172 child unit pointing to the symbol. If the current namespace has no
173 parent, then the symbol is just created in the current unit. */
176 get_proc_name (const char *name
, gfc_symbol
** result
)
182 if (gfc_current_ns
->parent
== NULL
)
183 return gfc_get_symbol (name
, NULL
, result
);
185 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
189 /* Deal with ENTRY problem */
191 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
197 /* See if the procedure should be a module procedure */
199 if (sym
->ns
->proc_name
!= NULL
200 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
201 && sym
->attr
.proc
!= PROC_MODULE
202 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
, NULL
) == FAILURE
)
209 /* Function called by variable_decl() that adds a name to the symbol
213 build_sym (const char *name
, gfc_charlen
* cl
,
214 gfc_array_spec
** as
, locus
* var_locus
)
216 symbol_attribute attr
;
219 if (find_special (name
, &sym
))
222 /* Start updating the symbol table. Add basic type attribute
224 if (current_ts
.type
!= BT_UNKNOWN
225 &&(sym
->attr
.implicit_type
== 0
226 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
227 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
230 if (sym
->ts
.type
== BT_CHARACTER
)
233 /* Add dimension attribute if present. */
234 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
238 /* Add attribute to symbol. The copy is so that we can reset the
239 dimension attribute. */
243 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
250 /* Function called by variable_decl() that adds an initialization
251 expression to a symbol. */
254 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
257 symbol_attribute attr
;
262 if (find_special (name
, &sym
))
267 /* If this symbol is confirming an implicit parameter type,
268 then an initialization expression is not allowed. */
269 if (attr
.flavor
== FL_PARAMETER
270 && sym
->value
!= NULL
273 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
282 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
289 /* An initializer is required for PARAMETER declarations. */
290 if (attr
.flavor
== FL_PARAMETER
)
292 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
298 /* If a variable appears in a DATA block, it cannot have an
303 ("Variable '%s' at %C with an initializer already appears "
304 "in a DATA statement", sym
->name
);
308 /* Checking a derived type parameter has to be put off until later. */
309 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
310 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
313 /* Add initializer. Make sure we keep the ranks sane. */
314 if (sym
->attr
.dimension
&& init
->rank
== 0)
315 init
->rank
= sym
->as
->rank
;
325 /* Function called by variable_decl() that adds a name to a structure
329 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
330 gfc_array_spec
** as
)
334 /* If the current symbol is of the same derived type that we're
335 constructing, it must have the pointer attribute. */
336 if (current_ts
.type
== BT_DERIVED
337 && current_ts
.derived
== gfc_current_block ()
338 && current_attr
.pointer
== 0)
340 gfc_error ("Component at %C must have the POINTER attribute");
344 if (gfc_current_block ()->attr
.pointer
347 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
349 gfc_error ("Array component of structure at %C must have explicit "
350 "or deferred shape");
355 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
360 gfc_set_component_attr (c
, ¤t_attr
);
362 c
->initializer
= *init
;
370 /* Check array components. */
376 if (c
->as
->type
!= AS_DEFERRED
)
378 gfc_error ("Pointer array component of structure at %C "
379 "must have a deferred shape");
385 if (c
->as
->type
!= AS_EXPLICIT
)
388 ("Array component of structure at %C must have an explicit "
398 /* Match a 'NULL()', and possibly take care of some side effects. */
401 gfc_match_null (gfc_expr
** result
)
407 m
= gfc_match (" null ( )");
411 /* The NULL symbol now has to be/become an intrinsic function. */
412 if (gfc_get_symbol ("null", NULL
, &sym
))
414 gfc_error ("NULL() initialization at %C is ambiguous");
418 gfc_intrinsic_symbol (sym
);
420 if (sym
->attr
.proc
!= PROC_INTRINSIC
421 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
, NULL
) == FAILURE
422 || gfc_add_function (&sym
->attr
, NULL
) == FAILURE
))
426 e
->where
= gfc_current_locus
;
427 e
->expr_type
= EXPR_NULL
;
428 e
->ts
.type
= BT_UNKNOWN
;
436 /* Match a variable name with an optional initializer. When this
437 subroutine is called, a variable is expected to be parsed next.
438 Depending on what is happening at the moment, updates either the
439 symbol table or the current interface. */
444 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
445 gfc_expr
*initializer
, *char_len
;
455 /* When we get here, we've just matched a list of attributes and
456 maybe a type and a double colon. The next thing we expect to see
457 is the name of the symbol. */
458 m
= gfc_match_name (name
);
462 var_locus
= gfc_current_locus
;
464 /* Now we could see the optional array spec. or character length. */
465 m
= gfc_match_array_spec (&as
);
466 if (m
== MATCH_ERROR
)
469 as
= gfc_copy_array_spec (current_as
);
474 if (current_ts
.type
== BT_CHARACTER
)
476 switch (match_char_length (&char_len
))
479 cl
= gfc_get_charlen ();
480 cl
->next
= gfc_current_ns
->cl_list
;
481 gfc_current_ns
->cl_list
= cl
;
483 cl
->length
= char_len
;
495 /* OK, we've successfully matched the declaration. Now put the
496 symbol in the current namespace, because it might be used in the
497 optional intialization expression for this symbol, e.g. this is
500 integer, parameter :: i = huge(i)
502 This is only true for parameters or variables of a basic type.
503 For components of derived types, it is not true, so we don't
504 create a symbol for those yet. If we fail to create the symbol,
506 if (gfc_current_state () != COMP_DERIVED
507 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
513 /* In functions that have a RESULT variable defined, the function
514 name always refers to function calls. Therefore, the name is
515 not allowed to appear in specification statements. */
516 if (gfc_current_state () == COMP_FUNCTION
517 && gfc_current_block () != NULL
518 && gfc_current_block ()->result
!= NULL
519 && gfc_current_block ()->result
!= gfc_current_block ()
520 && strcmp (gfc_current_block ()->name
, name
) == 0)
522 gfc_error ("Function name '%s' not allowed at %C", name
);
527 /* The double colon must be present in order to have initializers.
528 Otherwise the statement is ambiguous with an assignment statement. */
531 if (gfc_match (" =>") == MATCH_YES
)
534 if (!current_attr
.pointer
)
536 gfc_error ("Initialization at %C isn't for a pointer variable");
541 m
= gfc_match_null (&initializer
);
544 gfc_error ("Pointer initialization requires a NULL at %C");
551 ("Initialization of pointer at %C is not allowed in a "
559 initializer
->ts
= current_ts
;
562 else if (gfc_match_char ('=') == MATCH_YES
)
564 if (current_attr
.pointer
)
567 ("Pointer initialization at %C requires '=>', not '='");
572 m
= gfc_match_init_expr (&initializer
);
575 gfc_error ("Expected an initialization expression at %C");
579 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
582 ("Initialization of variable at %C is not allowed in a "
592 /* Add the initializer. Note that it is fine if initializer is
593 NULL here, because we sometimes also need to check if a
594 declaration *must* have an initialization expression. */
595 if (gfc_current_state () != COMP_DERIVED
)
596 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
599 if (current_ts
.type
== BT_DERIVED
&& !initializer
)
600 initializer
= gfc_default_initializer (¤t_ts
);
601 t
= build_struct (name
, cl
, &initializer
, &as
);
604 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
607 /* Free stuff up and return. */
608 gfc_free_expr (initializer
);
609 gfc_free_array_spec (as
);
615 /* Match an extended-f77 kind specification. */
618 gfc_match_old_kind_spec (gfc_typespec
* ts
)
622 if (gfc_match_char ('*') != MATCH_YES
)
625 m
= gfc_match_small_literal_int (&ts
->kind
);
629 /* Massage the kind numbers for complex types. */
630 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
632 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
635 if (gfc_validate_kind (ts
->type
, ts
->kind
) == -1)
637 gfc_error ("Old-style kind %d not supported for type %s at %C",
638 ts
->kind
, gfc_basic_typename (ts
->type
));
647 /* Match a kind specification. Since kinds are generally optional, we
648 usually return MATCH_NO if something goes wrong. If a "kind="
649 string is found, then we know we have an error. */
652 gfc_match_kind_spec (gfc_typespec
* ts
)
662 where
= gfc_current_locus
;
664 if (gfc_match_char ('(') == MATCH_NO
)
667 /* Also gobbles optional text. */
668 if (gfc_match (" kind = ") == MATCH_YES
)
671 n
= gfc_match_init_expr (&e
);
673 gfc_error ("Expected initialization expression at %C");
679 gfc_error ("Expected scalar initialization expression at %C");
684 msg
= gfc_extract_int (e
, &ts
->kind
);
695 if (gfc_validate_kind (ts
->type
, ts
->kind
) == -1)
697 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
698 gfc_basic_typename (ts
->type
));
704 if (gfc_match_char (')') != MATCH_YES
)
706 gfc_error ("Missing right paren at %C");
714 gfc_current_locus
= where
;
719 /* Match the various kind/length specifications in a CHARACTER
720 declaration. We don't return MATCH_NO. */
723 match_char_spec (gfc_typespec
* ts
)
725 int i
, kind
, seen_length
;
730 kind
= gfc_default_character_kind ();
734 /* Try the old-style specification first. */
735 old_char_selector
= 0;
737 m
= match_char_length (&len
);
741 old_char_selector
= 1;
746 m
= gfc_match_char ('(');
749 m
= MATCH_YES
; /* character without length is a single char */
753 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
754 if (gfc_match (" kind =") == MATCH_YES
)
756 m
= gfc_match_small_int (&kind
);
757 if (m
== MATCH_ERROR
)
762 if (gfc_match (" , len =") == MATCH_NO
)
765 m
= char_len_param_value (&len
);
768 if (m
== MATCH_ERROR
)
775 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
776 if (gfc_match (" len =") == MATCH_YES
)
778 m
= char_len_param_value (&len
);
781 if (m
== MATCH_ERROR
)
785 if (gfc_match_char (')') == MATCH_YES
)
788 if (gfc_match (" , kind =") != MATCH_YES
)
791 gfc_match_small_int (&kind
);
793 if (gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
795 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
802 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
803 m
= char_len_param_value (&len
);
806 if (m
== MATCH_ERROR
)
810 m
= gfc_match_char (')');
814 if (gfc_match_char (',') != MATCH_YES
)
817 gfc_match (" kind ="); /* Gobble optional text */
819 m
= gfc_match_small_int (&kind
);
820 if (m
== MATCH_ERROR
)
826 /* Require a right-paren at this point. */
827 m
= gfc_match_char (')');
832 gfc_error ("Syntax error in CHARACTER declaration at %C");
836 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
838 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
848 /* Do some final massaging of the length values. */
849 cl
= gfc_get_charlen ();
850 cl
->next
= gfc_current_ns
->cl_list
;
851 gfc_current_ns
->cl_list
= cl
;
853 if (seen_length
== 0)
854 cl
->length
= gfc_int_expr (1);
857 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
862 cl
->length
= gfc_int_expr (0);
873 /* Matches a type specification. If successful, sets the ts structure
874 to the matched specification. This is necessary for FUNCTION and
877 If implicit_flag is nonzero, then we don't check for the optional
878 kind specification. Not doing so is needed for matching an IMPLICIT
879 statement correctly. */
882 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
884 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
891 if (gfc_match (" integer") == MATCH_YES
)
893 ts
->type
= BT_INTEGER
;
894 ts
->kind
= gfc_default_integer_kind ();
898 if (gfc_match (" character") == MATCH_YES
)
900 ts
->type
= BT_CHARACTER
;
901 if (implicit_flag
== 0)
902 return match_char_spec (ts
);
907 if (gfc_match (" real") == MATCH_YES
)
910 ts
->kind
= gfc_default_real_kind ();
914 if (gfc_match (" double precision") == MATCH_YES
)
917 ts
->kind
= gfc_default_double_kind ();
921 if (gfc_match (" complex") == MATCH_YES
)
923 ts
->type
= BT_COMPLEX
;
924 ts
->kind
= gfc_default_complex_kind ();
928 if (gfc_match (" double complex") == MATCH_YES
)
930 ts
->type
= BT_COMPLEX
;
931 ts
->kind
= gfc_default_double_kind ();
935 if (gfc_match (" logical") == MATCH_YES
)
937 ts
->type
= BT_LOGICAL
;
938 ts
->kind
= gfc_default_logical_kind ();
942 m
= gfc_match (" type ( %n )", name
);
946 /* Search for the name but allow the components to be defined later. */
947 if (gfc_get_ha_symbol (name
, &sym
))
949 gfc_error ("Type name '%s' at %C is ambiguous", name
);
953 if (sym
->attr
.flavor
!= FL_DERIVED
954 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
957 ts
->type
= BT_DERIVED
;
964 /* For all types except double, derived and character, look for an
965 optional kind specifier. MATCH_NO is actually OK at this point. */
966 if (implicit_flag
== 1)
969 if (gfc_current_form
== FORM_FREE
)
972 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
973 && c
!= ':' && c
!= ',')
977 m
= gfc_match_kind_spec (ts
);
978 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
979 m
= gfc_match_old_kind_spec (ts
);
982 m
= MATCH_YES
; /* No kind specifier found. */
988 /* Match an IMPLICIT NONE statement. Actually, this statement is
989 already matched in parse.c, or we would not end up here in the
990 first place. So the only thing we need to check, is if there is
991 trailing garbage. If not, the match is successful. */
994 gfc_match_implicit_none (void)
997 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1001 /* Match the letter range(s) of an IMPLICIT statement. */
1004 match_implicit_range (void)
1006 int c
, c1
, c2
, inner
;
1009 cur_loc
= gfc_current_locus
;
1011 gfc_gobble_whitespace ();
1012 c
= gfc_next_char ();
1015 gfc_error ("Missing character range in IMPLICIT at %C");
1022 gfc_gobble_whitespace ();
1023 c1
= gfc_next_char ();
1027 gfc_gobble_whitespace ();
1028 c
= gfc_next_char ();
1033 inner
= 0; /* Fall through */
1040 gfc_gobble_whitespace ();
1041 c2
= gfc_next_char ();
1045 gfc_gobble_whitespace ();
1046 c
= gfc_next_char ();
1048 if ((c
!= ',') && (c
!= ')'))
1061 gfc_error ("Letters must be in alphabetic order in "
1062 "IMPLICIT statement at %C");
1066 /* See if we can add the newly matched range to the pending
1067 implicits from this IMPLICIT statement. We do not check for
1068 conflicts with whatever earlier IMPLICIT statements may have
1069 set. This is done when we've successfully finished matching
1071 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1078 gfc_syntax_error (ST_IMPLICIT
);
1080 gfc_current_locus
= cur_loc
;
1085 /* Match an IMPLICIT statement, storing the types for
1086 gfc_set_implicit() if the statement is accepted by the parser.
1087 There is a strange looking, but legal syntactic construction
1088 possible. It looks like:
1090 IMPLICIT INTEGER (a-b) (c-d)
1092 This is legal if "a-b" is a constant expression that happens to
1093 equal one of the legal kinds for integers. The real problem
1094 happens with an implicit specification that looks like:
1096 IMPLICIT INTEGER (a-b)
1098 In this case, a typespec matcher that is "greedy" (as most of the
1099 matchers are) gobbles the character range as a kindspec, leaving
1100 nothing left. We therefore have to go a bit more slowly in the
1101 matching process by inhibiting the kindspec checking during
1102 typespec matching and checking for a kind later. */
1105 gfc_match_implicit (void)
1112 /* We don't allow empty implicit statements. */
1113 if (gfc_match_eos () == MATCH_YES
)
1115 gfc_error ("Empty IMPLICIT statement at %C");
1121 /* First cleanup. */
1122 gfc_clear_new_implicit ();
1124 /* A basic type is mandatory here. */
1125 m
= match_type_spec (&ts
, 1);
1126 if (m
== MATCH_ERROR
)
1131 cur_loc
= gfc_current_locus
;
1132 m
= match_implicit_range ();
1136 /* We may have <TYPE> (<RANGE>). */
1137 gfc_gobble_whitespace ();
1138 c
= gfc_next_char ();
1139 if ((c
== '\n') || (c
== ','))
1141 /* Check for CHARACTER with no length parameter. */
1142 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1144 ts
.kind
= gfc_default_character_kind ();
1145 ts
.cl
= gfc_get_charlen ();
1146 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1147 gfc_current_ns
->cl_list
= ts
.cl
;
1148 ts
.cl
->length
= gfc_int_expr (1);
1151 /* Record the Successful match. */
1152 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1157 gfc_current_locus
= cur_loc
;
1160 /* Discard the (incorrectly) matched range. */
1161 gfc_clear_new_implicit ();
1163 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1164 if (ts
.type
== BT_CHARACTER
)
1165 m
= match_char_spec (&ts
);
1168 m
= gfc_match_kind_spec (&ts
);
1171 m
= gfc_match_old_kind_spec (&ts
);
1172 if (m
== MATCH_ERROR
)
1178 if (m
== MATCH_ERROR
)
1181 m
= match_implicit_range ();
1182 if (m
== MATCH_ERROR
)
1187 gfc_gobble_whitespace ();
1188 c
= gfc_next_char ();
1189 if ((c
!= '\n') && (c
!= ','))
1192 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1200 gfc_syntax_error (ST_IMPLICIT
);
1207 /* Matches an attribute specification including array specs. If
1208 successful, leaves the variables current_attr and current_as
1209 holding the specification. Also sets the colon_seen variable for
1210 later use by matchers associated with initializations.
1212 This subroutine is a little tricky in the sense that we don't know
1213 if we really have an attr-spec until we hit the double colon.
1214 Until that time, we can only return MATCH_NO. This forces us to
1215 check for duplicate specification at this level. */
1218 match_attr_spec (void)
1221 /* Modifiers that can exist in a type statement. */
1223 { GFC_DECL_BEGIN
= 0,
1224 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1225 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1226 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1227 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1228 GFC_DECL_END
/* Sentinel */
1232 /* GFC_DECL_END is the sentinel, index starts at 0. */
1233 #define NUM_DECL GFC_DECL_END
1235 static mstring decls
[] = {
1236 minit (", allocatable", DECL_ALLOCATABLE
),
1237 minit (", dimension", DECL_DIMENSION
),
1238 minit (", external", DECL_EXTERNAL
),
1239 minit (", intent ( in )", DECL_IN
),
1240 minit (", intent ( out )", DECL_OUT
),
1241 minit (", intent ( in out )", DECL_INOUT
),
1242 minit (", intrinsic", DECL_INTRINSIC
),
1243 minit (", optional", DECL_OPTIONAL
),
1244 minit (", parameter", DECL_PARAMETER
),
1245 minit (", pointer", DECL_POINTER
),
1246 minit (", private", DECL_PRIVATE
),
1247 minit (", public", DECL_PUBLIC
),
1248 minit (", save", DECL_SAVE
),
1249 minit (", target", DECL_TARGET
),
1250 minit ("::", DECL_COLON
),
1251 minit (NULL
, DECL_NONE
)
1254 locus start
, seen_at
[NUM_DECL
];
1261 gfc_clear_attr (¤t_attr
);
1262 start
= gfc_current_locus
;
1267 /* See if we get all of the keywords up to the final double colon. */
1268 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1273 d
= (decl_types
) gfc_match_strings (decls
);
1274 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1278 seen_at
[d
] = gfc_current_locus
;
1280 if (d
== DECL_DIMENSION
)
1282 m
= gfc_match_array_spec (¤t_as
);
1286 gfc_error ("Missing dimension specification at %C");
1290 if (m
== MATCH_ERROR
)
1295 /* No double colon, so assume that we've been looking at something
1296 else the whole time. */
1303 /* Since we've seen a double colon, we have to be looking at an
1304 attr-spec. This means that we can now issue errors. */
1305 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1310 case DECL_ALLOCATABLE
:
1311 attr
= "ALLOCATABLE";
1313 case DECL_DIMENSION
:
1320 attr
= "INTENT (IN)";
1323 attr
= "INTENT (OUT)";
1326 attr
= "INTENT (IN OUT)";
1328 case DECL_INTRINSIC
:
1334 case DECL_PARAMETER
:
1353 attr
= NULL
; /* This shouldn't happen */
1356 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1361 /* Now that we've dealt with duplicate attributes, add the attributes
1362 to the current attribute. */
1363 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1368 if (gfc_current_state () == COMP_DERIVED
1369 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1370 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1373 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1381 case DECL_ALLOCATABLE
:
1382 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1385 case DECL_DIMENSION
:
1386 t
= gfc_add_dimension (¤t_attr
, &seen_at
[d
]);
1390 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1394 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1398 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1402 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1405 case DECL_INTRINSIC
:
1406 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1410 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1413 case DECL_PARAMETER
:
1414 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, &seen_at
[d
]);
1418 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1422 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, &seen_at
[d
]);
1426 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, &seen_at
[d
]);
1430 t
= gfc_add_save (¤t_attr
, &seen_at
[d
]);
1434 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1438 gfc_internal_error ("match_attr_spec(): Bad attribute");
1452 gfc_current_locus
= start
;
1453 gfc_free_array_spec (current_as
);
1459 /* Match a data declaration statement. */
1462 gfc_match_data_decl (void)
1467 m
= match_type_spec (¤t_ts
, 0);
1471 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1473 sym
= gfc_use_derived (current_ts
.derived
);
1481 current_ts
.derived
= sym
;
1484 m
= match_attr_spec ();
1485 if (m
== MATCH_ERROR
)
1491 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1494 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1497 if (gfc_find_symbol (current_ts
.derived
->name
,
1498 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1501 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1502 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1505 gfc_error ("Derived type at %C has not been previously defined");
1511 /* If we have an old-style character declaration, and no new-style
1512 attribute specifications, then there a comma is optional between
1513 the type specification and the variable list. */
1514 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
1515 gfc_match_char (',');
1517 /* Give the types/attributes to symbols that follow. */
1520 m
= variable_decl ();
1521 if (m
== MATCH_ERROR
)
1526 if (gfc_match_eos () == MATCH_YES
)
1528 if (gfc_match_char (',') != MATCH_YES
)
1532 gfc_error ("Syntax error in data declaration at %C");
1536 gfc_free_array_spec (current_as
);
1542 /* Match a prefix associated with a function or subroutine
1543 declaration. If the typespec pointer is nonnull, then a typespec
1544 can be matched. Note that if nothing matches, MATCH_YES is
1545 returned (the null string was matched). */
1548 match_prefix (gfc_typespec
* ts
)
1552 gfc_clear_attr (¤t_attr
);
1556 if (!seen_type
&& ts
!= NULL
1557 && match_type_spec (ts
, 0) == MATCH_YES
1558 && gfc_match_space () == MATCH_YES
)
1565 if (gfc_match ("elemental% ") == MATCH_YES
)
1567 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
1573 if (gfc_match ("pure% ") == MATCH_YES
)
1575 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
1581 if (gfc_match ("recursive% ") == MATCH_YES
)
1583 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
1589 /* At this point, the next item is not a prefix. */
1594 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
1597 copy_prefix (symbol_attribute
* dest
, locus
* where
)
1600 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1603 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1606 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1613 /* Match a formal argument list. */
1616 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
1618 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
1619 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1625 if (gfc_match_char ('(') != MATCH_YES
)
1632 if (gfc_match_char (')') == MATCH_YES
)
1637 if (gfc_match_char ('*') == MATCH_YES
)
1641 m
= gfc_match_name (name
);
1645 if (gfc_get_symbol (name
, NULL
, &sym
))
1649 p
= gfc_get_formal_arglist ();
1661 /* We don't add the VARIABLE flavor because the name could be a
1662 dummy procedure. We don't apply these attributes to formal
1663 arguments of statement functions. */
1664 if (sym
!= NULL
&& !st_flag
1665 && (gfc_add_dummy (&sym
->attr
, NULL
) == FAILURE
1666 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
1672 /* The name of a program unit can be in a different namespace,
1673 so check for it explicitly. After the statement is accepted,
1674 the name is checked for especially in gfc_get_symbol(). */
1675 if (gfc_new_block
!= NULL
&& sym
!= NULL
1676 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
1678 gfc_error ("Name '%s' at %C is the name of the procedure",
1684 if (gfc_match_char (')') == MATCH_YES
)
1687 m
= gfc_match_char (',');
1690 gfc_error ("Unexpected junk in formal argument list at %C");
1696 /* Check for duplicate symbols in the formal argument list. */
1699 for (p
= head
; p
->next
; p
= p
->next
)
1704 for (q
= p
->next
; q
; q
= q
->next
)
1705 if (p
->sym
== q
->sym
)
1708 ("Duplicate symbol '%s' in formal argument list at %C",
1717 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
1727 gfc_free_formal_arglist (head
);
1732 /* Match a RESULT specification following a function declaration or
1733 ENTRY statement. Also matches the end-of-statement. */
1736 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
1738 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1742 if (gfc_match (" result (") != MATCH_YES
)
1745 m
= gfc_match_name (name
);
1749 if (gfc_match (" )%t") != MATCH_YES
)
1751 gfc_error ("Unexpected junk following RESULT variable at %C");
1755 if (strcmp (function
->name
, name
) == 0)
1758 ("RESULT variable at %C must be different than function name");
1762 if (gfc_get_symbol (name
, NULL
, &r
))
1765 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, NULL
) == FAILURE
1766 || gfc_add_result (&r
->attr
, NULL
) == FAILURE
)
1775 /* Match a function declaration. */
1778 gfc_match_function_decl (void)
1780 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1781 gfc_symbol
*sym
, *result
;
1785 if (gfc_current_state () != COMP_NONE
1786 && gfc_current_state () != COMP_INTERFACE
1787 && gfc_current_state () != COMP_CONTAINS
)
1790 gfc_clear_ts (¤t_ts
);
1792 old_loc
= gfc_current_locus
;
1794 m
= match_prefix (¤t_ts
);
1797 gfc_current_locus
= old_loc
;
1801 if (gfc_match ("function% %n", name
) != MATCH_YES
)
1803 gfc_current_locus
= old_loc
;
1807 if (get_proc_name (name
, &sym
))
1809 gfc_new_block
= sym
;
1811 m
= gfc_match_formal_arglist (sym
, 0, 0);
1813 gfc_error ("Expected formal argument list in function definition at %C");
1814 else if (m
== MATCH_ERROR
)
1819 if (gfc_match_eos () != MATCH_YES
)
1821 /* See if a result variable is present. */
1822 m
= match_result (sym
, &result
);
1824 gfc_error ("Unexpected junk after function declaration at %C");
1833 /* Make changes to the symbol. */
1836 if (gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
1839 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
1840 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
1843 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
1845 gfc_error ("Function '%s' at %C already has a type of %s", name
,
1846 gfc_basic_typename (sym
->ts
.type
));
1852 sym
->ts
= current_ts
;
1857 result
->ts
= current_ts
;
1858 sym
->result
= result
;
1864 gfc_current_locus
= old_loc
;
1869 /* Match an ENTRY statement. */
1872 gfc_match_entry (void)
1874 gfc_symbol
*function
, *result
, *entry
;
1875 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1876 gfc_compile_state state
;
1879 m
= gfc_match_name (name
);
1883 if (get_proc_name (name
, &entry
))
1886 gfc_enclosing_unit (&state
);
1889 case COMP_SUBROUTINE
:
1890 m
= gfc_match_formal_arglist (entry
, 0, 1);
1894 if (gfc_current_state () != COMP_SUBROUTINE
)
1895 goto exec_construct
;
1897 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1898 || gfc_add_subroutine (&entry
->attr
, NULL
) == FAILURE
)
1904 m
= gfc_match_formal_arglist (entry
, 0, 0);
1908 if (gfc_current_state () != COMP_FUNCTION
)
1909 goto exec_construct
;
1910 function
= gfc_state_stack
->sym
;
1914 if (gfc_match_eos () == MATCH_YES
)
1916 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1917 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
1920 entry
->result
= function
->result
;
1925 m
= match_result (function
, &result
);
1927 gfc_syntax_error (ST_ENTRY
);
1931 if (gfc_add_result (&result
->attr
, NULL
) == FAILURE
1932 || gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1933 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
1937 if (function
->attr
.recursive
&& result
== NULL
)
1939 gfc_error ("RESULT attribute required in ENTRY statement at %C");
1946 goto exec_construct
;
1949 if (gfc_match_eos () != MATCH_YES
)
1951 gfc_syntax_error (ST_ENTRY
);
1958 gfc_error ("ENTRY statement at %C cannot appear within %s",
1959 gfc_state_name (gfc_current_state ()));
1965 /* Match a subroutine statement, including optional prefixes. */
1968 gfc_match_subroutine (void)
1970 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1974 if (gfc_current_state () != COMP_NONE
1975 && gfc_current_state () != COMP_INTERFACE
1976 && gfc_current_state () != COMP_CONTAINS
)
1979 m
= match_prefix (NULL
);
1983 m
= gfc_match ("subroutine% %n", name
);
1987 if (get_proc_name (name
, &sym
))
1989 gfc_new_block
= sym
;
1991 if (gfc_add_subroutine (&sym
->attr
, NULL
) == FAILURE
)
1994 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
1997 if (gfc_match_eos () != MATCH_YES
)
1999 gfc_syntax_error (ST_SUBROUTINE
);
2003 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2010 /* Return nonzero if we're currenly compiling a contained procedure. */
2013 contained_procedure (void)
2017 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2018 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2019 && s
->previous
!= NULL
2020 && s
->previous
->state
== COMP_CONTAINS
)
2026 /* Match any of the various end-block statements. Returns the type of
2027 END to the caller. The END INTERFACE, END IF, END DO and END
2028 SELECT statements cannot be replaced by a single END statement. */
2031 gfc_match_end (gfc_statement
* st
)
2033 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2034 gfc_compile_state state
;
2036 const char *block_name
;
2041 old_loc
= gfc_current_locus
;
2042 if (gfc_match ("end") != MATCH_YES
)
2045 state
= gfc_current_state ();
2047 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2049 if (state
== COMP_CONTAINS
)
2051 state
= gfc_state_stack
->previous
->state
;
2052 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2053 : gfc_state_stack
->previous
->sym
->name
;
2060 *st
= ST_END_PROGRAM
;
2061 target
= " program";
2065 case COMP_SUBROUTINE
:
2066 *st
= ST_END_SUBROUTINE
;
2067 target
= " subroutine";
2068 eos_ok
= !contained_procedure ();
2072 *st
= ST_END_FUNCTION
;
2073 target
= " function";
2074 eos_ok
= !contained_procedure ();
2077 case COMP_BLOCK_DATA
:
2078 *st
= ST_END_BLOCK_DATA
;
2079 target
= " block data";
2084 *st
= ST_END_MODULE
;
2089 case COMP_INTERFACE
:
2090 *st
= ST_END_INTERFACE
;
2091 target
= " interface";
2114 *st
= ST_END_SELECT
;
2120 *st
= ST_END_FORALL
;
2132 gfc_error ("Unexpected END statement at %C");
2136 if (gfc_match_eos () == MATCH_YES
)
2140 /* We would have required END [something] */
2141 gfc_error ("%s statement expected at %C",
2142 gfc_ascii_statement (*st
));
2149 /* Verify that we've got the sort of end-block that we're expecting. */
2150 if (gfc_match (target
) != MATCH_YES
)
2152 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2156 /* If we're at the end, make sure a block name wasn't required. */
2157 if (gfc_match_eos () == MATCH_YES
)
2160 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2163 if (gfc_current_block () == NULL
)
2166 gfc_error ("Expected block name of '%s' in %s statement at %C",
2167 block_name
, gfc_ascii_statement (*st
));
2172 /* END INTERFACE has a special handler for its several possible endings. */
2173 if (*st
== ST_END_INTERFACE
)
2174 return gfc_match_end_interface ();
2176 /* We haven't hit the end of statement, so what is left must be an end-name. */
2177 m
= gfc_match_space ();
2179 m
= gfc_match_name (name
);
2182 gfc_error ("Expected terminating name at %C");
2186 if (block_name
== NULL
)
2189 if (strcmp (name
, block_name
) != 0)
2191 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2192 gfc_ascii_statement (*st
));
2196 if (gfc_match_eos () == MATCH_YES
)
2200 gfc_syntax_error (*st
);
2203 gfc_current_locus
= old_loc
;
2209 /***************** Attribute declaration statements ****************/
2211 /* Set the attribute of a single variable. */
2216 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2224 m
= gfc_match_name (name
);
2228 if (find_special (name
, &sym
))
2231 var_locus
= gfc_current_locus
;
2233 /* Deal with possible array specification for certain attributes. */
2234 if (current_attr
.dimension
2235 || current_attr
.allocatable
2236 || current_attr
.pointer
2237 || current_attr
.target
)
2239 m
= gfc_match_array_spec (&as
);
2240 if (m
== MATCH_ERROR
)
2243 if (current_attr
.dimension
&& m
== MATCH_NO
)
2246 ("Missing array specification at %L in DIMENSION statement",
2252 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2253 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2255 gfc_error ("Array specification must be deferred at %L",
2262 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2263 if (current_attr
.dimension
== 0
2264 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2270 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2276 if ((current_attr
.external
|| current_attr
.intrinsic
)
2277 && sym
->attr
.flavor
!= FL_PROCEDURE
2278 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, NULL
) == FAILURE
)
2287 gfc_free_array_spec (as
);
2292 /* Generic attribute declaration subroutine. Used for attributes that
2293 just have a list of names. */
2300 /* Gobble the optional double colon, by simply ignoring the result
2310 if (gfc_match_eos () == MATCH_YES
)
2316 if (gfc_match_char (',') != MATCH_YES
)
2318 gfc_error ("Unexpected character in variable list at %C");
2329 gfc_match_external (void)
2332 gfc_clear_attr (¤t_attr
);
2333 gfc_add_external (¤t_attr
, NULL
);
2335 return attr_decl ();
2341 gfc_match_intent (void)
2345 intent
= match_intent_spec ();
2346 if (intent
== INTENT_UNKNOWN
)
2349 gfc_clear_attr (¤t_attr
);
2350 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2352 return attr_decl ();
2357 gfc_match_intrinsic (void)
2360 gfc_clear_attr (¤t_attr
);
2361 gfc_add_intrinsic (¤t_attr
, NULL
);
2363 return attr_decl ();
2368 gfc_match_optional (void)
2371 gfc_clear_attr (¤t_attr
);
2372 gfc_add_optional (¤t_attr
, NULL
);
2374 return attr_decl ();
2379 gfc_match_pointer (void)
2382 gfc_clear_attr (¤t_attr
);
2383 gfc_add_pointer (¤t_attr
, NULL
);
2385 return attr_decl ();
2390 gfc_match_allocatable (void)
2393 gfc_clear_attr (¤t_attr
);
2394 gfc_add_allocatable (¤t_attr
, NULL
);
2396 return attr_decl ();
2401 gfc_match_dimension (void)
2404 gfc_clear_attr (¤t_attr
);
2405 gfc_add_dimension (¤t_attr
, NULL
);
2407 return attr_decl ();
2412 gfc_match_target (void)
2415 gfc_clear_attr (¤t_attr
);
2416 gfc_add_target (¤t_attr
, NULL
);
2418 return attr_decl ();
2422 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2426 access_attr_decl (gfc_statement st
)
2428 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2429 interface_type type
;
2432 gfc_intrinsic_op
operator;
2435 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2440 m
= gfc_match_generic_spec (&type
, name
, &operator);
2443 if (m
== MATCH_ERROR
)
2448 case INTERFACE_NAMELESS
:
2451 case INTERFACE_GENERIC
:
2452 if (gfc_get_symbol (name
, NULL
, &sym
))
2455 if (gfc_add_access (&sym
->attr
,
2457 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2463 case INTERFACE_INTRINSIC_OP
:
2464 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2466 gfc_current_ns
->operator_access
[operator] =
2467 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2471 gfc_error ("Access specification of the %s operator at %C has "
2472 "already been specified", gfc_op2string (operator));
2478 case INTERFACE_USER_OP
:
2479 uop
= gfc_get_uop (name
);
2481 if (uop
->access
== ACCESS_UNKNOWN
)
2484 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2489 ("Access specification of the .%s. operator at %C has "
2490 "already been specified", sym
->name
);
2497 if (gfc_match_char (',') == MATCH_NO
)
2501 if (gfc_match_eos () != MATCH_YES
)
2506 gfc_syntax_error (st
);
2513 /* The PRIVATE statement is a bit weird in that it can be a attribute
2514 declaration, but also works as a standlone statement inside of a
2515 type declaration or a module. */
2518 gfc_match_private (gfc_statement
* st
)
2521 if (gfc_match ("private") != MATCH_YES
)
2524 if (gfc_current_state () == COMP_DERIVED
)
2526 if (gfc_match_eos () == MATCH_YES
)
2532 gfc_syntax_error (ST_PRIVATE
);
2536 if (gfc_match_eos () == MATCH_YES
)
2543 return access_attr_decl (ST_PRIVATE
);
2548 gfc_match_public (gfc_statement
* st
)
2551 if (gfc_match ("public") != MATCH_YES
)
2554 if (gfc_match_eos () == MATCH_YES
)
2561 return access_attr_decl (ST_PUBLIC
);
2565 /* Workhorse for gfc_match_parameter. */
2574 m
= gfc_match_symbol (&sym
, 0);
2576 gfc_error ("Expected variable name at %C in PARAMETER statement");
2581 if (gfc_match_char ('=') == MATCH_NO
)
2583 gfc_error ("Expected = sign in PARAMETER statement at %C");
2587 m
= gfc_match_init_expr (&init
);
2589 gfc_error ("Expected expression at %C in PARAMETER statement");
2593 if (sym
->ts
.type
== BT_UNKNOWN
2594 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2600 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
2601 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, NULL
) == FAILURE
)
2611 gfc_free_expr (init
);
2616 /* Match a parameter statement, with the weird syntax that these have. */
2619 gfc_match_parameter (void)
2623 if (gfc_match_char ('(') == MATCH_NO
)
2632 if (gfc_match (" )%t") == MATCH_YES
)
2635 if (gfc_match_char (',') != MATCH_YES
)
2637 gfc_error ("Unexpected characters in PARAMETER statement at %C");
2647 /* Save statements have a special syntax. */
2650 gfc_match_save (void)
2652 char n
[GFC_MAX_SYMBOL_LEN
+1];
2657 if (gfc_match_eos () == MATCH_YES
)
2659 if (gfc_current_ns
->seen_save
)
2661 gfc_error ("Blanket SAVE statement at %C follows previous "
2667 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
2671 if (gfc_current_ns
->save_all
)
2673 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2681 m
= gfc_match_symbol (&sym
, 0);
2685 if (gfc_add_save (&sym
->attr
, &gfc_current_locus
) == FAILURE
)
2696 m
= gfc_match (" / %n /", &n
);
2697 if (m
== MATCH_ERROR
)
2702 c
= gfc_get_common (n
, 0);
2705 gfc_current_ns
->seen_save
= 1;
2708 if (gfc_match_eos () == MATCH_YES
)
2710 if (gfc_match_char (',') != MATCH_YES
)
2717 gfc_error ("Syntax error in SAVE statement at %C");
2722 /* Match a module procedure statement. Note that we have to modify
2723 symbols in the parent's namespace because the current one was there
2724 to receive symbols that are in a interface's formal argument list. */
2727 gfc_match_modproc (void)
2729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2733 if (gfc_state_stack
->state
!= COMP_INTERFACE
2734 || gfc_state_stack
->previous
== NULL
2735 || current_interface
.type
== INTERFACE_NAMELESS
)
2738 ("MODULE PROCEDURE at %C must be in a generic module interface");
2744 m
= gfc_match_name (name
);
2750 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
2753 if (sym
->attr
.proc
!= PROC_MODULE
2754 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
, NULL
) == FAILURE
)
2757 if (gfc_add_interface (sym
) == FAILURE
)
2760 if (gfc_match_eos () == MATCH_YES
)
2762 if (gfc_match_char (',') != MATCH_YES
)
2769 gfc_syntax_error (ST_MODULE_PROC
);
2774 /* Match the beginning of a derived type declaration. If a type name
2775 was the result of a function, then it is possible to have a symbol
2776 already to be known as a derived type yet have no components. */
2779 gfc_match_derived_decl (void)
2781 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2782 symbol_attribute attr
;
2786 if (gfc_current_state () == COMP_DERIVED
)
2789 gfc_clear_attr (&attr
);
2792 if (gfc_match (" , private") == MATCH_YES
)
2794 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
2797 ("Derived type at %C can only be PRIVATE within a MODULE");
2801 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
) == FAILURE
)
2806 if (gfc_match (" , public") == MATCH_YES
)
2808 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
2810 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2814 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
) == FAILURE
)
2819 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
2821 gfc_error ("Expected :: in TYPE definition at %C");
2825 m
= gfc_match (" %n%t", name
);
2829 /* Make sure the name isn't the name of an intrinsic type. The
2830 'double precision' type doesn't get past the name matcher. */
2831 if (strcmp (name
, "integer") == 0
2832 || strcmp (name
, "real") == 0
2833 || strcmp (name
, "character") == 0
2834 || strcmp (name
, "logical") == 0
2835 || strcmp (name
, "complex") == 0)
2838 ("Type name '%s' at %C cannot be the same as an intrinsic type",
2843 if (gfc_get_symbol (name
, NULL
, &sym
))
2846 if (sym
->ts
.type
!= BT_UNKNOWN
)
2848 gfc_error ("Derived type name '%s' at %C already has a basic type "
2849 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
2853 /* The symbol may already have the derived attribute without the
2854 components. The ways this can happen is via a function
2855 definition, an INTRINSIC statement or a subtype in another
2856 derived type that is a pointer. The first part of the AND clause
2857 is true if a the symbol is not the return value of a function. */
2858 if (sym
->attr
.flavor
!= FL_DERIVED
2859 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
2862 if (sym
->components
!= NULL
)
2865 ("Derived type definition of '%s' at %C has already been defined",
2870 if (attr
.access
!= ACCESS_UNKNOWN
2871 && gfc_add_access (&sym
->attr
, attr
.access
, NULL
) == FAILURE
)
2874 gfc_new_block
= sym
;