1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* This flag is set if an old-style length selector is matched
30 during a type-declaration statement. */
32 static int old_char_selector
;
34 /* When variables acquire types and attributes from a declaration
35 statement, they get them from the following static variables. The
36 first part of a declaration sets these variables and the second
37 part copies these into symbol structures. */
39 static gfc_typespec current_ts
;
41 static symbol_attribute current_attr
;
42 static gfc_array_spec
*current_as
;
43 static int colon_seen
;
45 /* Initializer of the previous enumerator. */
47 static gfc_expr
*last_initializer
;
49 /* History of all the enumerators is maintained, so that
50 kind values of all the enumerators could be updated depending
51 upon the maximum initialized value. */
53 typedef struct enumerator_history
56 gfc_expr
*initializer
;
57 struct enumerator_history
*next
;
61 /* Header of enum history chain. */
63 static enumerator_history
*enum_history
= NULL
;
65 /* Pointer of enum history node containing largest initializer. */
67 static enumerator_history
*max_enum
= NULL
;
69 /* gfc_new_block points to the symbol of a newly matched block. */
71 gfc_symbol
*gfc_new_block
;
74 /********************* DATA statement subroutines *********************/
76 static bool in_match_data
= false;
79 gfc_in_match_data (void)
85 gfc_set_in_match_data (bool set_value
)
87 in_match_data
= set_value
;
90 /* Free a gfc_data_variable structure and everything beneath it. */
93 free_variable (gfc_data_variable
*p
)
100 gfc_free_expr (p
->expr
);
101 gfc_free_iterator (&p
->iter
, 0);
102 free_variable (p
->list
);
108 /* Free a gfc_data_value structure and everything beneath it. */
111 free_value (gfc_data_value
*p
)
118 gfc_free_expr (p
->expr
);
124 /* Free a list of gfc_data structures. */
127 gfc_free_data (gfc_data
*p
)
134 free_variable (p
->var
);
135 free_value (p
->value
);
141 /* Free all data in a namespace. */
144 gfc_free_data_all (gfc_namespace
* ns
)
157 static match
var_element (gfc_data_variable
*);
159 /* Match a list of variables terminated by an iterator and a right
163 var_list (gfc_data_variable
*parent
)
165 gfc_data_variable
*tail
, var
;
168 m
= var_element (&var
);
169 if (m
== MATCH_ERROR
)
174 tail
= gfc_get_data_variable ();
181 if (gfc_match_char (',') != MATCH_YES
)
184 m
= gfc_match_iterator (&parent
->iter
, 1);
187 if (m
== MATCH_ERROR
)
190 m
= var_element (&var
);
191 if (m
== MATCH_ERROR
)
196 tail
->next
= gfc_get_data_variable ();
202 if (gfc_match_char (')') != MATCH_YES
)
207 gfc_syntax_error (ST_DATA
);
212 /* Match a single element in a data variable list, which can be a
213 variable-iterator list. */
216 var_element (gfc_data_variable
*new)
221 memset (new, 0, sizeof (gfc_data_variable
));
223 if (gfc_match_char ('(') == MATCH_YES
)
224 return var_list (new);
226 m
= gfc_match_variable (&new->expr
, 0);
230 sym
= new->expr
->symtree
->n
.sym
;
232 if (!sym
->attr
.function
&& gfc_current_ns
->parent
233 && gfc_current_ns
->parent
== sym
->ns
)
235 gfc_error ("Host associated variable '%s' may not be in the DATA "
236 "statement at %C", sym
->name
);
240 if (gfc_current_state () != COMP_BLOCK_DATA
241 && sym
->attr
.in_common
242 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
243 "common block variable '%s' in DATA statement at %C",
244 sym
->name
) == FAILURE
)
247 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
254 /* Match the top-level list of data variables. */
257 top_var_list (gfc_data
*d
)
259 gfc_data_variable var
, *tail
, *new;
266 m
= var_element (&var
);
269 if (m
== MATCH_ERROR
)
272 new = gfc_get_data_variable ();
282 if (gfc_match_char ('/') == MATCH_YES
)
284 if (gfc_match_char (',') != MATCH_YES
)
291 gfc_syntax_error (ST_DATA
);
292 gfc_free_data_all (gfc_current_ns
);
298 match_data_constant (gfc_expr
**result
)
300 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
305 m
= gfc_match_literal_constant (&expr
, 1);
312 if (m
== MATCH_ERROR
)
315 m
= gfc_match_null (result
);
319 m
= gfc_match_name (name
);
323 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
327 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
329 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
333 else if (sym
->attr
.flavor
== FL_DERIVED
)
334 return gfc_match_structure_constructor (sym
, result
);
336 *result
= gfc_copy_expr (sym
->value
);
341 /* Match a list of values in a DATA statement. The leading '/' has
342 already been seen at this point. */
345 top_val_list (gfc_data
*data
)
347 gfc_data_value
*new, *tail
;
356 m
= match_data_constant (&expr
);
359 if (m
== MATCH_ERROR
)
362 new = gfc_get_data_value ();
371 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
379 msg
= gfc_extract_int (expr
, &tmp
);
380 gfc_free_expr (expr
);
388 m
= match_data_constant (&tail
->expr
);
391 if (m
== MATCH_ERROR
)
395 if (gfc_match_char ('/') == MATCH_YES
)
397 if (gfc_match_char (',') == MATCH_NO
)
404 gfc_syntax_error (ST_DATA
);
405 gfc_free_data_all (gfc_current_ns
);
410 /* Matches an old style initialization. */
413 match_old_style_init (const char *name
)
420 /* Set up data structure to hold initializers. */
421 gfc_find_sym_tree (name
, NULL
, 0, &st
);
424 newdata
= gfc_get_data ();
425 newdata
->var
= gfc_get_data_variable ();
426 newdata
->var
->expr
= gfc_get_variable_expr (st
);
427 newdata
->where
= gfc_current_locus
;
429 /* Match initial value list. This also eats the terminal
431 m
= top_val_list (newdata
);
440 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
445 /* Mark the variable as having appeared in a data statement. */
446 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
452 /* Chain in namespace list of DATA initializers. */
453 newdata
->next
= gfc_current_ns
->data
;
454 gfc_current_ns
->data
= newdata
;
460 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
461 we are matching a DATA statement and are therefore issuing an error
462 if we encounter something unexpected, if not, we're trying to match
463 an old-style initialization expression of the form INTEGER I /2/. */
466 gfc_match_data (void)
471 gfc_set_in_match_data (true);
475 new = gfc_get_data ();
476 new->where
= gfc_current_locus
;
478 m
= top_var_list (new);
482 m
= top_val_list (new);
486 new->next
= gfc_current_ns
->data
;
487 gfc_current_ns
->data
= new;
489 if (gfc_match_eos () == MATCH_YES
)
492 gfc_match_char (','); /* Optional comma */
495 gfc_set_in_match_data (false);
499 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
506 gfc_set_in_match_data (false);
512 /************************ Declaration statements *********************/
514 /* Match an intent specification. Since this can only happen after an
515 INTENT word, a legal intent-spec must follow. */
518 match_intent_spec (void)
521 if (gfc_match (" ( in out )") == MATCH_YES
)
523 if (gfc_match (" ( in )") == MATCH_YES
)
525 if (gfc_match (" ( out )") == MATCH_YES
)
528 gfc_error ("Bad INTENT specification at %C");
529 return INTENT_UNKNOWN
;
533 /* Matches a character length specification, which is either a
534 specification expression or a '*'. */
537 char_len_param_value (gfc_expr
**expr
)
539 if (gfc_match_char ('*') == MATCH_YES
)
545 return gfc_match_expr (expr
);
549 /* A character length is a '*' followed by a literal integer or a
550 char_len_param_value in parenthesis. */
553 match_char_length (gfc_expr
**expr
)
558 m
= gfc_match_char ('*');
562 m
= gfc_match_small_literal_int (&length
, NULL
);
563 if (m
== MATCH_ERROR
)
568 *expr
= gfc_int_expr (length
);
572 if (gfc_match_char ('(') == MATCH_NO
)
575 m
= char_len_param_value (expr
);
576 if (m
== MATCH_ERROR
)
581 if (gfc_match_char (')') == MATCH_NO
)
583 gfc_free_expr (*expr
);
591 gfc_error ("Syntax error in character length specification at %C");
596 /* Special subroutine for finding a symbol. Check if the name is found
597 in the current name space. If not, and we're compiling a function or
598 subroutine and the parent compilation unit is an interface, then check
599 to see if the name we've been given is the name of the interface
600 (located in another namespace). */
603 find_special (const char *name
, gfc_symbol
**result
)
608 i
= gfc_get_symbol (name
, NULL
, result
);
612 if (gfc_current_state () != COMP_SUBROUTINE
613 && gfc_current_state () != COMP_FUNCTION
)
616 s
= gfc_state_stack
->previous
;
620 if (s
->state
!= COMP_INTERFACE
)
623 goto end
; /* Nameless interface */
625 if (strcmp (name
, s
->sym
->name
) == 0)
636 /* Special subroutine for getting a symbol node associated with a
637 procedure name, used in SUBROUTINE and FUNCTION statements. The
638 symbol is created in the parent using with symtree node in the
639 child unit pointing to the symbol. If the current namespace has no
640 parent, then the symbol is just created in the current unit. */
643 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
649 /* Module functions have to be left in their own namespace because
650 they have potentially (almost certainly!) already been referenced.
651 In this sense, they are rather like external functions. This is
652 fixed up in resolve.c(resolve_entries), where the symbol name-
653 space is set to point to the master function, so that the fake
654 result mechanism can work. */
655 if (module_fcn_entry
)
656 rc
= gfc_get_symbol (name
, NULL
, result
);
658 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
661 gfc_current_ns
->refs
++;
663 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
665 /* Trap another encompassed procedure with the same name. All
666 these conditions are necessary to avoid picking up an entry
667 whose name clashes with that of the encompassing procedure;
668 this is handled using gsymbols to register unique,globally
670 if (sym
->attr
.flavor
!= 0
671 && sym
->attr
.proc
!= 0
672 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
673 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
674 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
675 name
, &sym
->declared_at
);
677 /* Trap declarations of attributes in encompassing scope. The
678 signature for this is that ts.kind is set. Legitimate
679 references only set ts.type. */
680 if (sym
->ts
.kind
!= 0
681 && !sym
->attr
.implicit_type
682 && sym
->attr
.proc
== 0
683 && gfc_current_ns
->parent
!= NULL
684 && sym
->attr
.access
== 0
685 && !module_fcn_entry
)
686 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
687 "and must not have attributes declared at %L",
688 name
, &sym
->declared_at
);
691 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
694 /* Module function entries will already have a symtree in
695 the current namespace but will need one at module level. */
696 if (module_fcn_entry
)
697 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
699 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
704 /* See if the procedure should be a module procedure */
706 if (((sym
->ns
->proc_name
!= NULL
707 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
708 && sym
->attr
.proc
!= PROC_MODULE
) || module_fcn_entry
)
709 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
710 sym
->name
, NULL
) == FAILURE
)
717 /* Function called by variable_decl() that adds a name to the symbol
721 build_sym (const char *name
, gfc_charlen
*cl
,
722 gfc_array_spec
**as
, locus
*var_locus
)
724 symbol_attribute attr
;
727 if (gfc_get_symbol (name
, NULL
, &sym
))
730 /* Start updating the symbol table. Add basic type attribute
732 if (current_ts
.type
!= BT_UNKNOWN
733 && (sym
->attr
.implicit_type
== 0
734 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
735 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
738 if (sym
->ts
.type
== BT_CHARACTER
)
741 /* Add dimension attribute if present. */
742 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
746 /* Add attribute to symbol. The copy is so that we can reset the
747 dimension attribute. */
751 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
758 /* Set character constant to the given length. The constant will be padded or
762 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, bool array
)
767 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
768 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
770 slen
= expr
->value
.character
.length
;
773 s
= gfc_getmem (len
+ 1);
774 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
776 memset (&s
[slen
], ' ', len
- slen
);
778 if (gfc_option
.warn_character_truncation
&& slen
> len
)
779 gfc_warning_now ("CHARACTER expression at %L is being truncated "
780 "(%d/%d)", &expr
->where
, slen
, len
);
782 /* Apply the standard by 'hand' otherwise it gets cleared for
784 if (array
&& slen
< len
&& !(gfc_option
.allow_std
& GFC_STD_GNU
))
785 gfc_error_now ("The CHARACTER elements of the array constructor "
786 "at %L must have the same length (%d/%d)",
787 &expr
->where
, slen
, len
);
790 gfc_free (expr
->value
.character
.string
);
791 expr
->value
.character
.string
= s
;
792 expr
->value
.character
.length
= len
;
797 /* Function to create and update the enumerator history
798 using the information passed as arguments.
799 Pointer "max_enum" is also updated, to point to
800 enum history node containing largest initializer.
802 SYM points to the symbol node of enumerator.
803 INIT points to its enumerator value. */
806 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
808 enumerator_history
*new_enum_history
;
809 gcc_assert (sym
!= NULL
&& init
!= NULL
);
811 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
813 new_enum_history
->sym
= sym
;
814 new_enum_history
->initializer
= init
;
815 new_enum_history
->next
= NULL
;
817 if (enum_history
== NULL
)
819 enum_history
= new_enum_history
;
820 max_enum
= enum_history
;
824 new_enum_history
->next
= enum_history
;
825 enum_history
= new_enum_history
;
827 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
828 new_enum_history
->initializer
->value
.integer
) < 0)
829 max_enum
= new_enum_history
;
834 /* Function to free enum kind history. */
837 gfc_free_enum_history (void)
839 enumerator_history
*current
= enum_history
;
840 enumerator_history
*next
;
842 while (current
!= NULL
)
844 next
= current
->next
;
853 /* Function called by variable_decl() that adds an initialization
854 expression to a symbol. */
857 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
,
860 symbol_attribute attr
;
865 if (find_special (name
, &sym
))
870 /* If this symbol is confirming an implicit parameter type,
871 then an initialization expression is not allowed. */
872 if (attr
.flavor
== FL_PARAMETER
873 && sym
->value
!= NULL
876 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
885 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
892 /* An initializer is required for PARAMETER declarations. */
893 if (attr
.flavor
== FL_PARAMETER
)
895 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
901 /* If a variable appears in a DATA block, it cannot have an
905 gfc_error ("Variable '%s' at %C with an initializer already "
906 "appears in a DATA statement", sym
->name
);
910 /* Check if the assignment can happen. This has to be put off
911 until later for a derived type variable. */
912 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
913 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
916 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
918 /* Update symbol character length according initializer. */
919 if (sym
->ts
.cl
->length
== NULL
)
921 /* If there are multiple CHARACTER variables declared on
922 the same line, we don't want them to share the same
924 sym
->ts
.cl
= gfc_get_charlen ();
925 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
926 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
928 if (sym
->attr
.flavor
== FL_PARAMETER
929 && init
->expr_type
== EXPR_ARRAY
)
930 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
932 /* Update initializer character length according symbol. */
933 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
935 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
938 if (init
->expr_type
== EXPR_CONSTANT
)
939 gfc_set_constant_character_len (len
, init
, false);
940 else if (init
->expr_type
== EXPR_ARRAY
)
942 /* Build a new charlen to prevent simplification from
943 deleting the length before it is resolved. */
944 init
->ts
.cl
= gfc_get_charlen ();
945 init
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
946 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
947 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
949 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
950 gfc_set_constant_character_len (len
, p
->expr
, false);
955 /* Add initializer. Make sure we keep the ranks sane. */
956 if (sym
->attr
.dimension
&& init
->rank
== 0)
957 init
->rank
= sym
->as
->rank
;
967 /* Function called by variable_decl() that adds a name to a structure
971 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
976 /* If the current symbol is of the same derived type that we're
977 constructing, it must have the pointer attribute. */
978 if (current_ts
.type
== BT_DERIVED
979 && current_ts
.derived
== gfc_current_block ()
980 && current_attr
.pointer
== 0)
982 gfc_error ("Component at %C must have the POINTER attribute");
986 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
988 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
990 gfc_error ("Array component of structure at %C must have explicit "
991 "or deferred shape");
996 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
1001 gfc_set_component_attr (c
, ¤t_attr
);
1003 c
->initializer
= *init
;
1011 /* Check array components. */
1016 gfc_error ("Allocatable component at %C must be an array");
1025 if (c
->as
->type
!= AS_DEFERRED
)
1027 gfc_error ("Pointer array component of structure at %C must have a "
1032 else if (c
->allocatable
)
1034 if (c
->as
->type
!= AS_DEFERRED
)
1036 gfc_error ("Allocatable component of structure at %C must have a "
1043 if (c
->as
->type
!= AS_EXPLICIT
)
1045 gfc_error ("Array component of structure at %C must have an "
1055 /* Match a 'NULL()', and possibly take care of some side effects. */
1058 gfc_match_null (gfc_expr
**result
)
1064 m
= gfc_match (" null ( )");
1068 /* The NULL symbol now has to be/become an intrinsic function. */
1069 if (gfc_get_symbol ("null", NULL
, &sym
))
1071 gfc_error ("NULL() initialization at %C is ambiguous");
1075 gfc_intrinsic_symbol (sym
);
1077 if (sym
->attr
.proc
!= PROC_INTRINSIC
1078 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1079 sym
->name
, NULL
) == FAILURE
1080 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1083 e
= gfc_get_expr ();
1084 e
->where
= gfc_current_locus
;
1085 e
->expr_type
= EXPR_NULL
;
1086 e
->ts
.type
= BT_UNKNOWN
;
1094 /* Match a variable name with an optional initializer. When this
1095 subroutine is called, a variable is expected to be parsed next.
1096 Depending on what is happening at the moment, updates either the
1097 symbol table or the current interface. */
1100 variable_decl (int elem
)
1102 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1103 gfc_expr
*initializer
, *char_len
;
1105 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1116 old_locus
= gfc_current_locus
;
1118 /* When we get here, we've just matched a list of attributes and
1119 maybe a type and a double colon. The next thing we expect to see
1120 is the name of the symbol. */
1121 m
= gfc_match_name (name
);
1125 var_locus
= gfc_current_locus
;
1127 /* Now we could see the optional array spec. or character length. */
1128 m
= gfc_match_array_spec (&as
);
1129 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1130 cp_as
= gfc_copy_array_spec (as
);
1131 else if (m
== MATCH_ERROR
)
1135 as
= gfc_copy_array_spec (current_as
);
1140 if (current_ts
.type
== BT_CHARACTER
)
1142 switch (match_char_length (&char_len
))
1145 cl
= gfc_get_charlen ();
1146 cl
->next
= gfc_current_ns
->cl_list
;
1147 gfc_current_ns
->cl_list
= cl
;
1149 cl
->length
= char_len
;
1152 /* Non-constant lengths need to be copied after the first
1155 if (elem
> 1 && current_ts
.cl
->length
1156 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1158 cl
= gfc_get_charlen ();
1159 cl
->next
= gfc_current_ns
->cl_list
;
1160 gfc_current_ns
->cl_list
= cl
;
1161 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1173 /* If this symbol has already shown up in a Cray Pointer declaration,
1174 then we want to set the type & bail out. */
1175 if (gfc_option
.flag_cray_pointer
)
1177 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1178 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1180 sym
->ts
.type
= current_ts
.type
;
1181 sym
->ts
.kind
= current_ts
.kind
;
1183 sym
->ts
.derived
= current_ts
.derived
;
1186 /* Check to see if we have an array specification. */
1189 if (sym
->as
!= NULL
)
1191 gfc_error ("Duplicate array spec for Cray pointee at %C");
1192 gfc_free_array_spec (cp_as
);
1198 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1199 gfc_internal_error ("Couldn't set pointee array spec.");
1201 /* Fix the array spec. */
1202 m
= gfc_mod_pointee_as (sym
->as
);
1203 if (m
== MATCH_ERROR
)
1211 gfc_free_array_spec (cp_as
);
1216 /* OK, we've successfully matched the declaration. Now put the
1217 symbol in the current namespace, because it might be used in the
1218 optional initialization expression for this symbol, e.g. this is
1221 integer, parameter :: i = huge(i)
1223 This is only true for parameters or variables of a basic type.
1224 For components of derived types, it is not true, so we don't
1225 create a symbol for those yet. If we fail to create the symbol,
1227 if (gfc_current_state () != COMP_DERIVED
1228 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1234 /* An interface body specifies all of the procedure's
1235 characteristics and these shall be consistent with those
1236 specified in the procedure definition, except that the interface
1237 may specify a procedure that is not pure if the procedure is
1238 defined to be pure(12.3.2). */
1239 if (current_ts
.type
== BT_DERIVED
1240 && gfc_current_ns
->proc_name
1241 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1242 && current_ts
.derived
->ns
!= gfc_current_ns
1243 && !gfc_current_ns
->has_import_set
)
1245 gfc_error ("the type of '%s' at %C has not been declared within the "
1251 /* In functions that have a RESULT variable defined, the function
1252 name always refers to function calls. Therefore, the name is
1253 not allowed to appear in specification statements. */
1254 if (gfc_current_state () == COMP_FUNCTION
1255 && gfc_current_block () != NULL
1256 && gfc_current_block ()->result
!= NULL
1257 && gfc_current_block ()->result
!= gfc_current_block ()
1258 && strcmp (gfc_current_block ()->name
, name
) == 0)
1260 gfc_error ("Function name '%s' not allowed at %C", name
);
1265 /* We allow old-style initializations of the form
1266 integer i /2/, j(4) /3*3, 1/
1267 (if no colon has been seen). These are different from data
1268 statements in that initializers are only allowed to apply to the
1269 variable immediately preceding, i.e.
1271 is not allowed. Therefore we have to do some work manually, that
1272 could otherwise be left to the matchers for DATA statements. */
1274 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1276 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1277 "initialization at %C") == FAILURE
)
1280 return match_old_style_init (name
);
1283 /* The double colon must be present in order to have initializers.
1284 Otherwise the statement is ambiguous with an assignment statement. */
1287 if (gfc_match (" =>") == MATCH_YES
)
1289 if (!current_attr
.pointer
)
1291 gfc_error ("Initialization at %C isn't for a pointer variable");
1296 m
= gfc_match_null (&initializer
);
1299 gfc_error ("Pointer initialization requires a NULL() at %C");
1303 if (gfc_pure (NULL
))
1305 gfc_error ("Initialization of pointer at %C is not allowed in "
1306 "a PURE procedure");
1314 else if (gfc_match_char ('=') == MATCH_YES
)
1316 if (current_attr
.pointer
)
1318 gfc_error ("Pointer initialization at %C requires '=>', "
1324 m
= gfc_match_init_expr (&initializer
);
1327 gfc_error ("Expected an initialization expression at %C");
1331 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1333 gfc_error ("Initialization of variable at %C is not allowed in "
1334 "a PURE procedure");
1343 if (initializer
!= NULL
&& current_attr
.allocatable
1344 && gfc_current_state () == COMP_DERIVED
)
1346 gfc_error ("Initialization of allocatable component at %C is not "
1352 /* Add the initializer. Note that it is fine if initializer is
1353 NULL here, because we sometimes also need to check if a
1354 declaration *must* have an initialization expression. */
1355 if (gfc_current_state () != COMP_DERIVED
)
1356 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1359 if (current_ts
.type
== BT_DERIVED
1360 && !current_attr
.pointer
&& !initializer
)
1361 initializer
= gfc_default_initializer (¤t_ts
);
1362 t
= build_struct (name
, cl
, &initializer
, &as
);
1365 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1368 /* Free stuff up and return. */
1369 gfc_free_expr (initializer
);
1370 gfc_free_array_spec (as
);
1376 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1377 This assumes that the byte size is equal to the kind number for
1378 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1381 gfc_match_old_kind_spec (gfc_typespec
*ts
)
1386 if (gfc_match_char ('*') != MATCH_YES
)
1389 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1393 original_kind
= ts
->kind
;
1395 /* Massage the kind numbers for complex types. */
1396 if (ts
->type
== BT_COMPLEX
)
1400 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1401 gfc_basic_typename (ts
->type
), original_kind
);
1407 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1409 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1410 gfc_basic_typename (ts
->type
), original_kind
);
1414 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1415 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1422 /* Match a kind specification. Since kinds are generally optional, we
1423 usually return MATCH_NO if something goes wrong. If a "kind="
1424 string is found, then we know we have an error. */
1427 gfc_match_kind_spec (gfc_typespec
*ts
)
1437 where
= gfc_current_locus
;
1439 if (gfc_match_char ('(') == MATCH_NO
)
1442 /* Also gobbles optional text. */
1443 if (gfc_match (" kind = ") == MATCH_YES
)
1446 n
= gfc_match_init_expr (&e
);
1448 gfc_error ("Expected initialization expression at %C");
1454 gfc_error ("Expected scalar initialization expression at %C");
1459 msg
= gfc_extract_int (e
, &ts
->kind
);
1470 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1472 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1473 gfc_basic_typename (ts
->type
));
1479 if (gfc_match_char (')') != MATCH_YES
)
1481 gfc_error ("Missing right parenthesis at %C");
1489 gfc_current_locus
= where
;
1494 /* Match the various kind/length specifications in a CHARACTER
1495 declaration. We don't return MATCH_NO. */
1498 match_char_spec (gfc_typespec
*ts
)
1500 int i
, kind
, seen_length
;
1505 kind
= gfc_default_character_kind
;
1509 /* Try the old-style specification first. */
1510 old_char_selector
= 0;
1512 m
= match_char_length (&len
);
1516 old_char_selector
= 1;
1521 m
= gfc_match_char ('(');
1524 m
= MATCH_YES
; /* character without length is a single char */
1528 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1529 if (gfc_match (" kind =") == MATCH_YES
)
1531 m
= gfc_match_small_int (&kind
);
1532 if (m
== MATCH_ERROR
)
1537 if (gfc_match (" , len =") == MATCH_NO
)
1540 m
= char_len_param_value (&len
);
1543 if (m
== MATCH_ERROR
)
1550 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>" */
1551 if (gfc_match (" len =") == MATCH_YES
)
1553 m
= char_len_param_value (&len
);
1556 if (m
== MATCH_ERROR
)
1560 if (gfc_match_char (')') == MATCH_YES
)
1563 if (gfc_match (" , kind =") != MATCH_YES
)
1566 gfc_match_small_int (&kind
);
1568 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1570 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1577 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1578 m
= char_len_param_value (&len
);
1581 if (m
== MATCH_ERROR
)
1585 m
= gfc_match_char (')');
1589 if (gfc_match_char (',') != MATCH_YES
)
1592 gfc_match (" kind ="); /* Gobble optional text */
1594 m
= gfc_match_small_int (&kind
);
1595 if (m
== MATCH_ERROR
)
1601 /* Require a right-paren at this point. */
1602 m
= gfc_match_char (')');
1607 gfc_error ("Syntax error in CHARACTER declaration at %C");
1611 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1613 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1619 gfc_free_expr (len
);
1623 /* Do some final massaging of the length values. */
1624 cl
= gfc_get_charlen ();
1625 cl
->next
= gfc_current_ns
->cl_list
;
1626 gfc_current_ns
->cl_list
= cl
;
1628 if (seen_length
== 0)
1629 cl
->length
= gfc_int_expr (1);
1632 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1636 gfc_free_expr (len
);
1637 cl
->length
= gfc_int_expr (0);
1648 /* Matches a type specification. If successful, sets the ts structure
1649 to the matched specification. This is necessary for FUNCTION and
1650 IMPLICIT statements.
1652 If implicit_flag is nonzero, then we don't check for the optional
1653 kind specification. Not doing so is needed for matching an IMPLICIT
1654 statement correctly. */
1657 match_type_spec (gfc_typespec
*ts
, int implicit_flag
)
1659 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1666 if (gfc_match (" byte") == MATCH_YES
)
1668 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1672 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1674 gfc_error ("BYTE type used at %C "
1675 "is not available on the target machine");
1679 ts
->type
= BT_INTEGER
;
1684 if (gfc_match (" integer") == MATCH_YES
)
1686 ts
->type
= BT_INTEGER
;
1687 ts
->kind
= gfc_default_integer_kind
;
1691 if (gfc_match (" character") == MATCH_YES
)
1693 ts
->type
= BT_CHARACTER
;
1694 if (implicit_flag
== 0)
1695 return match_char_spec (ts
);
1700 if (gfc_match (" real") == MATCH_YES
)
1703 ts
->kind
= gfc_default_real_kind
;
1707 if (gfc_match (" double precision") == MATCH_YES
)
1710 ts
->kind
= gfc_default_double_kind
;
1714 if (gfc_match (" complex") == MATCH_YES
)
1716 ts
->type
= BT_COMPLEX
;
1717 ts
->kind
= gfc_default_complex_kind
;
1721 if (gfc_match (" double complex") == MATCH_YES
)
1723 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1724 "conform to the Fortran 95 standard") == FAILURE
)
1727 ts
->type
= BT_COMPLEX
;
1728 ts
->kind
= gfc_default_double_kind
;
1732 if (gfc_match (" logical") == MATCH_YES
)
1734 ts
->type
= BT_LOGICAL
;
1735 ts
->kind
= gfc_default_logical_kind
;
1739 m
= gfc_match (" type ( %n )", name
);
1743 /* Search for the name but allow the components to be defined later. */
1744 if (gfc_get_ha_symbol (name
, &sym
))
1746 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1750 if (sym
->attr
.flavor
!= FL_DERIVED
1751 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1754 ts
->type
= BT_DERIVED
;
1761 /* For all types except double, derived and character, look for an
1762 optional kind specifier. MATCH_NO is actually OK at this point. */
1763 if (implicit_flag
== 1)
1766 if (gfc_current_form
== FORM_FREE
)
1768 c
= gfc_peek_char();
1769 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1770 && c
!= ':' && c
!= ',')
1774 m
= gfc_match_kind_spec (ts
);
1775 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1776 m
= gfc_match_old_kind_spec (ts
);
1779 m
= MATCH_YES
; /* No kind specifier found. */
1785 /* Match an IMPLICIT NONE statement. Actually, this statement is
1786 already matched in parse.c, or we would not end up here in the
1787 first place. So the only thing we need to check, is if there is
1788 trailing garbage. If not, the match is successful. */
1791 gfc_match_implicit_none (void)
1793 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1797 /* Match the letter range(s) of an IMPLICIT statement. */
1800 match_implicit_range (void)
1802 int c
, c1
, c2
, inner
;
1805 cur_loc
= gfc_current_locus
;
1807 gfc_gobble_whitespace ();
1808 c
= gfc_next_char ();
1811 gfc_error ("Missing character range in IMPLICIT at %C");
1818 gfc_gobble_whitespace ();
1819 c1
= gfc_next_char ();
1823 gfc_gobble_whitespace ();
1824 c
= gfc_next_char ();
1829 inner
= 0; /* Fall through */
1836 gfc_gobble_whitespace ();
1837 c2
= gfc_next_char ();
1841 gfc_gobble_whitespace ();
1842 c
= gfc_next_char ();
1844 if ((c
!= ',') && (c
!= ')'))
1857 gfc_error ("Letters must be in alphabetic order in "
1858 "IMPLICIT statement at %C");
1862 /* See if we can add the newly matched range to the pending
1863 implicits from this IMPLICIT statement. We do not check for
1864 conflicts with whatever earlier IMPLICIT statements may have
1865 set. This is done when we've successfully finished matching
1867 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1874 gfc_syntax_error (ST_IMPLICIT
);
1876 gfc_current_locus
= cur_loc
;
1881 /* Match an IMPLICIT statement, storing the types for
1882 gfc_set_implicit() if the statement is accepted by the parser.
1883 There is a strange looking, but legal syntactic construction
1884 possible. It looks like:
1886 IMPLICIT INTEGER (a-b) (c-d)
1888 This is legal if "a-b" is a constant expression that happens to
1889 equal one of the legal kinds for integers. The real problem
1890 happens with an implicit specification that looks like:
1892 IMPLICIT INTEGER (a-b)
1894 In this case, a typespec matcher that is "greedy" (as most of the
1895 matchers are) gobbles the character range as a kindspec, leaving
1896 nothing left. We therefore have to go a bit more slowly in the
1897 matching process by inhibiting the kindspec checking during
1898 typespec matching and checking for a kind later. */
1901 gfc_match_implicit (void)
1908 /* We don't allow empty implicit statements. */
1909 if (gfc_match_eos () == MATCH_YES
)
1911 gfc_error ("Empty IMPLICIT statement at %C");
1917 /* First cleanup. */
1918 gfc_clear_new_implicit ();
1920 /* A basic type is mandatory here. */
1921 m
= match_type_spec (&ts
, 1);
1922 if (m
== MATCH_ERROR
)
1927 cur_loc
= gfc_current_locus
;
1928 m
= match_implicit_range ();
1932 /* We may have <TYPE> (<RANGE>). */
1933 gfc_gobble_whitespace ();
1934 c
= gfc_next_char ();
1935 if ((c
== '\n') || (c
== ','))
1937 /* Check for CHARACTER with no length parameter. */
1938 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1940 ts
.kind
= gfc_default_character_kind
;
1941 ts
.cl
= gfc_get_charlen ();
1942 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1943 gfc_current_ns
->cl_list
= ts
.cl
;
1944 ts
.cl
->length
= gfc_int_expr (1);
1947 /* Record the Successful match. */
1948 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1953 gfc_current_locus
= cur_loc
;
1956 /* Discard the (incorrectly) matched range. */
1957 gfc_clear_new_implicit ();
1959 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1960 if (ts
.type
== BT_CHARACTER
)
1961 m
= match_char_spec (&ts
);
1964 m
= gfc_match_kind_spec (&ts
);
1967 m
= gfc_match_old_kind_spec (&ts
);
1968 if (m
== MATCH_ERROR
)
1974 if (m
== MATCH_ERROR
)
1977 m
= match_implicit_range ();
1978 if (m
== MATCH_ERROR
)
1983 gfc_gobble_whitespace ();
1984 c
= gfc_next_char ();
1985 if ((c
!= '\n') && (c
!= ','))
1988 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1996 gfc_syntax_error (ST_IMPLICIT
);
2003 gfc_match_import (void)
2005 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2010 if (gfc_current_ns
->proc_name
== NULL
||
2011 gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
2013 gfc_error ("IMPORT statement at %C only permitted in "
2014 "an INTERFACE body");
2018 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: IMPORT statement at %C")
2022 if (gfc_match_eos () == MATCH_YES
)
2024 /* All host variables should be imported. */
2025 gfc_current_ns
->has_import_set
= 1;
2029 if (gfc_match (" ::") == MATCH_YES
)
2031 if (gfc_match_eos () == MATCH_YES
)
2033 gfc_error ("Expecting list of named entities at %C");
2040 m
= gfc_match (" %n", name
);
2044 if (gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
2046 gfc_error ("Type name '%s' at %C is ambiguous", name
);
2052 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2053 "at %C - does not exist.", name
);
2057 if (gfc_find_symtree (gfc_current_ns
->sym_root
,name
))
2059 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2064 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
2067 sym
->ns
= gfc_current_ns
;
2079 if (gfc_match_eos () == MATCH_YES
)
2081 if (gfc_match_char (',') != MATCH_YES
)
2088 gfc_error ("Syntax error in IMPORT statement at %C");
2092 /* Matches an attribute specification including array specs. If
2093 successful, leaves the variables current_attr and current_as
2094 holding the specification. Also sets the colon_seen variable for
2095 later use by matchers associated with initializations.
2097 This subroutine is a little tricky in the sense that we don't know
2098 if we really have an attr-spec until we hit the double colon.
2099 Until that time, we can only return MATCH_NO. This forces us to
2100 check for duplicate specification at this level. */
2103 match_attr_spec (void)
2105 /* Modifiers that can exist in a type statement. */
2107 { GFC_DECL_BEGIN
= 0,
2108 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2109 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2110 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
2111 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
2112 DECL_COLON
, DECL_NONE
,
2113 GFC_DECL_END
/* Sentinel */
2117 /* GFC_DECL_END is the sentinel, index starts at 0. */
2118 #define NUM_DECL GFC_DECL_END
2120 static mstring decls
[] = {
2121 minit (", allocatable", DECL_ALLOCATABLE
),
2122 minit (", dimension", DECL_DIMENSION
),
2123 minit (", external", DECL_EXTERNAL
),
2124 minit (", intent ( in )", DECL_IN
),
2125 minit (", intent ( out )", DECL_OUT
),
2126 minit (", intent ( in out )", DECL_INOUT
),
2127 minit (", intrinsic", DECL_INTRINSIC
),
2128 minit (", optional", DECL_OPTIONAL
),
2129 minit (", parameter", DECL_PARAMETER
),
2130 minit (", pointer", DECL_POINTER
),
2131 minit (", protected", DECL_PROTECTED
),
2132 minit (", private", DECL_PRIVATE
),
2133 minit (", public", DECL_PUBLIC
),
2134 minit (", save", DECL_SAVE
),
2135 minit (", target", DECL_TARGET
),
2136 minit (", value", DECL_VALUE
),
2137 minit (", volatile", DECL_VOLATILE
),
2138 minit ("::", DECL_COLON
),
2139 minit (NULL
, DECL_NONE
)
2142 locus start
, seen_at
[NUM_DECL
];
2149 gfc_clear_attr (¤t_attr
);
2150 start
= gfc_current_locus
;
2155 /* See if we get all of the keywords up to the final double colon. */
2156 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2161 d
= (decl_types
) gfc_match_strings (decls
);
2162 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2166 seen_at
[d
] = gfc_current_locus
;
2168 if (d
== DECL_DIMENSION
)
2170 m
= gfc_match_array_spec (¤t_as
);
2174 gfc_error ("Missing dimension specification at %C");
2178 if (m
== MATCH_ERROR
)
2183 /* No double colon, so assume that we've been looking at something
2184 else the whole time. */
2191 /* Since we've seen a double colon, we have to be looking at an
2192 attr-spec. This means that we can now issue errors. */
2193 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2198 case DECL_ALLOCATABLE
:
2199 attr
= "ALLOCATABLE";
2201 case DECL_DIMENSION
:
2208 attr
= "INTENT (IN)";
2211 attr
= "INTENT (OUT)";
2214 attr
= "INTENT (IN OUT)";
2216 case DECL_INTRINSIC
:
2222 case DECL_PARAMETER
:
2228 case DECL_PROTECTED
:
2250 attr
= NULL
; /* This shouldn't happen */
2253 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2258 /* Now that we've dealt with duplicate attributes, add the attributes
2259 to the current attribute. */
2260 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2265 if (gfc_current_state () == COMP_DERIVED
2266 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2267 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2269 if (d
== DECL_ALLOCATABLE
)
2271 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ALLOCATABLE "
2272 "attribute at %C in a TYPE definition")
2281 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2288 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2289 && gfc_current_state () != COMP_MODULE
)
2291 if (d
== DECL_PRIVATE
)
2296 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2304 case DECL_ALLOCATABLE
:
2305 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2308 case DECL_DIMENSION
:
2309 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2313 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2317 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2321 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2325 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2328 case DECL_INTRINSIC
:
2329 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2333 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2336 case DECL_PARAMETER
:
2337 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2341 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2344 case DECL_PROTECTED
:
2345 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
2347 gfc_error ("PROTECTED at %C only allowed in specification "
2348 "part of a module");
2353 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED "
2358 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
2362 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2367 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2372 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2376 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2380 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE attribute "
2385 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
2389 if (gfc_notify_std (GFC_STD_F2003
,
2390 "Fortran 2003: VOLATILE attribute at %C")
2394 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
2398 gfc_internal_error ("match_attr_spec(): Bad attribute");
2412 gfc_current_locus
= start
;
2413 gfc_free_array_spec (current_as
);
2419 /* Match a data declaration statement. */
2422 gfc_match_data_decl (void)
2428 m
= match_type_spec (¤t_ts
, 0);
2432 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2434 sym
= gfc_use_derived (current_ts
.derived
);
2442 current_ts
.derived
= sym
;
2445 m
= match_attr_spec ();
2446 if (m
== MATCH_ERROR
)
2452 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2455 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2458 gfc_find_symbol (current_ts
.derived
->name
,
2459 current_ts
.derived
->ns
->parent
, 1, &sym
);
2461 /* Any symbol that we find had better be a type definition
2462 which has its components defined. */
2463 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2464 && current_ts
.derived
->components
!= NULL
)
2467 /* Now we have an error, which we signal, and then fix up
2468 because the knock-on is plain and simple confusing. */
2469 gfc_error_now ("Derived type at %C has not been previously defined "
2470 "and so cannot appear in a derived type definition");
2471 current_attr
.pointer
= 1;
2476 /* If we have an old-style character declaration, and no new-style
2477 attribute specifications, then there a comma is optional between
2478 the type specification and the variable list. */
2479 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2480 gfc_match_char (',');
2482 /* Give the types/attributes to symbols that follow. Give the element
2483 a number so that repeat character length expressions can be copied. */
2487 m
= variable_decl (elem
++);
2488 if (m
== MATCH_ERROR
)
2493 if (gfc_match_eos () == MATCH_YES
)
2495 if (gfc_match_char (',') != MATCH_YES
)
2499 if (gfc_error_flag_test () == 0)
2500 gfc_error ("Syntax error in data declaration at %C");
2503 gfc_free_data_all (gfc_current_ns
);
2506 gfc_free_array_spec (current_as
);
2512 /* Match a prefix associated with a function or subroutine
2513 declaration. If the typespec pointer is nonnull, then a typespec
2514 can be matched. Note that if nothing matches, MATCH_YES is
2515 returned (the null string was matched). */
2518 match_prefix (gfc_typespec
*ts
)
2522 gfc_clear_attr (¤t_attr
);
2526 if (!seen_type
&& ts
!= NULL
2527 && match_type_spec (ts
, 0) == MATCH_YES
2528 && gfc_match_space () == MATCH_YES
)
2535 if (gfc_match ("elemental% ") == MATCH_YES
)
2537 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2543 if (gfc_match ("pure% ") == MATCH_YES
)
2545 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2551 if (gfc_match ("recursive% ") == MATCH_YES
)
2553 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2559 /* At this point, the next item is not a prefix. */
2564 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2567 copy_prefix (symbol_attribute
*dest
, locus
*where
)
2569 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2572 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2575 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2582 /* Match a formal argument list. */
2585 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
2587 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2588 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2594 if (gfc_match_char ('(') != MATCH_YES
)
2601 if (gfc_match_char (')') == MATCH_YES
)
2606 if (gfc_match_char ('*') == MATCH_YES
)
2610 m
= gfc_match_name (name
);
2614 if (gfc_get_symbol (name
, NULL
, &sym
))
2618 p
= gfc_get_formal_arglist ();
2630 /* We don't add the VARIABLE flavor because the name could be a
2631 dummy procedure. We don't apply these attributes to formal
2632 arguments of statement functions. */
2633 if (sym
!= NULL
&& !st_flag
2634 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2635 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2641 /* The name of a program unit can be in a different namespace,
2642 so check for it explicitly. After the statement is accepted,
2643 the name is checked for especially in gfc_get_symbol(). */
2644 if (gfc_new_block
!= NULL
&& sym
!= NULL
2645 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2647 gfc_error ("Name '%s' at %C is the name of the procedure",
2653 if (gfc_match_char (')') == MATCH_YES
)
2656 m
= gfc_match_char (',');
2659 gfc_error ("Unexpected junk in formal argument list at %C");
2665 /* Check for duplicate symbols in the formal argument list. */
2668 for (p
= head
; p
->next
; p
= p
->next
)
2673 for (q
= p
->next
; q
; q
= q
->next
)
2674 if (p
->sym
== q
->sym
)
2676 gfc_error ("Duplicate symbol '%s' in formal argument list "
2677 "at %C", p
->sym
->name
);
2685 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2695 gfc_free_formal_arglist (head
);
2700 /* Match a RESULT specification following a function declaration or
2701 ENTRY statement. Also matches the end-of-statement. */
2704 match_result (gfc_symbol
* function
, gfc_symbol
**result
)
2706 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2710 if (gfc_match (" result (") != MATCH_YES
)
2713 m
= gfc_match_name (name
);
2717 if (gfc_match (" )%t") != MATCH_YES
)
2719 gfc_error ("Unexpected junk following RESULT variable at %C");
2723 if (strcmp (function
->name
, name
) == 0)
2725 gfc_error ("RESULT variable at %C must be different than function name");
2729 if (gfc_get_symbol (name
, NULL
, &r
))
2732 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2733 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2742 /* Match a function declaration. */
2745 gfc_match_function_decl (void)
2747 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2748 gfc_symbol
*sym
, *result
;
2752 if (gfc_current_state () != COMP_NONE
2753 && gfc_current_state () != COMP_INTERFACE
2754 && gfc_current_state () != COMP_CONTAINS
)
2757 gfc_clear_ts (¤t_ts
);
2759 old_loc
= gfc_current_locus
;
2761 m
= match_prefix (¤t_ts
);
2764 gfc_current_locus
= old_loc
;
2768 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2770 gfc_current_locus
= old_loc
;
2774 if (get_proc_name (name
, &sym
, false))
2776 gfc_new_block
= sym
;
2778 m
= gfc_match_formal_arglist (sym
, 0, 0);
2781 gfc_error ("Expected formal argument list in function "
2782 "definition at %C");
2786 else if (m
== MATCH_ERROR
)
2791 if (gfc_match_eos () != MATCH_YES
)
2793 /* See if a result variable is present. */
2794 m
= match_result (sym
, &result
);
2796 gfc_error ("Unexpected junk after function declaration at %C");
2805 /* Make changes to the symbol. */
2808 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2811 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2812 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2815 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
2816 && !sym
->attr
.implicit_type
)
2818 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2819 gfc_basic_typename (sym
->ts
.type
));
2825 sym
->ts
= current_ts
;
2830 result
->ts
= current_ts
;
2831 sym
->result
= result
;
2837 gfc_current_locus
= old_loc
;
2842 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
2843 pass the name of the entry, rather than the gfc_current_block name, and
2844 to return false upon finding an existing global entry. */
2847 add_global_entry (const char *name
, int sub
)
2851 s
= gfc_get_gsymbol(name
);
2854 || (s
->type
!= GSYM_UNKNOWN
2855 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2856 global_used(s
, NULL
);
2859 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2860 s
->where
= gfc_current_locus
;
2868 /* Match an ENTRY statement. */
2871 gfc_match_entry (void)
2876 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2877 gfc_compile_state state
;
2881 bool module_procedure
;
2883 m
= gfc_match_name (name
);
2887 state
= gfc_current_state ();
2888 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2893 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2896 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2898 case COMP_BLOCK_DATA
:
2899 gfc_error ("ENTRY statement at %C cannot appear within "
2902 case COMP_INTERFACE
:
2903 gfc_error ("ENTRY statement at %C cannot appear within "
2907 gfc_error ("ENTRY statement at %C cannot appear within "
2908 "a DERIVED TYPE block");
2911 gfc_error ("ENTRY statement at %C cannot appear within "
2912 "an IF-THEN block");
2915 gfc_error ("ENTRY statement at %C cannot appear within "
2919 gfc_error ("ENTRY statement at %C cannot appear within "
2923 gfc_error ("ENTRY statement at %C cannot appear within "
2927 gfc_error ("ENTRY statement at %C cannot appear within "
2931 gfc_error ("ENTRY statement at %C cannot appear within "
2932 "a contained subprogram");
2935 gfc_internal_error ("gfc_match_entry(): Bad state");
2940 module_procedure
= gfc_current_ns
->parent
!= NULL
2941 && gfc_current_ns
->parent
->proc_name
2942 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
2945 if (gfc_current_ns
->parent
!= NULL
2946 && gfc_current_ns
->parent
->proc_name
2947 && !module_procedure
)
2949 gfc_error("ENTRY statement at %C cannot appear in a "
2950 "contained procedure");
2954 /* Module function entries need special care in get_proc_name
2955 because previous references within the function will have
2956 created symbols attached to the current namespace. */
2957 if (get_proc_name (name
, &entry
,
2958 gfc_current_ns
->parent
!= NULL
2960 && gfc_current_ns
->proc_name
->attr
.function
))
2963 proc
= gfc_current_block ();
2965 if (state
== COMP_SUBROUTINE
)
2967 /* An entry in a subroutine. */
2968 if (!add_global_entry (name
, 1))
2971 m
= gfc_match_formal_arglist (entry
, 0, 1);
2975 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2976 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2981 /* An entry in a function.
2982 We need to take special care because writing
2987 ENTRY f() RESULT (r)
2989 ENTRY f RESULT (r). */
2990 if (!add_global_entry (name
, 0))
2993 old_loc
= gfc_current_locus
;
2994 if (gfc_match_eos () == MATCH_YES
)
2996 gfc_current_locus
= old_loc
;
2997 /* Match the empty argument list, and add the interface to
2999 m
= gfc_match_formal_arglist (entry
, 0, 1);
3002 m
= gfc_match_formal_arglist (entry
, 0, 0);
3009 if (gfc_match_eos () == MATCH_YES
)
3011 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
3012 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
3015 entry
->result
= entry
;
3019 m
= match_result (proc
, &result
);
3021 gfc_syntax_error (ST_ENTRY
);
3025 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
3026 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
3027 || gfc_add_function (&entry
->attr
, result
->name
, NULL
)
3031 entry
->result
= result
;
3035 if (gfc_match_eos () != MATCH_YES
)
3037 gfc_syntax_error (ST_ENTRY
);
3041 entry
->attr
.recursive
= proc
->attr
.recursive
;
3042 entry
->attr
.elemental
= proc
->attr
.elemental
;
3043 entry
->attr
.pure
= proc
->attr
.pure
;
3045 el
= gfc_get_entry_list ();
3047 el
->next
= gfc_current_ns
->entries
;
3048 gfc_current_ns
->entries
= el
;
3050 el
->id
= el
->next
->id
+ 1;
3054 new_st
.op
= EXEC_ENTRY
;
3055 new_st
.ext
.entry
= el
;
3061 /* Match a subroutine statement, including optional prefixes. */
3064 gfc_match_subroutine (void)
3066 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3070 if (gfc_current_state () != COMP_NONE
3071 && gfc_current_state () != COMP_INTERFACE
3072 && gfc_current_state () != COMP_CONTAINS
)
3075 m
= match_prefix (NULL
);
3079 m
= gfc_match ("subroutine% %n", name
);
3083 if (get_proc_name (name
, &sym
, false))
3085 gfc_new_block
= sym
;
3087 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3090 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
3093 if (gfc_match_eos () != MATCH_YES
)
3095 gfc_syntax_error (ST_SUBROUTINE
);
3099 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
3106 /* Return nonzero if we're currently compiling a contained procedure. */
3109 contained_procedure (void)
3113 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
3114 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
3115 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
3121 /* Set the kind of each enumerator. The kind is selected such that it is
3122 interoperable with the corresponding C enumeration type, making
3123 sure that -fshort-enums is honored. */
3128 enumerator_history
*current_history
= NULL
;
3132 if (max_enum
== NULL
|| enum_history
== NULL
)
3135 if (!gfc_option
.fshort_enums
)
3141 kind
= gfc_integer_kinds
[i
++].kind
;
3143 while (kind
< gfc_c_int_kind
3144 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
3147 current_history
= enum_history
;
3148 while (current_history
!= NULL
)
3150 current_history
->sym
->ts
.kind
= kind
;
3151 current_history
= current_history
->next
;
3156 /* Match any of the various end-block statements. Returns the type of
3157 END to the caller. The END INTERFACE, END IF, END DO and END
3158 SELECT statements cannot be replaced by a single END statement. */
3161 gfc_match_end (gfc_statement
*st
)
3163 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3164 gfc_compile_state state
;
3166 const char *block_name
;
3171 old_loc
= gfc_current_locus
;
3172 if (gfc_match ("end") != MATCH_YES
)
3175 state
= gfc_current_state ();
3176 block_name
= gfc_current_block () == NULL
3177 ? NULL
: gfc_current_block ()->name
;
3179 if (state
== COMP_CONTAINS
)
3181 state
= gfc_state_stack
->previous
->state
;
3182 block_name
= gfc_state_stack
->previous
->sym
== NULL
3183 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
3190 *st
= ST_END_PROGRAM
;
3191 target
= " program";
3195 case COMP_SUBROUTINE
:
3196 *st
= ST_END_SUBROUTINE
;
3197 target
= " subroutine";
3198 eos_ok
= !contained_procedure ();
3202 *st
= ST_END_FUNCTION
;
3203 target
= " function";
3204 eos_ok
= !contained_procedure ();
3207 case COMP_BLOCK_DATA
:
3208 *st
= ST_END_BLOCK_DATA
;
3209 target
= " block data";
3214 *st
= ST_END_MODULE
;
3219 case COMP_INTERFACE
:
3220 *st
= ST_END_INTERFACE
;
3221 target
= " interface";
3244 *st
= ST_END_SELECT
;
3250 *st
= ST_END_FORALL
;
3265 last_initializer
= NULL
;
3267 gfc_free_enum_history ();
3271 gfc_error ("Unexpected END statement at %C");
3275 if (gfc_match_eos () == MATCH_YES
)
3279 /* We would have required END [something] */
3280 gfc_error ("%s statement expected at %L",
3281 gfc_ascii_statement (*st
), &old_loc
);
3288 /* Verify that we've got the sort of end-block that we're expecting. */
3289 if (gfc_match (target
) != MATCH_YES
)
3291 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3295 /* If we're at the end, make sure a block name wasn't required. */
3296 if (gfc_match_eos () == MATCH_YES
)
3299 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3302 if (gfc_current_block () == NULL
)
3305 gfc_error ("Expected block name of '%s' in %s statement at %C",
3306 block_name
, gfc_ascii_statement (*st
));
3311 /* END INTERFACE has a special handler for its several possible endings. */
3312 if (*st
== ST_END_INTERFACE
)
3313 return gfc_match_end_interface ();
3315 /* We haven't hit the end of statement, so what is left must be an end-name. */
3316 m
= gfc_match_space ();
3318 m
= gfc_match_name (name
);
3321 gfc_error ("Expected terminating name at %C");
3325 if (block_name
== NULL
)
3328 if (strcmp (name
, block_name
) != 0)
3330 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3331 gfc_ascii_statement (*st
));
3335 if (gfc_match_eos () == MATCH_YES
)
3339 gfc_syntax_error (*st
);
3342 gfc_current_locus
= old_loc
;
3348 /***************** Attribute declaration statements ****************/
3350 /* Set the attribute of a single variable. */
3355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3363 m
= gfc_match_name (name
);
3367 if (find_special (name
, &sym
))
3370 var_locus
= gfc_current_locus
;
3372 /* Deal with possible array specification for certain attributes. */
3373 if (current_attr
.dimension
3374 || current_attr
.allocatable
3375 || current_attr
.pointer
3376 || current_attr
.target
)
3378 m
= gfc_match_array_spec (&as
);
3379 if (m
== MATCH_ERROR
)
3382 if (current_attr
.dimension
&& m
== MATCH_NO
)
3384 gfc_error ("Missing array specification at %L in DIMENSION "
3385 "statement", &var_locus
);
3390 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3391 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3393 gfc_error ("Array specification must be deferred at %L", &var_locus
);
3399 /* Update symbol table. DIMENSION attribute is set
3400 in gfc_set_array_spec(). */
3401 if (current_attr
.dimension
== 0
3402 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3408 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3414 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3416 /* Fix the array spec. */
3417 m
= gfc_mod_pointee_as (sym
->as
);
3418 if (m
== MATCH_ERROR
)
3422 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
3428 if ((current_attr
.external
|| current_attr
.intrinsic
)
3429 && sym
->attr
.flavor
!= FL_PROCEDURE
3430 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3439 gfc_free_array_spec (as
);
3444 /* Generic attribute declaration subroutine. Used for attributes that
3445 just have a list of names. */
3452 /* Gobble the optional double colon, by simply ignoring the result
3462 if (gfc_match_eos () == MATCH_YES
)
3468 if (gfc_match_char (',') != MATCH_YES
)
3470 gfc_error ("Unexpected character in variable list at %C");
3480 /* This routine matches Cray Pointer declarations of the form:
3481 pointer ( <pointer>, <pointee> )
3483 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3484 The pointer, if already declared, should be an integer. Otherwise, we
3485 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3486 be either a scalar, or an array declaration. No space is allocated for
3487 the pointee. For the statement
3488 pointer (ipt, ar(10))
3489 any subsequent uses of ar will be translated (in C-notation) as
3490 ar(i) => ((<type> *) ipt)(i)
3491 After gimplification, pointee variable will disappear in the code. */
3494 cray_pointer_decl (void)
3498 gfc_symbol
*cptr
; /* Pointer symbol. */
3499 gfc_symbol
*cpte
; /* Pointee symbol. */
3505 if (gfc_match_char ('(') != MATCH_YES
)
3507 gfc_error ("Expected '(' at %C");
3511 /* Match pointer. */
3512 var_locus
= gfc_current_locus
;
3513 gfc_clear_attr (¤t_attr
);
3514 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3515 current_ts
.type
= BT_INTEGER
;
3516 current_ts
.kind
= gfc_index_integer_kind
;
3518 m
= gfc_match_symbol (&cptr
, 0);
3521 gfc_error ("Expected variable name at %C");
3525 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3528 gfc_set_sym_referenced (cptr
);
3530 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3532 cptr
->ts
.type
= BT_INTEGER
;
3533 cptr
->ts
.kind
= gfc_index_integer_kind
;
3535 else if (cptr
->ts
.type
!= BT_INTEGER
)
3537 gfc_error ("Cray pointer at %C must be an integer");
3540 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3541 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3542 " memory addresses require %d bytes",
3543 cptr
->ts
.kind
, gfc_index_integer_kind
);
3545 if (gfc_match_char (',') != MATCH_YES
)
3547 gfc_error ("Expected \",\" at %C");
3551 /* Match Pointee. */
3552 var_locus
= gfc_current_locus
;
3553 gfc_clear_attr (¤t_attr
);
3554 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3555 current_ts
.type
= BT_UNKNOWN
;
3556 current_ts
.kind
= 0;
3558 m
= gfc_match_symbol (&cpte
, 0);
3561 gfc_error ("Expected variable name at %C");
3565 /* Check for an optional array spec. */
3566 m
= gfc_match_array_spec (&as
);
3567 if (m
== MATCH_ERROR
)
3569 gfc_free_array_spec (as
);
3572 else if (m
== MATCH_NO
)
3574 gfc_free_array_spec (as
);
3578 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3581 gfc_set_sym_referenced (cpte
);
3583 if (cpte
->as
== NULL
)
3585 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3586 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3588 else if (as
!= NULL
)
3590 gfc_error ("Duplicate array spec for Cray pointee at %C");
3591 gfc_free_array_spec (as
);
3597 if (cpte
->as
!= NULL
)
3599 /* Fix array spec. */
3600 m
= gfc_mod_pointee_as (cpte
->as
);
3601 if (m
== MATCH_ERROR
)
3605 /* Point the Pointee at the Pointer. */
3606 cpte
->cp_pointer
= cptr
;
3608 if (gfc_match_char (')') != MATCH_YES
)
3610 gfc_error ("Expected \")\" at %C");
3613 m
= gfc_match_char (',');
3615 done
= true; /* Stop searching for more declarations. */
3619 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3620 || gfc_match_eos () != MATCH_YES
)
3622 gfc_error ("Expected \",\" or end of statement at %C");
3630 gfc_match_external (void)
3633 gfc_clear_attr (¤t_attr
);
3634 current_attr
.external
= 1;
3636 return attr_decl ();
3641 gfc_match_intent (void)
3645 intent
= match_intent_spec ();
3646 if (intent
== INTENT_UNKNOWN
)
3649 gfc_clear_attr (¤t_attr
);
3650 current_attr
.intent
= intent
;
3652 return attr_decl ();
3657 gfc_match_intrinsic (void)
3660 gfc_clear_attr (¤t_attr
);
3661 current_attr
.intrinsic
= 1;
3663 return attr_decl ();
3668 gfc_match_optional (void)
3671 gfc_clear_attr (¤t_attr
);
3672 current_attr
.optional
= 1;
3674 return attr_decl ();
3679 gfc_match_pointer (void)
3681 gfc_gobble_whitespace ();
3682 if (gfc_peek_char () == '(')
3684 if (!gfc_option
.flag_cray_pointer
)
3686 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3690 return cray_pointer_decl ();
3694 gfc_clear_attr (¤t_attr
);
3695 current_attr
.pointer
= 1;
3697 return attr_decl ();
3703 gfc_match_allocatable (void)
3705 gfc_clear_attr (¤t_attr
);
3706 current_attr
.allocatable
= 1;
3708 return attr_decl ();
3713 gfc_match_dimension (void)
3715 gfc_clear_attr (¤t_attr
);
3716 current_attr
.dimension
= 1;
3718 return attr_decl ();
3723 gfc_match_target (void)
3725 gfc_clear_attr (¤t_attr
);
3726 current_attr
.target
= 1;
3728 return attr_decl ();
3732 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3736 access_attr_decl (gfc_statement st
)
3738 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3739 interface_type type
;
3742 gfc_intrinsic_op
operator;
3745 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3750 m
= gfc_match_generic_spec (&type
, name
, &operator);
3753 if (m
== MATCH_ERROR
)
3758 case INTERFACE_NAMELESS
:
3761 case INTERFACE_GENERIC
:
3762 if (gfc_get_symbol (name
, NULL
, &sym
))
3765 if (gfc_add_access (&sym
->attr
, (st
== ST_PUBLIC
)
3766 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3767 sym
->name
, NULL
) == FAILURE
)
3772 case INTERFACE_INTRINSIC_OP
:
3773 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3775 gfc_current_ns
->operator_access
[operator] =
3776 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3780 gfc_error ("Access specification of the %s operator at %C has "
3781 "already been specified", gfc_op2string (operator));
3787 case INTERFACE_USER_OP
:
3788 uop
= gfc_get_uop (name
);
3790 if (uop
->access
== ACCESS_UNKNOWN
)
3792 uop
->access
= (st
== ST_PUBLIC
)
3793 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3797 gfc_error ("Access specification of the .%s. operator at %C "
3798 "has already been specified", sym
->name
);
3805 if (gfc_match_char (',') == MATCH_NO
)
3809 if (gfc_match_eos () != MATCH_YES
)
3814 gfc_syntax_error (st
);
3822 gfc_match_protected (void)
3827 if (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
3829 gfc_error ("PROTECTED at %C only allowed in specification "
3830 "part of a module");
3835 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PROTECTED statement at %C")
3839 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3844 if (gfc_match_eos () == MATCH_YES
)
3849 m
= gfc_match_symbol (&sym
, 0);
3853 if (gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
)
3866 if (gfc_match_eos () == MATCH_YES
)
3868 if (gfc_match_char (',') != MATCH_YES
)
3875 gfc_error ("Syntax error in PROTECTED statement at %C");
3880 /* The PRIVATE statement is a bit weird in that it can be a attribute
3881 declaration, but also works as a standlone statement inside of a
3882 type declaration or a module. */
3885 gfc_match_private (gfc_statement
*st
)
3888 if (gfc_match ("private") != MATCH_YES
)
3891 if (gfc_current_state () == COMP_DERIVED
)
3893 if (gfc_match_eos () == MATCH_YES
)
3899 gfc_syntax_error (ST_PRIVATE
);
3903 if (gfc_match_eos () == MATCH_YES
)
3910 return access_attr_decl (ST_PRIVATE
);
3915 gfc_match_public (gfc_statement
*st
)
3918 if (gfc_match ("public") != MATCH_YES
)
3921 if (gfc_match_eos () == MATCH_YES
)
3928 return access_attr_decl (ST_PUBLIC
);
3932 /* Workhorse for gfc_match_parameter. */
3941 m
= gfc_match_symbol (&sym
, 0);
3943 gfc_error ("Expected variable name at %C in PARAMETER statement");
3948 if (gfc_match_char ('=') == MATCH_NO
)
3950 gfc_error ("Expected = sign in PARAMETER statement at %C");
3954 m
= gfc_match_init_expr (&init
);
3956 gfc_error ("Expected expression at %C in PARAMETER statement");
3960 if (sym
->ts
.type
== BT_UNKNOWN
3961 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3967 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3968 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3974 if (sym
->ts
.type
== BT_CHARACTER
3975 && sym
->ts
.cl
!= NULL
3976 && sym
->ts
.cl
->length
!= NULL
3977 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3978 && init
->expr_type
== EXPR_CONSTANT
3979 && init
->ts
.type
== BT_CHARACTER
3980 && init
->ts
.kind
== 1)
3981 gfc_set_constant_character_len (
3982 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
, false);
3988 gfc_free_expr (init
);
3993 /* Match a parameter statement, with the weird syntax that these have. */
3996 gfc_match_parameter (void)
4000 if (gfc_match_char ('(') == MATCH_NO
)
4009 if (gfc_match (" )%t") == MATCH_YES
)
4012 if (gfc_match_char (',') != MATCH_YES
)
4014 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4024 /* Save statements have a special syntax. */
4027 gfc_match_save (void)
4029 char n
[GFC_MAX_SYMBOL_LEN
+1];
4034 if (gfc_match_eos () == MATCH_YES
)
4036 if (gfc_current_ns
->seen_save
)
4038 if (gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
4039 "follows previous SAVE statement")
4044 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
4048 if (gfc_current_ns
->save_all
)
4050 if (gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
4051 "blanket SAVE statement")
4060 m
= gfc_match_symbol (&sym
, 0);
4064 if (gfc_add_save (&sym
->attr
, sym
->name
, &gfc_current_locus
)
4076 m
= gfc_match (" / %n /", &n
);
4077 if (m
== MATCH_ERROR
)
4082 c
= gfc_get_common (n
, 0);
4085 gfc_current_ns
->seen_save
= 1;
4088 if (gfc_match_eos () == MATCH_YES
)
4090 if (gfc_match_char (',') != MATCH_YES
)
4097 gfc_error ("Syntax error in SAVE statement at %C");
4103 gfc_match_value (void)
4108 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VALUE statement at %C")
4112 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4117 if (gfc_match_eos () == MATCH_YES
)
4122 m
= gfc_match_symbol (&sym
, 0);
4126 if (gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
)
4139 if (gfc_match_eos () == MATCH_YES
)
4141 if (gfc_match_char (',') != MATCH_YES
)
4148 gfc_error ("Syntax error in VALUE statement at %C");
4153 gfc_match_volatile (void)
4158 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: VOLATILE statement at %C")
4162 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
4167 if (gfc_match_eos () == MATCH_YES
)
4172 /* VOLATILE is special because it can be added to host-associated
4174 m
= gfc_match_symbol (&sym
, 1);
4178 if (gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
)
4191 if (gfc_match_eos () == MATCH_YES
)
4193 if (gfc_match_char (',') != MATCH_YES
)
4200 gfc_error ("Syntax error in VOLATILE statement at %C");
4206 /* Match a module procedure statement. Note that we have to modify
4207 symbols in the parent's namespace because the current one was there
4208 to receive symbols that are in an interface's formal argument list. */
4211 gfc_match_modproc (void)
4213 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4217 if (gfc_state_stack
->state
!= COMP_INTERFACE
4218 || gfc_state_stack
->previous
== NULL
4219 || current_interface
.type
== INTERFACE_NAMELESS
)
4221 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4228 m
= gfc_match_name (name
);
4234 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
4237 if (sym
->attr
.proc
!= PROC_MODULE
4238 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
4239 sym
->name
, NULL
) == FAILURE
)
4242 if (gfc_add_interface (sym
) == FAILURE
)
4245 sym
->attr
.mod_proc
= 1;
4247 if (gfc_match_eos () == MATCH_YES
)
4249 if (gfc_match_char (',') != MATCH_YES
)
4256 gfc_syntax_error (ST_MODULE_PROC
);
4261 /* Match the beginning of a derived type declaration. If a type name
4262 was the result of a function, then it is possible to have a symbol
4263 already to be known as a derived type yet have no components. */
4266 gfc_match_derived_decl (void)
4268 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4269 symbol_attribute attr
;
4273 if (gfc_current_state () == COMP_DERIVED
)
4276 gfc_clear_attr (&attr
);
4279 if (gfc_match (" , private") == MATCH_YES
)
4281 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4283 gfc_error ("Derived type at %C can only be PRIVATE within a MODULE");
4287 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
4292 if (gfc_match (" , public") == MATCH_YES
)
4294 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4296 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4300 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
4305 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
4307 gfc_error ("Expected :: in TYPE definition at %C");
4311 m
= gfc_match (" %n%t", name
);
4315 /* Make sure the name isn't the name of an intrinsic type. The
4316 'double precision' type doesn't get past the name matcher. */
4317 if (strcmp (name
, "integer") == 0
4318 || strcmp (name
, "real") == 0
4319 || strcmp (name
, "character") == 0
4320 || strcmp (name
, "logical") == 0
4321 || strcmp (name
, "complex") == 0)
4323 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4328 if (gfc_get_symbol (name
, NULL
, &sym
))
4331 if (sym
->ts
.type
!= BT_UNKNOWN
)
4333 gfc_error ("Derived type name '%s' at %C already has a basic type "
4334 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
4338 /* The symbol may already have the derived attribute without the
4339 components. The ways this can happen is via a function
4340 definition, an INTRINSIC statement or a subtype in another
4341 derived type that is a pointer. The first part of the AND clause
4342 is true if a the symbol is not the return value of a function. */
4343 if (sym
->attr
.flavor
!= FL_DERIVED
4344 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
4347 if (sym
->components
!= NULL
)
4349 gfc_error ("Derived type definition of '%s' at %C has already been "
4350 "defined", sym
->name
);
4354 if (attr
.access
!= ACCESS_UNKNOWN
4355 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
4358 gfc_new_block
= sym
;
4364 /* Cray Pointees can be declared as:
4365 pointer (ipt, a (n,m,...,*))
4366 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4367 cheat and set a constant bound of 1 for the last dimension, if this
4368 is the case. Since there is no bounds-checking for Cray Pointees,
4369 this will be okay. */
4372 gfc_mod_pointee_as (gfc_array_spec
*as
)
4374 as
->cray_pointee
= true; /* This will be useful to know later. */
4375 if (as
->type
== AS_ASSUMED_SIZE
)
4377 as
->type
= AS_EXPLICIT
;
4378 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4379 as
->cp_was_assumed
= true;
4381 else if (as
->type
== AS_ASSUMED_SHAPE
)
4383 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4390 /* Match the enum definition statement, here we are trying to match
4391 the first line of enum definition statement.
4392 Returns MATCH_YES if match is found. */
4395 gfc_match_enum (void)
4399 m
= gfc_match_eos ();
4403 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ENUM and ENUMERATOR at %C")
4411 /* Match a variable name with an optional initializer. When this
4412 subroutine is called, a variable is expected to be parsed next.
4413 Depending on what is happening at the moment, updates either the
4414 symbol table or the current interface. */
4417 enumerator_decl (void)
4419 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4420 gfc_expr
*initializer
;
4421 gfc_array_spec
*as
= NULL
;
4429 old_locus
= gfc_current_locus
;
4431 /* When we get here, we've just matched a list of attributes and
4432 maybe a type and a double colon. The next thing we expect to see
4433 is the name of the symbol. */
4434 m
= gfc_match_name (name
);
4438 var_locus
= gfc_current_locus
;
4440 /* OK, we've successfully matched the declaration. Now put the
4441 symbol in the current namespace. If we fail to create the symbol,
4443 if (build_sym (name
, NULL
, &as
, &var_locus
) == FAILURE
)
4449 /* The double colon must be present in order to have initializers.
4450 Otherwise the statement is ambiguous with an assignment statement. */
4453 if (gfc_match_char ('=') == MATCH_YES
)
4455 m
= gfc_match_init_expr (&initializer
);
4458 gfc_error ("Expected an initialization expression at %C");
4467 /* If we do not have an initializer, the initialization value of the
4468 previous enumerator (stored in last_initializer) is incremented
4469 by 1 and is used to initialize the current enumerator. */
4470 if (initializer
== NULL
)
4471 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
4473 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
4475 gfc_error("ENUMERATOR %L not initialized with integer expression",
4478 gfc_free_enum_history ();
4482 /* Store this current initializer, for the next enumerator variable
4483 to be parsed. add_init_expr_to_sym() zeros initializer, so we
4484 use last_initializer below. */
4485 last_initializer
= initializer
;
4486 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
4488 /* Maintain enumerator history. */
4489 gfc_find_symbol (name
, NULL
, 0, &sym
);
4490 create_enum_history (sym
, last_initializer
);
4492 return (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
4495 /* Free stuff up and return. */
4496 gfc_free_expr (initializer
);
4502 /* Match the enumerator definition statement. */
4505 gfc_match_enumerator_def (void)
4510 gfc_clear_ts (¤t_ts
);
4512 m
= gfc_match (" enumerator");
4516 m
= gfc_match (" :: ");
4517 if (m
== MATCH_ERROR
)
4520 colon_seen
= (m
== MATCH_YES
);
4522 if (gfc_current_state () != COMP_ENUM
)
4524 gfc_error ("ENUM definition statement expected before %C");
4525 gfc_free_enum_history ();
4529 (¤t_ts
)->type
= BT_INTEGER
;
4530 (¤t_ts
)->kind
= gfc_c_int_kind
;
4532 gfc_clear_attr (¤t_attr
);
4533 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
4542 m
= enumerator_decl ();
4543 if (m
== MATCH_ERROR
)
4548 if (gfc_match_eos () == MATCH_YES
)
4550 if (gfc_match_char (',') != MATCH_YES
)
4554 if (gfc_current_state () == COMP_ENUM
)
4556 gfc_free_enum_history ();
4557 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4562 gfc_free_array_spec (current_as
);