1 /* Declaration statement matcher
2 Copyright (C) 2002 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",
280 /* An initializer is required for PARAMETER declarations. */
281 if (attr
.flavor
== FL_PARAMETER
)
283 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
289 /* If a variable appears in a DATA block, it cannot have an
294 ("Variable '%s' at %C with an initializer already appears "
295 "in a DATA statement", sym
->name
);
299 /* Checking a derived type parameter has to be put off until later. */
300 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
301 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
304 /* Add initializer. Make sure we keep the ranks sane. */
305 if (sym
->attr
.dimension
&& init
->rank
== 0)
306 init
->rank
= sym
->as
->rank
;
316 /* Function called by variable_decl() that adds a name to a structure
320 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
321 gfc_array_spec
** as
)
325 /* If the current symbol is of the same derived type that we're
326 constructing, it must have the pointer attribute. */
327 if (current_ts
.type
== BT_DERIVED
328 && current_ts
.derived
== gfc_current_block ()
329 && current_attr
.pointer
== 0)
331 gfc_error ("Component at %C must have the POINTER attribute");
335 if (gfc_current_block ()->attr
.pointer
338 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
340 gfc_error ("Array component of structure at %C must have explicit "
341 "or deferred shape");
346 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
351 gfc_set_component_attr (c
, ¤t_attr
);
353 c
->initializer
= *init
;
361 /* Check array components. */
367 if (c
->as
->type
!= AS_DEFERRED
)
369 gfc_error ("Pointer array component of structure at %C "
370 "must have a deferred shape");
376 if (c
->as
->type
!= AS_EXPLICIT
)
379 ("Array component of structure at %C must have an explicit "
389 /* Match a 'NULL()', and possibly take care of some side effects. */
392 gfc_match_null (gfc_expr
** result
)
398 m
= gfc_match (" null ( )");
402 /* The NULL symbol now has to be/become an intrinsic function. */
403 if (gfc_get_symbol ("null", NULL
, &sym
))
405 gfc_error ("NULL() initialization at %C is ambiguous");
409 gfc_intrinsic_symbol (sym
);
411 if (sym
->attr
.proc
!= PROC_INTRINSIC
412 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
, NULL
) == FAILURE
413 || gfc_add_function (&sym
->attr
, NULL
) == FAILURE
))
417 e
->where
= *gfc_current_locus ();
418 e
->expr_type
= EXPR_NULL
;
419 e
->ts
.type
= BT_UNKNOWN
;
427 /* Get an expression for a default initializer. */
429 default_initializer (void)
431 gfc_constructor
*tail
;
437 /* First see if we have a default initializer. */
438 for (c
= current_ts
.derived
->components
; c
; c
= c
->next
)
440 if (c
->initializer
&& init
== NULL
)
441 init
= gfc_get_expr ();
447 init
->expr_type
= EXPR_STRUCTURE
;
448 init
->ts
= current_ts
;
449 init
->where
= current_ts
.derived
->declared_at
;
451 for (c
= current_ts
.derived
->components
; c
; c
= c
->next
)
454 init
->value
.constructor
= tail
= gfc_get_constructor ();
457 tail
->next
= gfc_get_constructor ();
462 tail
->expr
= gfc_copy_expr (c
->initializer
);
468 /* Match a variable name with an optional initializer. When this
469 subroutine is called, a variable is expected to be parsed next.
470 Depending on what is happening at the moment, updates either the
471 symbol table or the current interface. */
476 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
477 gfc_expr
*initializer
, *char_len
;
487 /* When we get here, we've just matched a list of attributes and
488 maybe a type and a double colon. The next thing we expect to see
489 is the name of the symbol. */
490 m
= gfc_match_name (name
);
494 var_locus
= *gfc_current_locus ();
496 /* Now we could see the optional array spec. or character length. */
497 m
= gfc_match_array_spec (&as
);
498 if (m
== MATCH_ERROR
)
501 as
= gfc_copy_array_spec (current_as
);
506 if (current_ts
.type
== BT_CHARACTER
)
508 switch (match_char_length (&char_len
))
511 cl
= gfc_get_charlen ();
512 cl
->next
= gfc_current_ns
->cl_list
;
513 gfc_current_ns
->cl_list
= cl
;
515 cl
->length
= char_len
;
527 /* OK, we've successfully matched the declaration. Now put the
528 symbol in the current namespace, because it might be used in the
529 optional intialization expression for this symbol, e.g. this is
532 integer, parameter :: i = huge(i)
534 This is only true for parameters or variables of a basic type.
535 For components of derived types, it is not true, so we don't
536 create a symbol for those yet. If we fail to create the symbol,
538 if (gfc_current_state () != COMP_DERIVED
539 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
545 /* In functions that have a RESULT variable defined, the function
546 name always refers to function calls. Therefore, the name is
547 not allowed to appear in specification statements. */
548 if (gfc_current_state () == COMP_FUNCTION
549 && gfc_current_block () != NULL
550 && gfc_current_block ()->result
!= NULL
551 && gfc_current_block ()->result
!= gfc_current_block ()
552 && strcmp (gfc_current_block ()->name
, name
) == 0)
554 gfc_error ("Function name '%s' not allowed at %C", name
);
559 /* The double colon must be present in order to have initializers.
560 Otherwise the statement is ambiguous with an assignment statement. */
563 if (gfc_match (" =>") == MATCH_YES
)
566 if (!current_attr
.pointer
)
568 gfc_error ("Initialization at %C isn't for a pointer variable");
573 m
= gfc_match_null (&initializer
);
576 gfc_error ("Pointer initialization requires a NULL at %C");
583 ("Initialization of pointer at %C is not allowed in a "
591 initializer
->ts
= current_ts
;
594 else if (gfc_match_char ('=') == MATCH_YES
)
596 if (current_attr
.pointer
)
599 ("Pointer initialization at %C requires '=>', not '='");
604 m
= gfc_match_init_expr (&initializer
);
607 gfc_error ("Expected an initialization expression at %C");
611 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
614 ("Initialization of variable at %C is not allowed in a "
622 else if (current_ts
.type
== BT_DERIVED
)
624 initializer
= default_initializer ();
628 /* Add the initializer. Note that it is fine if &initializer is
629 NULL here, because we sometimes also need to check if a
630 declaration *must* have an initialization expression. */
631 if (gfc_current_state () != COMP_DERIVED
)
632 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
634 t
= build_struct (name
, cl
, &initializer
, &as
);
636 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
639 /* Free stuff up and return. */
640 gfc_free_expr (initializer
);
641 gfc_free_array_spec (as
);
647 /* Match an extended-f77 kind specification. */
650 gfc_match_old_kind_spec (gfc_typespec
* ts
)
654 if (gfc_match_char ('*') != MATCH_YES
)
657 m
= gfc_match_small_literal_int (&ts
->kind
);
661 /* Massage the kind numbers for complex types. */
662 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
664 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
667 if (gfc_validate_kind (ts
->type
, ts
->kind
) == -1)
669 gfc_error ("Old-style kind %d not supported for type %s at %C",
670 ts
->kind
, gfc_basic_typename (ts
->type
));
679 /* Match a kind specification. Since kinds are generally optional, we
680 usually return MATCH_NO if something goes wrong. If a "kind="
681 string is found, then we know we have an error. */
684 gfc_match_kind_spec (gfc_typespec
* ts
)
694 where
= *gfc_current_locus ();
696 if (gfc_match_char ('(') == MATCH_NO
)
699 /* Also gobbles optional text. */
700 if (gfc_match (" kind = ") == MATCH_YES
)
703 n
= gfc_match_init_expr (&e
);
705 gfc_error ("Expected initialization expression at %C");
711 gfc_error ("Expected scalar initialization expression at %C");
716 msg
= gfc_extract_int (e
, &ts
->kind
);
727 if (gfc_validate_kind (ts
->type
, ts
->kind
) == -1)
729 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
730 gfc_basic_typename (ts
->type
));
736 if (gfc_match_char (')') != MATCH_YES
)
738 gfc_error ("Missing right paren at %C");
746 gfc_set_locus (&where
);
751 /* Match the various kind/length specifications in a CHARACTER
752 declaration. We don't return MATCH_NO. */
755 match_char_spec (gfc_typespec
* ts
)
757 int i
, kind
, seen_length
;
762 kind
= gfc_default_character_kind ();
766 /* Try the old-style specification first. */
767 old_char_selector
= 0;
769 m
= match_char_length (&len
);
773 old_char_selector
= 1;
778 m
= gfc_match_char ('(');
781 m
= MATCH_YES
; /* character without length is a single char */
785 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
786 if (gfc_match (" kind =") == MATCH_YES
)
788 m
= gfc_match_small_int (&kind
);
789 if (m
== MATCH_ERROR
)
794 if (gfc_match (" , len =") == MATCH_NO
)
797 m
= char_len_param_value (&len
);
800 if (m
== MATCH_ERROR
)
807 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
808 if (gfc_match (" len =") == MATCH_YES
)
810 m
= char_len_param_value (&len
);
813 if (m
== MATCH_ERROR
)
817 if (gfc_match_char (')') == MATCH_YES
)
820 if (gfc_match (" , kind =") != MATCH_YES
)
823 gfc_match_small_int (&kind
);
825 if (gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
827 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
834 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
835 m
= char_len_param_value (&len
);
838 if (m
== MATCH_ERROR
)
842 m
= gfc_match_char (')');
846 if (gfc_match_char (',') != MATCH_YES
)
849 gfc_match (" kind ="); /* Gobble optional text */
851 m
= gfc_match_small_int (&kind
);
852 if (m
== MATCH_ERROR
)
858 /* Require a right-paren at this point. */
859 m
= gfc_match_char (')');
864 gfc_error ("Syntax error in CHARACTER declaration at %C");
868 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
870 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
880 /* Do some final massaging of the length values. */
881 cl
= gfc_get_charlen ();
882 cl
->next
= gfc_current_ns
->cl_list
;
883 gfc_current_ns
->cl_list
= cl
;
885 if (seen_length
== 0)
886 cl
->length
= gfc_int_expr (1);
889 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
894 cl
->length
= gfc_int_expr (0);
905 /* Matches a type specification. If successful, sets the ts structure
906 to the matched specification. This is necessary for FUNCTION and
909 If kind_flag is nonzero, then we check for the optional kind
910 specification. Not doing so is needed for matching an IMPLICIT
911 statement correctly. */
914 gfc_match_type_spec (gfc_typespec
* ts
, int kind_flag
)
916 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
922 if (gfc_match (" integer") == MATCH_YES
)
924 ts
->type
= BT_INTEGER
;
925 ts
->kind
= gfc_default_integer_kind ();
929 if (gfc_match (" character") == MATCH_YES
)
931 ts
->type
= BT_CHARACTER
;
932 return match_char_spec (ts
);
935 if (gfc_match (" real") == MATCH_YES
)
938 ts
->kind
= gfc_default_real_kind ();
942 if (gfc_match (" double precision") == MATCH_YES
)
945 ts
->kind
= gfc_default_double_kind ();
949 if (gfc_match (" complex") == MATCH_YES
)
951 ts
->type
= BT_COMPLEX
;
952 ts
->kind
= gfc_default_complex_kind ();
956 if (gfc_match (" double complex") == MATCH_YES
)
958 ts
->type
= BT_COMPLEX
;
959 ts
->kind
= gfc_default_double_kind ();
963 if (gfc_match (" logical") == MATCH_YES
)
965 ts
->type
= BT_LOGICAL
;
966 ts
->kind
= gfc_default_logical_kind ();
970 m
= gfc_match (" type ( %n )", name
);
974 /* Search for the name but allow the components to be defined later. */
975 if (gfc_get_ha_symbol (name
, &sym
))
977 gfc_error ("Type name '%s' at %C is ambiguous", name
);
981 if (sym
->attr
.flavor
!= FL_DERIVED
982 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
985 ts
->type
= BT_DERIVED
;
992 /* For all types except double, derived and character, look for an
993 optional kind specifier. MATCH_NO is actually OK at this point. */
997 m
= gfc_match_kind_spec (ts
);
998 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
999 m
= gfc_match_old_kind_spec (ts
);
1002 m
= MATCH_YES
; /* No kind specifier found. */
1008 /* Matches an attribute specification including array specs. If
1009 successful, leaves the variables current_attr and current_as
1010 holding the specification. Also sets the colon_seen variable for
1011 later use by matchers associated with initializations.
1013 This subroutine is a little tricky in the sense that we don't know
1014 if we really have an attr-spec until we hit the double colon.
1015 Until that time, we can only return MATCH_NO. This forces us to
1016 check for duplicate specification at this level. */
1019 match_attr_spec (void)
1022 /* Modifiers that can exist in a type statement. */
1024 { GFC_DECL_BEGIN
= 0,
1025 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1026 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1027 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1028 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1029 GFC_DECL_END
/* Sentinel */
1033 /* GFC_DECL_END is the sentinel, index starts at 0. */
1034 #define NUM_DECL GFC_DECL_END
1036 static mstring decls
[] = {
1037 minit (", allocatable", DECL_ALLOCATABLE
),
1038 minit (", dimension", DECL_DIMENSION
),
1039 minit (", external", DECL_EXTERNAL
),
1040 minit (", intent ( in )", DECL_IN
),
1041 minit (", intent ( out )", DECL_OUT
),
1042 minit (", intent ( in out )", DECL_INOUT
),
1043 minit (", intrinsic", DECL_INTRINSIC
),
1044 minit (", optional", DECL_OPTIONAL
),
1045 minit (", parameter", DECL_PARAMETER
),
1046 minit (", pointer", DECL_POINTER
),
1047 minit (", private", DECL_PRIVATE
),
1048 minit (", public", DECL_PUBLIC
),
1049 minit (", save", DECL_SAVE
),
1050 minit (", target", DECL_TARGET
),
1051 minit ("::", DECL_COLON
),
1052 minit (NULL
, DECL_NONE
)
1055 locus start
, seen_at
[NUM_DECL
];
1062 gfc_clear_attr (¤t_attr
);
1063 start
= *gfc_current_locus ();
1068 /* See if we get all of the keywords up to the final double colon. */
1069 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1074 d
= (decl_types
) gfc_match_strings (decls
);
1075 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1079 seen_at
[d
] = *gfc_current_locus ();
1081 if (d
== DECL_DIMENSION
)
1083 m
= gfc_match_array_spec (¤t_as
);
1087 gfc_error ("Missing dimension specification at %C");
1091 if (m
== MATCH_ERROR
)
1096 /* No double colon, so assume that we've been looking at something
1097 else the whole time. */
1104 /* Since we've seen a double colon, we have to be looking at an
1105 attr-spec. This means that we can now issue errors. */
1106 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1111 case DECL_ALLOCATABLE
:
1112 attr
= "ALLOCATABLE";
1114 case DECL_DIMENSION
:
1121 attr
= "INTENT (IN)";
1124 attr
= "INTENT (OUT)";
1127 attr
= "INTENT (IN OUT)";
1129 case DECL_INTRINSIC
:
1135 case DECL_PARAMETER
:
1154 attr
= NULL
; /* This shouldn't happen */
1157 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1162 /* Now that we've dealt with duplicate attributes, add the attributes
1163 to the current attribute. */
1164 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1169 if (gfc_current_state () == COMP_DERIVED
1170 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1171 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1174 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1182 case DECL_ALLOCATABLE
:
1183 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1186 case DECL_DIMENSION
:
1187 t
= gfc_add_dimension (¤t_attr
, &seen_at
[d
]);
1191 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1195 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1199 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1203 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1206 case DECL_INTRINSIC
:
1207 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1211 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1214 case DECL_PARAMETER
:
1215 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, &seen_at
[d
]);
1219 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1223 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, &seen_at
[d
]);
1227 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, &seen_at
[d
]);
1231 t
= gfc_add_save (¤t_attr
, &seen_at
[d
]);
1235 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1239 gfc_internal_error ("match_attr_spec(): Bad attribute");
1253 gfc_set_locus (&start
);
1254 gfc_free_array_spec (current_as
);
1260 /* Match a data declaration statement. */
1263 gfc_match_data_decl (void)
1268 m
= gfc_match_type_spec (¤t_ts
, 1);
1272 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1274 sym
= gfc_use_derived (current_ts
.derived
);
1282 current_ts
.derived
= sym
;
1285 m
= match_attr_spec ();
1286 if (m
== MATCH_ERROR
)
1292 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1295 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1298 if (gfc_find_symbol (current_ts
.derived
->name
,
1299 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1302 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1303 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1306 gfc_error ("Derived type at %C has not been previously defined");
1312 /* If we have an old-style character declaration, and no new-style
1313 attribute specifications, then there a comma is optional between
1314 the type specification and the variable list. */
1315 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
1316 gfc_match_char (',');
1318 /* Give the types/attributes to symbols that follow. */
1321 m
= variable_decl ();
1322 if (m
== MATCH_ERROR
)
1327 if (gfc_match_eos () == MATCH_YES
)
1329 if (gfc_match_char (',') != MATCH_YES
)
1333 gfc_error ("Syntax error in data declaration at %C");
1337 gfc_free_array_spec (current_as
);
1343 /* Match a prefix associated with a function or subroutine
1344 declaration. If the typespec pointer is nonnull, then a typespec
1345 can be matched. Note that if nothing matches, MATCH_YES is
1346 returned (the null string was matched). */
1349 match_prefix (gfc_typespec
* ts
)
1353 gfc_clear_attr (¤t_attr
);
1357 if (!seen_type
&& ts
!= NULL
1358 && gfc_match_type_spec (ts
, 1) == MATCH_YES
1359 && gfc_match_space () == MATCH_YES
)
1366 if (gfc_match ("elemental% ") == MATCH_YES
)
1368 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
1374 if (gfc_match ("pure% ") == MATCH_YES
)
1376 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
1382 if (gfc_match ("recursive% ") == MATCH_YES
)
1384 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
1390 /* At this point, the next item is not a prefix. */
1395 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
1398 copy_prefix (symbol_attribute
* dest
, locus
* where
)
1401 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
1404 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
1407 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
1414 /* Match a formal argument list. */
1417 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
1419 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
1420 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1426 if (gfc_match_char ('(') != MATCH_YES
)
1433 if (gfc_match_char (')') == MATCH_YES
)
1438 if (gfc_match_char ('*') == MATCH_YES
)
1442 m
= gfc_match_name (name
);
1446 if (gfc_get_symbol (name
, NULL
, &sym
))
1450 p
= gfc_get_formal_arglist ();
1462 /* We don't add the VARIABLE flavor because the name could be a
1463 dummy procedure. We don't apply these attributes to formal
1464 arguments of statement functions. */
1465 if (sym
!= NULL
&& !st_flag
1466 && (gfc_add_dummy (&sym
->attr
, NULL
) == FAILURE
1467 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
1473 /* The name of a program unit can be in a different namespace,
1474 so check for it explicitly. After the statement is accepted,
1475 the name is checked for especially in gfc_get_symbol(). */
1476 if (gfc_new_block
!= NULL
&& sym
!= NULL
1477 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
1479 gfc_error ("Name '%s' at %C is the name of the procedure",
1485 if (gfc_match_char (')') == MATCH_YES
)
1488 m
= gfc_match_char (',');
1491 gfc_error ("Unexpected junk in formal argument list at %C");
1497 /* Check for duplicate symbols in the formal argument list. */
1500 for (p
= head
; p
->next
; p
= p
->next
)
1505 for (q
= p
->next
; q
; q
= q
->next
)
1506 if (p
->sym
== q
->sym
)
1509 ("Duplicate symbol '%s' in formal argument list at %C",
1518 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
1528 gfc_free_formal_arglist (head
);
1533 /* Match a RESULT specification following a function declaration or
1534 ENTRY statement. Also matches the end-of-statement. */
1537 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
1539 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1543 if (gfc_match (" result (") != MATCH_YES
)
1546 m
= gfc_match_name (name
);
1550 if (gfc_match (" )%t") != MATCH_YES
)
1552 gfc_error ("Unexpected junk following RESULT variable at %C");
1556 if (strcmp (function
->name
, name
) == 0)
1559 ("RESULT variable at %C must be different than function name");
1563 if (gfc_get_symbol (name
, NULL
, &r
))
1566 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, NULL
) == FAILURE
1567 || gfc_add_result (&r
->attr
, NULL
) == FAILURE
)
1576 /* Match a function declaration. */
1579 gfc_match_function_decl (void)
1581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1582 gfc_symbol
*sym
, *result
;
1586 if (gfc_current_state () != COMP_NONE
1587 && gfc_current_state () != COMP_INTERFACE
1588 && gfc_current_state () != COMP_CONTAINS
)
1591 gfc_clear_ts (¤t_ts
);
1593 old_loc
= *gfc_current_locus ();
1595 m
= match_prefix (¤t_ts
);
1598 gfc_set_locus (&old_loc
);
1602 if (gfc_match ("function% %n", name
) != MATCH_YES
)
1604 gfc_set_locus (&old_loc
);
1608 if (get_proc_name (name
, &sym
))
1610 gfc_new_block
= sym
;
1612 m
= gfc_match_formal_arglist (sym
, 0, 0);
1614 gfc_error ("Expected formal argument list in function definition at %C");
1615 else if (m
== MATCH_ERROR
)
1620 if (gfc_match_eos () != MATCH_YES
)
1622 /* See if a result variable is present. */
1623 m
= match_result (sym
, &result
);
1625 gfc_error ("Unexpected junk after function declaration at %C");
1634 /* Make changes to the symbol. */
1637 if (gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
1640 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
1641 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
1644 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
1646 gfc_error ("Function '%s' at %C already has a type of %s", name
,
1647 gfc_basic_typename (sym
->ts
.type
));
1653 sym
->ts
= current_ts
;
1658 result
->ts
= current_ts
;
1659 sym
->result
= result
;
1665 gfc_set_locus (&old_loc
);
1670 /* Match an ENTRY statement. */
1673 gfc_match_entry (void)
1675 gfc_symbol
*function
, *result
, *entry
;
1676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1677 gfc_compile_state state
;
1680 m
= gfc_match_name (name
);
1684 if (get_proc_name (name
, &entry
))
1687 gfc_enclosing_unit (&state
);
1690 case COMP_SUBROUTINE
:
1691 m
= gfc_match_formal_arglist (entry
, 0, 1);
1695 if (gfc_current_state () != COMP_SUBROUTINE
)
1696 goto exec_construct
;
1698 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1699 || gfc_add_subroutine (&entry
->attr
, NULL
) == FAILURE
)
1705 m
= gfc_match_formal_arglist (entry
, 0, 0);
1709 if (gfc_current_state () != COMP_FUNCTION
)
1710 goto exec_construct
;
1711 function
= gfc_state_stack
->sym
;
1715 if (gfc_match_eos () == MATCH_YES
)
1717 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1718 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
1721 entry
->result
= function
->result
;
1726 m
= match_result (function
, &result
);
1728 gfc_syntax_error (ST_ENTRY
);
1732 if (gfc_add_result (&result
->attr
, NULL
) == FAILURE
1733 || gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
1734 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
1738 if (function
->attr
.recursive
&& result
== NULL
)
1740 gfc_error ("RESULT attribute required in ENTRY statement at %C");
1747 goto exec_construct
;
1750 if (gfc_match_eos () != MATCH_YES
)
1752 gfc_syntax_error (ST_ENTRY
);
1759 gfc_error ("ENTRY statement at %C cannot appear within %s",
1760 gfc_state_name (gfc_current_state ()));
1766 /* Match a subroutine statement, including optional prefixes. */
1769 gfc_match_subroutine (void)
1771 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1775 if (gfc_current_state () != COMP_NONE
1776 && gfc_current_state () != COMP_INTERFACE
1777 && gfc_current_state () != COMP_CONTAINS
)
1780 m
= match_prefix (NULL
);
1784 m
= gfc_match ("subroutine% %n", name
);
1788 if (get_proc_name (name
, &sym
))
1790 gfc_new_block
= sym
;
1792 if (gfc_add_subroutine (&sym
->attr
, NULL
) == FAILURE
)
1795 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
1798 if (gfc_match_eos () != MATCH_YES
)
1800 gfc_syntax_error (ST_SUBROUTINE
);
1804 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
1811 /* Match any of the various end-block statements. Returns the type of
1812 END to the caller. The END INTERFACE, END IF, END DO and END
1813 SELECT statements cannot be replaced by a single END statement. */
1816 gfc_match_end (gfc_statement
* st
)
1818 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1819 gfc_compile_state state
;
1821 const char *block_name
;
1825 old_loc
= *gfc_current_locus ();
1826 if (gfc_match ("end") != MATCH_YES
)
1829 state
= gfc_current_state ();
1831 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
1833 if (state
== COMP_CONTAINS
)
1835 state
= gfc_state_stack
->previous
->state
;
1836 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
1837 : gfc_state_stack
->previous
->sym
->name
;
1844 *st
= ST_END_PROGRAM
;
1845 target
= " program";
1848 case COMP_SUBROUTINE
:
1849 *st
= ST_END_SUBROUTINE
;
1850 target
= " subroutine";
1854 *st
= ST_END_FUNCTION
;
1855 target
= " function";
1858 case COMP_BLOCK_DATA
:
1859 *st
= ST_END_BLOCK_DATA
;
1860 target
= " block data";
1864 *st
= ST_END_MODULE
;
1868 case COMP_INTERFACE
:
1869 *st
= ST_END_INTERFACE
;
1870 target
= " interface";
1889 *st
= ST_END_SELECT
;
1894 *st
= ST_END_FORALL
;
1904 gfc_error ("Unexpected END statement at %C");
1908 if (gfc_match_eos () == MATCH_YES
)
1911 if (*st
== ST_ENDIF
|| *st
== ST_ENDDO
|| *st
== ST_END_SELECT
1912 || *st
== ST_END_INTERFACE
|| *st
== ST_END_FORALL
1913 || *st
== ST_END_WHERE
)
1916 gfc_error ("%s statement expected at %C",
1917 gfc_ascii_statement (*st
));
1924 /* Verify that we've got the sort of end-block that we're expecting. */
1925 if (gfc_match (target
) != MATCH_YES
)
1927 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
1931 /* If we're at the end, make sure a block name wasn't required. */
1932 if (gfc_match_eos () == MATCH_YES
)
1935 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
1938 if (gfc_current_block () == NULL
)
1941 gfc_error ("Expected block name of '%s' in %s statement at %C",
1942 block_name
, gfc_ascii_statement (*st
));
1947 /* END INTERFACE has a special handler for its several possible endings. */
1948 if (*st
== ST_END_INTERFACE
)
1949 return gfc_match_end_interface ();
1951 /* We haven't hit the end of statement, so what is left must be an end-name. */
1952 m
= gfc_match_space ();
1954 m
= gfc_match_name (name
);
1957 gfc_error ("Expected terminating name at %C");
1961 if (block_name
== NULL
)
1964 if (strcmp (name
, block_name
) != 0)
1966 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
1967 gfc_ascii_statement (*st
));
1971 if (gfc_match_eos () == MATCH_YES
)
1975 gfc_syntax_error (*st
);
1978 gfc_set_locus (&old_loc
);
1984 /***************** Attribute declaration statements ****************/
1986 /* Set the attribute of a single variable. */
1991 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1999 m
= gfc_match_name (name
);
2003 if (find_special (name
, &sym
))
2006 var_locus
= *gfc_current_locus ();
2008 /* Deal with possible array specification for certain attributes. */
2009 if (current_attr
.dimension
2010 || current_attr
.allocatable
2011 || current_attr
.pointer
2012 || current_attr
.target
)
2014 m
= gfc_match_array_spec (&as
);
2015 if (m
== MATCH_ERROR
)
2018 if (current_attr
.dimension
&& m
== MATCH_NO
)
2021 ("Missing array specification at %L in DIMENSION statement",
2027 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2028 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2030 gfc_error ("Array specification must be deferred at %L",
2037 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2038 if (current_attr
.dimension
== 0
2039 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2045 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2051 if ((current_attr
.external
|| current_attr
.intrinsic
)
2052 && sym
->attr
.flavor
!= FL_PROCEDURE
2053 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, NULL
) == FAILURE
)
2062 gfc_free_array_spec (as
);
2067 /* Generic attribute declaration subroutine. Used for attributes that
2068 just have a list of names. */
2075 /* Gobble the optional double colon, by simply ignoring the result
2085 if (gfc_match_eos () == MATCH_YES
)
2091 if (gfc_match_char (',') != MATCH_YES
)
2093 gfc_error ("Unexpected character in variable list at %C");
2104 gfc_match_external (void)
2107 gfc_clear_attr (¤t_attr
);
2108 gfc_add_external (¤t_attr
, NULL
);
2110 return attr_decl ();
2116 gfc_match_intent (void)
2120 intent
= match_intent_spec ();
2121 if (intent
== INTENT_UNKNOWN
)
2124 gfc_clear_attr (¤t_attr
);
2125 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2127 return attr_decl ();
2132 gfc_match_intrinsic (void)
2135 gfc_clear_attr (¤t_attr
);
2136 gfc_add_intrinsic (¤t_attr
, NULL
);
2138 return attr_decl ();
2143 gfc_match_optional (void)
2146 gfc_clear_attr (¤t_attr
);
2147 gfc_add_optional (¤t_attr
, NULL
);
2149 return attr_decl ();
2154 gfc_match_pointer (void)
2157 gfc_clear_attr (¤t_attr
);
2158 gfc_add_pointer (¤t_attr
, NULL
);
2160 return attr_decl ();
2165 gfc_match_allocatable (void)
2168 gfc_clear_attr (¤t_attr
);
2169 gfc_add_allocatable (¤t_attr
, NULL
);
2171 return attr_decl ();
2176 gfc_match_dimension (void)
2179 gfc_clear_attr (¤t_attr
);
2180 gfc_add_dimension (¤t_attr
, NULL
);
2182 return attr_decl ();
2187 gfc_match_target (void)
2190 gfc_clear_attr (¤t_attr
);
2191 gfc_add_target (¤t_attr
, NULL
);
2193 return attr_decl ();
2197 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2201 access_attr_decl (gfc_statement st
)
2203 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2204 interface_type type
;
2207 gfc_intrinsic_op
operator;
2210 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2215 m
= gfc_match_generic_spec (&type
, name
, &operator);
2218 if (m
== MATCH_ERROR
)
2223 case INTERFACE_NAMELESS
:
2226 case INTERFACE_GENERIC
:
2227 if (gfc_get_symbol (name
, NULL
, &sym
))
2230 if (gfc_add_access (&sym
->attr
,
2232 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2238 case INTERFACE_INTRINSIC_OP
:
2239 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2241 gfc_current_ns
->operator_access
[operator] =
2242 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2246 gfc_error ("Access specification of the %s operator at %C has "
2247 "already been specified", gfc_op2string (operator));
2253 case INTERFACE_USER_OP
:
2254 uop
= gfc_get_uop (name
);
2256 if (uop
->access
== ACCESS_UNKNOWN
)
2259 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2264 ("Access specification of the .%s. operator at %C has "
2265 "already been specified", sym
->name
);
2272 if (gfc_match_char (',') == MATCH_NO
)
2276 if (gfc_match_eos () != MATCH_YES
)
2281 gfc_syntax_error (st
);
2288 /* The PRIVATE statement is a bit weird in that it can be a attribute
2289 declaration, but also works as a standlone statement inside of a
2290 type declaration or a module. */
2293 gfc_match_private (gfc_statement
* st
)
2296 if (gfc_match ("private") != MATCH_YES
)
2299 if (gfc_current_state () == COMP_DERIVED
)
2301 if (gfc_match_eos () == MATCH_YES
)
2307 gfc_syntax_error (ST_PRIVATE
);
2311 if (gfc_match_eos () == MATCH_YES
)
2318 return access_attr_decl (ST_PRIVATE
);
2323 gfc_match_public (gfc_statement
* st
)
2326 if (gfc_match ("public") != MATCH_YES
)
2329 if (gfc_match_eos () == MATCH_YES
)
2336 return access_attr_decl (ST_PUBLIC
);
2340 /* Workhorse for gfc_match_parameter. */
2349 m
= gfc_match_symbol (&sym
, 0);
2351 gfc_error ("Expected variable name at %C in PARAMETER statement");
2356 if (gfc_match_char ('=') == MATCH_NO
)
2358 gfc_error ("Expected = sign in PARAMETER statement at %C");
2362 m
= gfc_match_init_expr (&init
);
2364 gfc_error ("Expected expression at %C in PARAMETER statement");
2368 if (sym
->ts
.type
== BT_UNKNOWN
2369 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2375 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
2376 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, NULL
) == FAILURE
)
2386 gfc_free_expr (init
);
2391 /* Match a parameter statement, with the weird syntax that these have. */
2394 gfc_match_parameter (void)
2398 if (gfc_match_char ('(') == MATCH_NO
)
2407 if (gfc_match (" )%t") == MATCH_YES
)
2410 if (gfc_match_char (',') != MATCH_YES
)
2412 gfc_error ("Unexpected characters in PARAMETER statement at %C");
2422 /* Save statements have a special syntax. */
2425 gfc_match_save (void)
2430 if (gfc_match_eos () == MATCH_YES
)
2432 if (gfc_current_ns
->seen_save
)
2434 gfc_error ("Blanket SAVE statement at %C follows previous "
2440 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
2444 if (gfc_current_ns
->save_all
)
2446 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2454 m
= gfc_match_symbol (&sym
, 0);
2458 if (gfc_add_save (&sym
->attr
, gfc_current_locus ()) == FAILURE
)
2469 m
= gfc_match (" / %s /", &sym
);
2470 if (m
== MATCH_ERROR
)
2475 if (gfc_add_saved_common (&sym
->attr
, NULL
) == FAILURE
)
2477 gfc_current_ns
->seen_save
= 1;
2480 if (gfc_match_eos () == MATCH_YES
)
2482 if (gfc_match_char (',') != MATCH_YES
)
2489 gfc_error ("Syntax error in SAVE statement at %C");
2494 /* Match a module procedure statement. Note that we have to modify
2495 symbols in the parent's namespace because the current one was there
2496 to receive symbols that are in a interface's formal argument list. */
2499 gfc_match_modproc (void)
2501 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2505 if (gfc_state_stack
->state
!= COMP_INTERFACE
2506 || gfc_state_stack
->previous
== NULL
2507 || current_interface
.type
== INTERFACE_NAMELESS
)
2510 ("MODULE PROCEDURE at %C must be in a generic module interface");
2516 m
= gfc_match_name (name
);
2522 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
2525 if (sym
->attr
.proc
!= PROC_MODULE
2526 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
, NULL
) == FAILURE
)
2529 if (gfc_add_interface (sym
) == FAILURE
)
2532 if (gfc_match_eos () == MATCH_YES
)
2534 if (gfc_match_char (',') != MATCH_YES
)
2541 gfc_syntax_error (ST_MODULE_PROC
);
2546 /* Match the beginning of a derived type declaration. If a type name
2547 was the result of a function, then it is possible to have a symbol
2548 already to be known as a derived type yet have no components. */
2551 gfc_match_derived_decl (void)
2553 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2554 symbol_attribute attr
;
2558 if (gfc_current_state () == COMP_DERIVED
)
2561 gfc_clear_attr (&attr
);
2564 if (gfc_match (" , private") == MATCH_YES
)
2566 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
2569 ("Derived type at %C can only be PRIVATE within a MODULE");
2573 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
) == FAILURE
)
2578 if (gfc_match (" , public") == MATCH_YES
)
2580 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
2582 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2586 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
) == FAILURE
)
2591 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
2593 gfc_error ("Expected :: in TYPE definition at %C");
2597 m
= gfc_match (" %n%t", name
);
2601 /* Make sure the name isn't the name of an intrinsic type. The
2602 'double precision' type doesn't get past the name matcher. */
2603 if (strcmp (name
, "integer") == 0
2604 || strcmp (name
, "real") == 0
2605 || strcmp (name
, "character") == 0
2606 || strcmp (name
, "logical") == 0
2607 || strcmp (name
, "complex") == 0)
2610 ("Type name '%s' at %C cannot be the same as an intrinsic type",
2615 if (gfc_get_symbol (name
, NULL
, &sym
))
2618 if (sym
->ts
.type
!= BT_UNKNOWN
)
2620 gfc_error ("Derived type name '%s' at %C already has a basic type "
2621 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
2625 /* The symbol may already have the derived attribute without the
2626 components. The ways this can happen is via a function
2627 definition, an INTRINSIC statement or a subtype in another
2628 derived type that is a pointer. The first part of the AND clause
2629 is true if a the symbol is not the return value of a function. */
2630 if (sym
->attr
.flavor
!= FL_DERIVED
2631 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
2634 if (sym
->components
!= NULL
)
2637 ("Derived type definition of '%s' at %C has already been defined",
2642 if (attr
.access
!= ACCESS_UNKNOWN
2643 && gfc_add_access (&sym
->attr
, attr
.access
, NULL
) == FAILURE
)
2646 gfc_new_block
= sym
;