blob: 3396c6ce4a79c8624ecb18c54e9ea41f55ec66dd [file] [log] [blame]
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +00001/* Perform type resolution on the various structures.
Jakub Jelinek7adcbaf2022-01-03 10:42:10 +01002 Copyright (C) 2001-2022 Free Software Foundation, Inc.
Diego Novillo6de9cd92004-05-13 02:41:07 -04003 Contributed by Andy Vaught
4
Tobias Schlüter9fc4d792004-05-14 15:00:04 +02005This file is part of GCC.
Diego Novillo6de9cd92004-05-13 02:41:07 -04006
Tobias Schlüter9fc4d792004-05-14 15:00:04 +02007GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
Nick Cliftond234d782007-08-01 16:29:36 +00009Software Foundation; either version 3, or (at your option) any later
Tobias Schlüter9fc4d792004-05-14 15:00:04 +020010version.
Diego Novillo6de9cd92004-05-13 02:41:07 -040011
Tobias Schlüter9fc4d792004-05-14 15:00:04 +020012GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
Diego Novillo6de9cd92004-05-13 02:41:07 -040016
17You should have received a copy of the GNU General Public License
Nick Cliftond234d782007-08-01 16:29:36 +000018along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040020
21#include "config.h"
Steven G. Kargld22e4892005-01-03 21:43:55 +000022#include "system.h"
Steven Bosscher953bee72012-07-08 09:55:02 +000023#include "coretypes.h"
Andrew MacLeod1916bcb2015-07-09 11:27:35 +000024#include "options.h"
Tobias Schlüter0615f922007-04-13 15:48:08 +020025#include "bitmap.h"
Andrew MacLeod2adfab82015-10-29 15:27:20 +000026#include "gfortran.h"
Diego Novillo6de9cd92004-05-13 02:41:07 -040027#include "arith.h" /* For gfc_compare_expr(). */
Richard Sandiford1524f802005-12-13 05:23:12 +000028#include "dependency.h"
Francois-Xavier Coudertca39e6f2007-10-05 12:33:07 +000029#include "data.h"
Tobias Burnus00a46182007-12-08 22:46:56 +010030#include "target-memory.h" /* for gfc_simplify_transfer */
Jerry DeLisleb7e75772010-04-13 01:59:35 +000031#include "constructor.h"
Steven G. Kargld22e4892005-01-03 21:43:55 +000032
Paul Thomase8ec07e2005-10-01 07:39:08 +000033/* Types used in equivalence statements. */
34
Trevor Saundersa79683d2015-08-19 02:48:48 +000035enum seq_type
Paul Thomase8ec07e2005-10-01 07:39:08 +000036{
37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
Trevor Saundersa79683d2015-08-19 02:48:48 +000038};
Diego Novillo6de9cd92004-05-13 02:41:07 -040039
Tobias Schlüter0615f922007-04-13 15:48:08 +020040/* Stack to keep track of the nesting of blocks as we move through the
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020041 code. See resolve_branch() and gfc_resolve_code(). */
Diego Novillo6de9cd92004-05-13 02:41:07 -040042
43typedef struct code_stack
44{
Tobias Schlüterd80c6952009-03-29 19:15:48 +020045 struct gfc_code *head, *current;
Diego Novillo6de9cd92004-05-13 02:41:07 -040046 struct code_stack *prev;
Tobias Schlüter0615f922007-04-13 15:48:08 +020047
48 /* This bitmap keeps track of the targets valid for a branch from
Tobias Schlüterd80c6952009-03-29 19:15:48 +020049 inside this block except for END {IF|SELECT}s of enclosing
50 blocks. */
Tobias Schlüter0615f922007-04-13 15:48:08 +020051 bitmap reachable_labels;
Diego Novillo6de9cd92004-05-13 02:41:07 -040052}
53code_stack;
54
55static code_stack *cs_base = NULL;
56
57
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020058/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040059
60static int forall_flag;
Thomas Koenigce96d372013-09-02 22:09:07 +000061int gfc_do_concurrent_flag;
Diego Novillo6de9cd92004-05-13 02:41:07 -040062
Tobias Burnusc62c6622012-07-20 07:56:37 +020063/* True when we are resolving an expression that is an actual argument to
64 a procedure. */
65static bool actual_arg = false;
66/* True when we are resolving an expression that is the first actual argument
67 to a procedure. */
68static bool first_actual_arg = false;
69
Tobias Burnus45a69322012-03-03 09:40:24 +010070
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010071/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
72
73static int omp_workshare_flag;
74
Janus Weil7a283532016-12-13 19:55:20 +010075/* True if we are processing a formal arglist. The corresponding function
Paul Thomas4213f932005-10-17 20:52:37 +000076 resets the flag each time that it is read. */
Janus Weil7a283532016-12-13 19:55:20 +010077static bool formal_arg_flag = false;
Paul Thomas4213f932005-10-17 20:52:37 +000078
Paul Thomas0e9a4452006-06-07 07:20:39 +000079/* True if we are resolving a specification expression. */
Tobias Burnusfd061182012-10-18 19:09:13 +020080static bool specification_expr = false;
Paul Thomas0e9a4452006-06-07 07:20:39 +000081
82/* The id of the last entry seen. */
83static int current_entry_id;
84
Tobias Schlüter0615f922007-04-13 15:48:08 +020085/* We use bitmaps to determine if a branch target is valid. */
86static bitmap_obstack labels_obstack;
87
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020088/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
89static bool inquiry_argument = false;
90
Tobias Burnusc62c6622012-07-20 07:56:37 +020091
Janus Weil7a283532016-12-13 19:55:20 +010092bool
Paul Thomas4213f932005-10-17 20:52:37 +000093gfc_is_formal_arg (void)
94{
95 return formal_arg_flag;
96}
97
Paul Thomasc867b7b2009-04-20 21:55:26 +000098/* Is the symbol host associated? */
99static bool
100is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
101{
102 for (ns = ns->parent; ns; ns = ns->parent)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +0000103 {
Paul Thomasc867b7b2009-04-20 21:55:26 +0000104 if (sym->ns == ns)
105 return true;
106 }
107
108 return false;
109}
Daniel Kraft52f49932008-09-02 10:13:21 +0200110
111/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
112 an ABSTRACT derived-type. If where is not NULL, an error message with that
113 locus is printed, optionally using name. */
114
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300115static bool
Daniel Kraft52f49932008-09-02 10:13:21 +0200116resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
117{
Janus Weilbc21d312009-08-13 21:46:46 +0200118 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
Daniel Kraft52f49932008-09-02 10:13:21 +0200119 {
120 if (where)
121 {
122 if (name)
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100123 gfc_error ("%qs at %L is of the ABSTRACT type %qs",
Janus Weilbc21d312009-08-13 21:46:46 +0200124 name, where, ts->u.derived->name);
Daniel Kraft52f49932008-09-02 10:13:21 +0200125 else
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100126 gfc_error ("ABSTRACT type %qs used at %L",
Janus Weilbc21d312009-08-13 21:46:46 +0200127 ts->u.derived->name, where);
Daniel Kraft52f49932008-09-02 10:13:21 +0200128 }
129
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300130 return false;
Daniel Kraft52f49932008-09-02 10:13:21 +0200131 }
132
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300133 return true;
Daniel Kraft52f49932008-09-02 10:13:21 +0200134}
135
136
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300137static bool
Janus Weilb6a45602012-08-02 10:57:58 +0200138check_proc_interface (gfc_symbol *ifc, locus *where)
139{
140 /* Several checks for F08:C1216. */
141 if (ifc->attr.procedure)
142 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100143 gfc_error ("Interface %qs at %L is declared "
Janus Weilb6a45602012-08-02 10:57:58 +0200144 "in a later PROCEDURE statement", ifc->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300145 return false;
Janus Weilb6a45602012-08-02 10:57:58 +0200146 }
147 if (ifc->generic)
148 {
149 /* For generic interfaces, check if there is
150 a specific procedure with the same name. */
151 gfc_interface *gen = ifc->generic;
152 while (gen && strcmp (gen->sym->name, ifc->name) != 0)
153 gen = gen->next;
154 if (!gen)
155 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100156 gfc_error ("Interface %qs at %L may not be generic",
Janus Weilb6a45602012-08-02 10:57:58 +0200157 ifc->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300158 return false;
Janus Weilb6a45602012-08-02 10:57:58 +0200159 }
160 }
161 if (ifc->attr.proc == PROC_ST_FUNCTION)
162 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100163 gfc_error ("Interface %qs at %L may not be a statement function",
Janus Weilb6a45602012-08-02 10:57:58 +0200164 ifc->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300165 return false;
Janus Weilb6a45602012-08-02 10:57:58 +0200166 }
167 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at)
168 || gfc_is_intrinsic (ifc, 1, ifc->declared_at))
169 ifc->attr.intrinsic = 1;
170 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0))
171 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100172 gfc_error ("Intrinsic procedure %qs not allowed in "
Janus Weilb6a45602012-08-02 10:57:58 +0200173 "PROCEDURE statement at %L", ifc->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300174 return false;
Janus Weilb6a45602012-08-02 10:57:58 +0200175 }
176 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
177 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100178 gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300179 return false;
Janus Weilb6a45602012-08-02 10:57:58 +0200180 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300181 return true;
Janus Weilb6a45602012-08-02 10:57:58 +0200182}
183
184
Janus Weil2fcac972010-08-23 14:26:42 +0200185static void resolve_symbol (gfc_symbol *sym);
Janus Weil2fcac972010-08-23 14:26:42 +0200186
187
188/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
189
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300190static bool
Janus Weil2fcac972010-08-23 14:26:42 +0200191resolve_procedure_interface (gfc_symbol *sym)
192{
Janus Weil0e8d8542012-07-31 20:32:41 +0200193 gfc_symbol *ifc = sym->ts.interface;
194
195 if (!ifc)
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300196 return true;
Janus Weil0e8d8542012-07-31 20:32:41 +0200197
Janus Weil0e8d8542012-07-31 20:32:41 +0200198 if (ifc == sym)
Janus Weil2fcac972010-08-23 14:26:42 +0200199 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface",
Janus Weil2fcac972010-08-23 14:26:42 +0200201 sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300202 return false;
Janus Weil2fcac972010-08-23 14:26:42 +0200203 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300204 if (!check_proc_interface (ifc, &sym->declared_at))
205 return false;
Janus Weil2fcac972010-08-23 14:26:42 +0200206
Janus Weil0e8d8542012-07-31 20:32:41 +0200207 if (ifc->attr.if_source || ifc->attr.intrinsic)
Janus Weil2fcac972010-08-23 14:26:42 +0200208 {
Janus Weilb6a45602012-08-02 10:57:58 +0200209 /* Resolve interface and copy attributes. */
Janus Weil2fcac972010-08-23 14:26:42 +0200210 resolve_symbol (ifc);
Janus Weil2fcac972010-08-23 14:26:42 +0200211 if (ifc->attr.intrinsic)
Janus Weil2dda89a2012-07-30 21:55:41 +0200212 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
Janus Weil2fcac972010-08-23 14:26:42 +0200213
214 if (ifc->result)
Janus Weilc79bb352011-02-09 23:59:02 +0100215 {
216 sym->ts = ifc->result->ts;
Janus Weild809e152016-11-14 17:55:01 +0100217 sym->attr.allocatable = ifc->result->attr.allocatable;
218 sym->attr.pointer = ifc->result->attr.pointer;
219 sym->attr.dimension = ifc->result->attr.dimension;
220 sym->attr.class_ok = ifc->result->attr.class_ok;
221 sym->as = gfc_copy_array_spec (ifc->result->as);
Janus Weilc79bb352011-02-09 23:59:02 +0100222 sym->result = sym;
223 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +0000224 else
Janus Weild809e152016-11-14 17:55:01 +0100225 {
226 sym->ts = ifc->ts;
227 sym->attr.allocatable = ifc->attr.allocatable;
228 sym->attr.pointer = ifc->attr.pointer;
229 sym->attr.dimension = ifc->attr.dimension;
230 sym->attr.class_ok = ifc->attr.class_ok;
231 sym->as = gfc_copy_array_spec (ifc->as);
232 }
Janus Weil2fcac972010-08-23 14:26:42 +0200233 sym->ts.interface = ifc;
234 sym->attr.function = ifc->attr.function;
235 sym->attr.subroutine = ifc->attr.subroutine;
Janus Weil2fcac972010-08-23 14:26:42 +0200236
Janus Weil2fcac972010-08-23 14:26:42 +0200237 sym->attr.pure = ifc->attr.pure;
238 sym->attr.elemental = ifc->attr.elemental;
Janus Weil2fcac972010-08-23 14:26:42 +0200239 sym->attr.contiguous = ifc->attr.contiguous;
240 sym->attr.recursive = ifc->attr.recursive;
241 sym->attr.always_explicit = ifc->attr.always_explicit;
242 sym->attr.ext_attr |= ifc->attr.ext_attr;
Janus Weil8be3d7d2010-11-11 22:44:15 +0100243 sym->attr.is_bind_c = ifc->attr.is_bind_c;
Janus Weil2fcac972010-08-23 14:26:42 +0200244 /* Copy char length. */
245 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
246 {
247 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
Janus Weil2fcac972010-08-23 14:26:42 +0200248 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300249 && !gfc_resolve_expr (sym->ts.u.cl->length))
250 return false;
Janus Weil2fcac972010-08-23 14:26:42 +0200251 }
252 }
Janus Weil2fcac972010-08-23 14:26:42 +0200253
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300254 return true;
Janus Weil2fcac972010-08-23 14:26:42 +0200255}
256
257
Diego Novillo6de9cd92004-05-13 02:41:07 -0400258/* Resolve types of formal argument lists. These have to be done early so that
259 the formal argument lists of module procedures can be copied to the
260 containing module before the individual procedures are resolved
261 individually. We also resolve argument lists of procedures in interface
262 blocks because they are self-contained scoping units.
263
264 Since a dummy argument cannot be a non-dummy procedure, the only
265 resort left for untyped names are the IMPLICIT types. */
266
Tobias Burnus3ab216a2020-04-02 18:27:09 +0200267void
268gfc_resolve_formal_arglist (gfc_symbol *proc)
Diego Novillo6de9cd92004-05-13 02:41:07 -0400269{
270 gfc_formal_arglist *f;
271 gfc_symbol *sym;
Tobias Burnusfd061182012-10-18 19:09:13 +0200272 bool saved_specification_expr;
Diego Novillo6de9cd92004-05-13 02:41:07 -0400273 int i;
274
Diego Novillo6de9cd92004-05-13 02:41:07 -0400275 if (proc->result != NULL)
276 sym = proc->result;
277 else
278 sym = proc;
279
280 if (gfc_elemental (proc)
281 || sym->attr.pointer || sym->attr.allocatable
Tobias Burnusc62c6622012-07-20 07:56:37 +0200282 || (sym->as && sym->as->rank != 0))
Francois-Xavier Coudert43e7fd22008-02-28 15:42:21 +0000283 {
284 proc->attr.always_explicit = 1;
285 sym->attr.always_explicit = 1;
286 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400287
Janus Weil7a283532016-12-13 19:55:20 +0100288 formal_arg_flag = true;
Paul Thomas4213f932005-10-17 20:52:37 +0000289
Diego Novillo6de9cd92004-05-13 02:41:07 -0400290 for (f = proc->formal; f; f = f->next)
291 {
Tobias Burnus3d333a22012-07-19 22:20:17 +0200292 gfc_array_spec *as;
Diego Novillo6de9cd92004-05-13 02:41:07 -0400293
Tobias Burnus6220bf42012-07-21 11:37:18 +0200294 sym = f->sym;
295
Diego Novillo6de9cd92004-05-13 02:41:07 -0400296 if (sym == NULL)
297 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000298 /* Alternate return placeholder. */
Diego Novillo6de9cd92004-05-13 02:41:07 -0400299 if (gfc_elemental (proc))
300 gfc_error ("Alternate return specifier in elemental subroutine "
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100301 "%qs at %L is not allowed", proc->name,
Diego Novillo6de9cd92004-05-13 02:41:07 -0400302 &proc->declared_at);
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000303 if (proc->attr.function)
304 gfc_error ("Alternate return specifier in function "
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100305 "%qs at %L is not allowed", proc->name,
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000306 &proc->declared_at);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400307 continue;
308 }
Janus Weil0e8d8542012-07-31 20:32:41 +0200309 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300310 && !resolve_procedure_interface (sym))
Janus Weil0e8d8542012-07-31 20:32:41 +0200311 return;
Diego Novillo6de9cd92004-05-13 02:41:07 -0400312
Bud Davis92816252013-05-27 14:16:36 +0000313 if (strcmp (proc->name, sym->name) == 0)
314 {
315 gfc_error ("Self-referential argument "
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100316 "%qs at %L is not allowed", sym->name,
Bud Davis92816252013-05-27 14:16:36 +0000317 &proc->declared_at);
318 return;
319 }
320
Diego Novillo6de9cd92004-05-13 02:41:07 -0400321 if (sym->attr.if_source != IFSRC_UNKNOWN)
Tobias Burnus3ab216a2020-04-02 18:27:09 +0200322 gfc_resolve_formal_arglist (sym);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400323
Janus Weilfe445bf2011-10-16 21:16:59 +0200324 if (sym->attr.subroutine || sym->attr.external)
Janus Weil4056cc12011-09-29 13:57:35 +0200325 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200326 if (sym->attr.flavor == FL_UNKNOWN)
327 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at);
Janus Weil4056cc12011-09-29 13:57:35 +0200328 }
Janus Weilfe445bf2011-10-16 21:16:59 +0200329 else
Diego Novillo6de9cd92004-05-13 02:41:07 -0400330 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200331 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
332 && (!sym->attr.function || sym->result == sym))
333 gfc_set_default_type (sym, 1, sym->ns);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400334 }
335
Tobias Burnus3d333a22012-07-19 22:20:17 +0200336 as = sym->ts.type == BT_CLASS && sym->attr.class_ok
337 ? CLASS_DATA (sym)->as : sym->as;
338
Tobias Burnusfd061182012-10-18 19:09:13 +0200339 saved_specification_expr = specification_expr;
340 specification_expr = true;
Tobias Burnus3d333a22012-07-19 22:20:17 +0200341 gfc_resolve_array_spec (as, 0);
Tobias Burnusfd061182012-10-18 19:09:13 +0200342 specification_expr = saved_specification_expr;
Diego Novillo6de9cd92004-05-13 02:41:07 -0400343
344 /* We can't tell if an array with dimension (:) is assumed or deferred
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000345 shape until we know if it has the pointer or allocatable attributes.
Diego Novillo6de9cd92004-05-13 02:41:07 -0400346 */
Tobias Burnus3d333a22012-07-19 22:20:17 +0200347 if (as && as->rank > 0 && as->type == AS_DEFERRED
348 && ((sym->ts.type != BT_CLASS
349 && !(sym->attr.pointer || sym->attr.allocatable))
350 || (sym->ts.type == BT_CLASS
351 && !(CLASS_DATA (sym)->attr.class_pointer
352 || CLASS_DATA (sym)->attr.allocatable)))
Tobias Burnus12578be2011-04-29 18:49:53 +0200353 && sym->attr.flavor != FL_PROCEDURE)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000354 {
Tobias Burnus3d333a22012-07-19 22:20:17 +0200355 as->type = AS_ASSUMED_SHAPE;
356 for (i = 0; i < as->rank; i++)
357 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000358 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400359
Tobias Burnus3d333a22012-07-19 22:20:17 +0200360 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
Tobias Burnusc62c6622012-07-20 07:56:37 +0200361 || (as && as->type == AS_ASSUMED_RANK)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000362 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
Tobias Burnus3d333a22012-07-19 22:20:17 +0200363 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
364 && (CLASS_DATA (sym)->attr.class_pointer
365 || CLASS_DATA (sym)->attr.allocatable
366 || CLASS_DATA (sym)->attr.target))
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000367 || sym->attr.optional)
Francois-Xavier Coudert43e7fd22008-02-28 15:42:21 +0000368 {
369 proc->attr.always_explicit = 1;
370 if (proc->result)
371 proc->result->attr.always_explicit = 1;
372 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400373
374 /* If the flavor is unknown at this point, it has to be a variable.
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000375 A procedure specification would have already set the type. */
Diego Novillo6de9cd92004-05-13 02:41:07 -0400376
377 if (sym->attr.flavor == FL_UNKNOWN)
Tobias Schlüter231b2fc2005-02-07 23:16:13 +0100378 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400379
Janus Weilfe445bf2011-10-16 21:16:59 +0200380 if (gfc_pure (proc))
Diego Novillo6de9cd92004-05-13 02:41:07 -0400381 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200382 if (sym->attr.flavor == FL_PROCEDURE)
Tobias Burnusa26e8df2011-02-11 22:07:17 +0100383 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200384 /* F08:C1279. */
385 if (!gfc_pure (sym))
386 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must "
Janus Weilfe445bf2011-10-16 21:16:59 +0200388 "also be PURE", sym->name, &sym->declared_at);
389 continue;
390 }
Tobias Burnusa26e8df2011-02-11 22:07:17 +0100391 }
Janus Weilfe445bf2011-10-16 21:16:59 +0200392 else if (!sym->attr.pointer)
Tobias Burnusa26e8df2011-02-11 22:07:17 +0100393 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200394 if (proc->attr.function && sym->attr.intent != INTENT_IN)
395 {
396 if (sym->attr.value)
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100397 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
398 " of pure function %qs at %L with VALUE "
Janus Weilfe445bf2011-10-16 21:16:59 +0200399 "attribute but without INTENT(IN)",
400 sym->name, proc->name, &sym->declared_at);
401 else
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100402 gfc_error ("Argument %qs of pure function %qs at %L must "
Janus Weilfe445bf2011-10-16 21:16:59 +0200403 "be INTENT(IN) or VALUE", sym->name, proc->name,
404 &sym->declared_at);
405 }
406
407 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
408 {
409 if (sym->attr.value)
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100410 gfc_notify_std (GFC_STD_F2008, "Argument %qs"
411 " of pure subroutine %qs at %L with VALUE "
Janus Weilfe445bf2011-10-16 21:16:59 +0200412 "attribute but without INTENT", sym->name,
413 proc->name, &sym->declared_at);
414 else
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100415 gfc_error ("Argument %qs of pure subroutine %qs at %L "
Janus Weilfe445bf2011-10-16 21:16:59 +0200416 "must have its INTENT specified or have the "
417 "VALUE attribute", sym->name, proc->name,
418 &sym->declared_at);
419 }
Tobias Burnusa26e8df2011-02-11 22:07:17 +0100420 }
Janus Weilc19a0032014-12-27 23:40:21 +0100421
422 /* F08:C1278a. */
423 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT)
424 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +0000425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L"
Janus Weilc19a0032014-12-27 23:40:21 +0100426 " may not be polymorphic", sym->name, proc->name,
427 &sym->declared_at);
428 continue;
429 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400430 }
431
Janus Weilfe445bf2011-10-16 21:16:59 +0200432 if (proc->attr.implicit_pure)
Paul Thomasf1f39032011-01-08 19:17:03 +0000433 {
Janus Weilfe445bf2011-10-16 21:16:59 +0200434 if (sym->attr.flavor == FL_PROCEDURE)
435 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300436 if (!gfc_pure (sym))
Janus Weilfe445bf2011-10-16 21:16:59 +0200437 proc->attr.implicit_pure = 0;
438 }
439 else if (!sym->attr.pointer)
440 {
Tobias Burnusc915f8b2012-09-13 16:57:38 +0200441 if (proc->attr.function && sym->attr.intent != INTENT_IN
442 && !sym->value)
Janus Weilfe445bf2011-10-16 21:16:59 +0200443 proc->attr.implicit_pure = 0;
Paul Thomasf1f39032011-01-08 19:17:03 +0000444
Tobias Burnusc915f8b2012-09-13 16:57:38 +0200445 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
446 && !sym->value)
Janus Weilfe445bf2011-10-16 21:16:59 +0200447 proc->attr.implicit_pure = 0;
448 }
Paul Thomasf1f39032011-01-08 19:17:03 +0000449 }
450
Diego Novillo6de9cd92004-05-13 02:41:07 -0400451 if (gfc_elemental (proc))
452 {
Janus Weil4056cc12011-09-29 13:57:35 +0200453 /* F08:C1289. */
Tobias Burnus9775a922012-01-27 14:02:54 +0100454 if (sym->attr.codimension
455 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
456 && CLASS_DATA (sym)->attr.codimension))
Tobias Burnusbe59db22010-04-06 20:16:13 +0200457 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100458 gfc_error ("Coarray dummy argument %qs at %L to elemental "
Tobias Burnusbe59db22010-04-06 20:16:13 +0200459 "procedure", sym->name, &sym->declared_at);
460 continue;
461 }
462
Tobias Burnus9775a922012-01-27 14:02:54 +0100463 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
464 && CLASS_DATA (sym)->as))
Diego Novillo6de9cd92004-05-13 02:41:07 -0400465 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100466 gfc_error ("Argument %qs of elemental procedure at %L must "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000467 "be scalar", sym->name, &sym->declared_at);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400468 continue;
469 }
470
Tobias Burnus9775a922012-01-27 14:02:54 +0100471 if (sym->attr.allocatable
472 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
473 && CLASS_DATA (sym)->attr.allocatable))
Daniel Krafte6c14892010-08-15 17:28:10 +0200474 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100475 gfc_error ("Argument %qs of elemental procedure at %L cannot "
Daniel Krafte6c14892010-08-15 17:28:10 +0200476 "have the ALLOCATABLE attribute", sym->name,
477 &sym->declared_at);
478 continue;
479 }
480
Tobias Burnusc696c6f2012-01-27 14:59:04 +0100481 if (sym->attr.pointer
482 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
483 && CLASS_DATA (sym)->attr.class_pointer))
Diego Novillo6de9cd92004-05-13 02:41:07 -0400484 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000485 gfc_error ("Argument %qs of elemental procedure at %L cannot "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000486 "have the POINTER attribute", sym->name,
487 &sym->declared_at);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400488 continue;
489 }
Tobias Burnus242633d2008-01-06 10:18:43 +0100490
491 if (sym->attr.flavor == FL_PROCEDURE)
492 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000493 gfc_error ("Dummy procedure %qs not allowed in elemental "
494 "procedure %qs at %L", sym->name, proc->name,
Tobias Burnus242633d2008-01-06 10:18:43 +0100495 &sym->declared_at);
496 continue;
497 }
Daniel Krafte6c14892010-08-15 17:28:10 +0200498
Tobias Burnus25ffd462012-12-16 00:25:36 +0100499 /* Fortran 2008 Corrigendum 1, C1290a. */
500 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
Daniel Krafte6c14892010-08-15 17:28:10 +0200501 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000502 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
Tobias Burnus25ffd462012-12-16 00:25:36 +0100503 "have its INTENT specified or have the VALUE "
504 "attribute", sym->name, proc->name,
Daniel Krafte6c14892010-08-15 17:28:10 +0200505 &sym->declared_at);
506 continue;
507 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400508 }
509
510 /* Each dummy shall be specified to be scalar. */
511 if (proc->attr.proc == PROC_ST_FUNCTION)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000512 {
513 if (sym->as != NULL)
514 {
Francois-Xavier Coudert5f0367d2018-02-11 18:55:31 +0000515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name
516 shall be specified, explicitly or implicitly, to be scalar. */
517 gfc_error ("Argument '%s' of statement function '%s' at %L "
518 "must be scalar", sym->name, proc->name,
519 &proc->declared_at);
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000520 continue;
521 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400522
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000523 if (sym->ts.type == BT_CHARACTER)
524 {
Janus Weilbc21d312009-08-13 21:46:46 +0200525 gfc_charlen *cl = sym->ts.u.cl;
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000526 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
527 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000528 gfc_error ("Character-valued argument %qs of statement "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000529 "function at %L must have constant length",
530 sym->name, &sym->declared_at);
531 continue;
532 }
533 }
534 }
Diego Novillo6de9cd92004-05-13 02:41:07 -0400535 }
Janus Weil7a283532016-12-13 19:55:20 +0100536 formal_arg_flag = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -0400537}
538
539
540/* Work function called when searching for symbols that have argument lists
541 associated with them. */
542
543static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000544find_arglists (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -0400545{
Tobias Burnusc3f34952011-11-16 22:37:43 +0100546 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
Fritz Reesef6288c22016-05-07 23:16:23 +0000547 || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic)
Diego Novillo6de9cd92004-05-13 02:41:07 -0400548 return;
549
Tobias Burnus3ab216a2020-04-02 18:27:09 +0200550 gfc_resolve_formal_arglist (sym);
Diego Novillo6de9cd92004-05-13 02:41:07 -0400551}
552
553
554/* Given a namespace, resolve all formal argument lists within the namespace.
555 */
556
557static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000558resolve_formal_arglists (gfc_namespace *ns)
Diego Novillo6de9cd92004-05-13 02:41:07 -0400559{
Diego Novillo6de9cd92004-05-13 02:41:07 -0400560 if (ns == NULL)
561 return;
562
563 gfc_traverse_ns (ns, find_arglists);
564}
565
566
Paul Brook3d79abb2004-08-17 15:34:12 +0000567static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000568resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
Paul Brook3d79abb2004-08-17 15:34:12 +0000569{
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300570 bool t;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +0200571
Paul Thomas345bd7e2016-12-09 11:55:27 +0000572 if (sym && sym->attr.flavor == FL_PROCEDURE
573 && sym->ns->parent
574 && sym->ns->parent->proc_name
575 && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
576 && !strcmp (sym->name, sym->ns->parent->proc_name->name))
577 gfc_error ("Contained procedure %qs at %L has the same name as its "
578 "encompassing procedure", sym->name, &sym->declared_at);
579
Tobias Burnusb5bf3e42007-11-18 17:35:12 +0100580 /* If this namespace is not a function or an entry master function,
581 ignore it. */
582 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
583 || sym->attr.entry_master)
Paul Brook3d79abb2004-08-17 15:34:12 +0000584 return;
585
Steven G. Karglee3aab62019-06-19 17:58:54 +0000586 if (!sym->result)
587 return;
588
Paul Brook0dd973d2005-01-22 15:24:09 +0000589 /* Try to find out of what the return type is. */
Janus Weilf9909822009-06-18 10:09:40 +0200590 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
Paul Brook3d79abb2004-08-17 15:34:12 +0000591 {
Tobias Burnusc2de0c12007-05-27 23:24:48 +0200592 t = gfc_set_default_type (sym->result, 0, ns);
Paul Brook3d79abb2004-08-17 15:34:12 +0000593
Janne Blomqvist524af0d2013-04-11 00:36:58 +0300594 if (!t && !sym->result->attr.untyped)
Jakub Jelinekcf4d2462005-06-01 12:00:19 +0200595 {
Tobias Burnusc2de0c12007-05-27 23:24:48 +0200596 if (sym->result == sym)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000597 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
Tobias Burnusc2de0c12007-05-27 23:24:48 +0200598 sym->name, &sym->declared_at);
Janus Weil3070bab2009-04-09 11:39:09 +0200599 else if (!sym->result->attr.proc_pointer)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +0000600 gfc_error ("Result %qs of contained function %qs at %L has "
Tobias Burnusc2de0c12007-05-27 23:24:48 +0200601 "no IMPLICIT type", sym->result->name, sym->name,
602 &sym->result->declared_at);
603 sym->result->attr.untyped = 1;
Jakub Jelinekcf4d2462005-06-01 12:00:19 +0200604 }
Paul Brook3d79abb2004-08-17 15:34:12 +0000605 }
Paul Thomasb95605f2005-11-21 16:05:58 +0000606
Paul Thomas99d22932018-07-05 16:27:38 +0000607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000608 type, lists the only ways a character length value of * can be used:
Paul Thomas77f72c92018-06-21 22:38:55 +0000609 dummy arguments of procedures, named constants, function results and
610 in allocate statements if the allocate_object is an assumed length dummy
Daniel Kraft6c19d9b2009-10-07 20:13:28 +0200611 in external functions. Internal function results and results of module
612 procedures are not on this list, ergo, not permitted. */
Paul Thomasb95605f2005-11-21 16:05:58 +0000613
Tobias Burnusc2de0c12007-05-27 23:24:48 +0200614 if (sym->result->ts.type == BT_CHARACTER)
Paul Thomasb95605f2005-11-21 16:05:58 +0000615 {
Janus Weilbc21d312009-08-13 21:46:46 +0200616 gfc_charlen *cl = sym->result->ts.u.cl;
Paul Thomas8d51f262011-01-28 13:53:19 +0000617 if ((!cl || !cl->length) && !sym->result->ts.deferred)
Daniel Kraft6c19d9b2009-10-07 20:13:28 +0200618 {
619 /* See if this is a module-procedure and adapt error message
620 accordingly. */
621 bool module_proc;
622 gcc_assert (ns->parent && ns->parent->proc_name);
623 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
624
David Malcolm7fb22eb2017-03-15 18:05:06 +0000625 gfc_error (module_proc
626 ? G_("Character-valued module procedure %qs at %L"
627 " must not be assumed length")
628 : G_("Character-valued internal function %qs at %L"
629 " must not be assumed length"),
Daniel Kraft6c19d9b2009-10-07 20:13:28 +0200630 sym->name, &sym->declared_at);
631 }
Paul Thomasb95605f2005-11-21 16:05:58 +0000632 }
Paul Brook3d79abb2004-08-17 15:34:12 +0000633}
634
635
636/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
Kazu Hirataf7b529f2004-11-08 14:56:41 +0000637 introduce duplicates. */
Paul Brook3d79abb2004-08-17 15:34:12 +0000638
639static void
640merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
641{
642 gfc_formal_arglist *f, *new_arglist;
643 gfc_symbol *new_sym;
644
645 for (; new_args != NULL; new_args = new_args->next)
646 {
647 new_sym = new_args->sym;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +0200648 /* See if this arg is already in the formal argument list. */
Paul Brook3d79abb2004-08-17 15:34:12 +0000649 for (f = proc->formal; f; f = f->next)
650 {
651 if (new_sym == f->sym)
652 break;
653 }
654
655 if (f)
656 continue;
657
658 /* Add a new argument. Argument order is not important. */
659 new_arglist = gfc_get_formal_arglist ();
660 new_arglist->sym = new_sym;
661 new_arglist->next = proc->formal;
662 proc->formal = new_arglist;
663 }
664}
665
666
Paul Thomas54129a62006-12-22 20:49:00 +0000667/* Flag the arguments that are not present in all entries. */
668
669static void
670check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
671{
672 gfc_formal_arglist *f, *head;
673 head = new_args;
674
675 for (f = proc->formal; f; f = f->next)
676 {
677 if (f->sym == NULL)
678 continue;
679
680 for (new_args = head; new_args; new_args = new_args->next)
681 {
682 if (new_args->sym == f->sym)
683 break;
684 }
685
686 if (new_args)
687 continue;
688
689 f->sym->attr.not_always_present = 1;
690 }
691}
692
693
Paul Brook3d79abb2004-08-17 15:34:12 +0000694/* Resolve alternate entry points. If a symbol has multiple entry points we
695 create a new master symbol for the main routine, and turn the existing
696 symbol into an entry point. */
697
698static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000699resolve_entries (gfc_namespace *ns)
Paul Brook3d79abb2004-08-17 15:34:12 +0000700{
701 gfc_namespace *old_ns;
702 gfc_code *c;
703 gfc_symbol *proc;
704 gfc_entry_list *el;
705 char name[GFC_MAX_SYMBOL_LEN + 1];
706 static int master_count = 0;
707
708 if (ns->proc_name == NULL)
709 return;
710
711 /* No need to do anything if this procedure doesn't have alternate entry
712 points. */
713 if (!ns->entries)
714 return;
715
716 /* We may already have resolved alternate entry points. */
717 if (ns->proc_name->attr.entry_master)
718 return;
719
Kazu Hirataf7b529f2004-11-08 14:56:41 +0000720 /* If this isn't a procedure something has gone horribly wrong. */
Paul Brook6e45f572004-09-08 14:33:03 +0000721 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +0200722
Paul Brook3d79abb2004-08-17 15:34:12 +0000723 /* Remember the current namespace. */
724 old_ns = gfc_current_ns;
725
726 gfc_current_ns = ns;
727
728 /* Add the main entry point to the list of entry points. */
729 el = gfc_get_entry_list ();
730 el->sym = ns->proc_name;
731 el->id = 0;
732 el->next = ns->entries;
733 ns->entries = el;
734 ns->proc_name->attr.entry = 1;
735
Paul Thomas1a492602006-06-09 22:16:08 +0000736 /* If it is a module function, it needs to be in the right namespace
737 so that gfc_get_fake_result_decl can gather up the results. The
738 need for this arose in get_proc_name, where these beasts were
739 left in their own namespace, to keep prior references linked to
740 the entry declaration.*/
741 if (ns->proc_name->attr.function
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000742 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
Paul Thomas1a492602006-06-09 22:16:08 +0000743 el->sym->ns = ns;
744
Paul Thomas08ee9e82007-07-31 22:14:29 +0000745 /* Do the same for entries where the master is not a module
746 procedure. These are retained in the module namespace because
747 of the module procedure declaration. */
748 for (el = el->next; el; el = el->next)
749 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
750 && el->sym->attr.mod_proc)
751 el->sym->ns = ns;
752 el = ns->entries;
753
Paul Brook3d79abb2004-08-17 15:34:12 +0000754 /* Add an entry statement for it. */
Janus Weil11e52742013-08-09 21:26:07 +0200755 c = gfc_get_code (EXEC_ENTRY);
Paul Brook3d79abb2004-08-17 15:34:12 +0000756 c->ext.entry = el;
757 c->next = ns->code;
758 ns->code = c;
759
760 /* Create a new symbol for the master function. */
761 /* Give the internal function a unique name (within this file).
Tobias Schlüter7be7d412004-08-24 18:54:52 +0200762 Also include the function name so the user has some hope of figuring
763 out what is going on. */
Paul Brook3d79abb2004-08-17 15:34:12 +0000764 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
765 master_count++, ns->proc_name->name);
Paul Brook3d79abb2004-08-17 15:34:12 +0000766 gfc_get_ha_symbol (name, &proc);
Paul Brook6e45f572004-09-08 14:33:03 +0000767 gcc_assert (proc != NULL);
Paul Brook3d79abb2004-08-17 15:34:12 +0000768
Tobias Schlüter231b2fc2005-02-07 23:16:13 +0100769 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
Paul Brook3d79abb2004-08-17 15:34:12 +0000770 if (ns->proc_name->attr.subroutine)
Tobias Schlüter231b2fc2005-02-07 23:16:13 +0100771 gfc_add_subroutine (&proc->attr, proc->name, NULL);
Paul Brook3d79abb2004-08-17 15:34:12 +0000772 else
773 {
Jakub Jelinekd198b592005-04-29 17:31:39 +0200774 gfc_symbol *sym;
775 gfc_typespec *ts, *fts;
Paul Thomas5be38272006-10-03 20:13:03 +0000776 gfc_array_spec *as, *fas;
Tobias Schlüter231b2fc2005-02-07 23:16:13 +0100777 gfc_add_function (&proc->attr, proc->name, NULL);
Jakub Jelinekd198b592005-04-29 17:31:39 +0200778 proc->result = proc;
Paul Thomas5be38272006-10-03 20:13:03 +0000779 fas = ns->entries->sym->as;
780 fas = fas ? fas : ns->entries->sym->result->as;
Jakub Jelinekd198b592005-04-29 17:31:39 +0200781 fts = &ns->entries->sym->result->ts;
782 if (fts->type == BT_UNKNOWN)
Janus Weil713485c2009-05-06 23:17:16 +0200783 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
Jakub Jelinekd198b592005-04-29 17:31:39 +0200784 for (el = ns->entries->next; el; el = el->next)
785 {
786 ts = &el->sym->result->ts;
Paul Thomas5be38272006-10-03 20:13:03 +0000787 as = el->sym->as;
788 as = as ? as : el->sym->result->as;
Jakub Jelinekd198b592005-04-29 17:31:39 +0200789 if (ts->type == BT_UNKNOWN)
Janus Weil713485c2009-05-06 23:17:16 +0200790 ts = gfc_get_default_type (el->sym->result->name, NULL);
Paul Thomas5be38272006-10-03 20:13:03 +0000791
Jakub Jelinekd198b592005-04-29 17:31:39 +0200792 if (! gfc_compare_types (ts, fts)
793 || (el->sym->result->attr.dimension
794 != ns->entries->sym->result->attr.dimension)
795 || (el->sym->result->attr.pointer
796 != ns->entries->sym->result->attr.pointer))
797 break;
Paul Thomasf5d67ed2008-01-20 16:58:15 +0000798 else if (as && fas && ns->entries->sym->result != el->sym->result
799 && gfc_compare_array_spec (as, fas) == 0)
Tobias Burnus107d5ff2007-12-23 19:17:08 +0100800 gfc_error ("Function %s at %L has entries with mismatched "
Paul Thomas5be38272006-10-03 20:13:03 +0000801 "array specifications", ns->entries->sym->name,
802 &ns->entries->sym->declared_at);
Tobias Burnus107d5ff2007-12-23 19:17:08 +0100803 /* The characteristics need to match and thus both need to have
804 the same string length, i.e. both len=*, or both len=4.
805 Having both len=<variable> is also possible, but difficult to
806 check at compile time. */
Harald Anlauff9809ef2021-08-28 20:09:44 +0200807 else if (ts->type == BT_CHARACTER
808 && (el->sym->result->attr.allocatable
809 != ns->entries->sym->result->attr.allocatable))
810 {
811 gfc_error ("Function %s at %L has entry %s with mismatched "
812 "characteristics", ns->entries->sym->name,
813 &ns->entries->sym->declared_at, el->sym->name);
Harald Anlaufb305ec92021-09-14 20:23:27 +0200814 goto cleanup;
Harald Anlauff9809ef2021-08-28 20:09:44 +0200815 }
Janus Weilbc21d312009-08-13 21:46:46 +0200816 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
817 && (((ts->u.cl->length && !fts->u.cl->length)
818 ||(!ts->u.cl->length && fts->u.cl->length))
819 || (ts->u.cl->length
820 && ts->u.cl->length->expr_type
821 != fts->u.cl->length->expr_type)
822 || (ts->u.cl->length
823 && ts->u.cl->length->expr_type == EXPR_CONSTANT
824 && mpz_cmp (ts->u.cl->length->value.integer,
825 fts->u.cl->length->value.integer) != 0)))
Janus Weil9717f7a2012-07-17 23:51:20 +0200826 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
Tobias Burnus107d5ff2007-12-23 19:17:08 +0100827 "entries returning variables of different "
828 "string lengths", ns->entries->sym->name,
829 &ns->entries->sym->declared_at);
Jakub Jelinekd198b592005-04-29 17:31:39 +0200830 }
831
832 if (el == NULL)
833 {
834 sym = ns->entries->sym->result;
835 /* All result types the same. */
836 proc->ts = *fts;
837 if (sym->attr.dimension)
838 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
839 if (sym->attr.pointer)
840 gfc_add_pointer (&proc->attr, NULL);
841 }
842 else
843 {
Kazu Hirata49de9e72005-08-06 12:56:19 +0000844 /* Otherwise the result will be passed through a union by
Jakub Jelinekd198b592005-04-29 17:31:39 +0200845 reference. */
846 proc->attr.mixed_entry_master = 1;
847 for (el = ns->entries; el; el = el->next)
848 {
849 sym = el->sym->result;
850 if (sym->attr.dimension)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000851 {
852 if (el == ns->entries)
Martin Liska1fe61ad2019-03-12 16:11:42 +0100853 gfc_error ("FUNCTION result %s cannot be an array in "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000854 "FUNCTION %s at %L", sym->name,
855 ns->entries->sym->name, &sym->declared_at);
856 else
Martin Liska1fe61ad2019-03-12 16:11:42 +0100857 gfc_error ("ENTRY result %s cannot be an array in "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000858 "FUNCTION %s at %L", sym->name,
859 ns->entries->sym->name, &sym->declared_at);
860 }
Jakub Jelinekd198b592005-04-29 17:31:39 +0200861 else if (sym->attr.pointer)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000862 {
863 if (el == ns->entries)
Martin Liska1fe61ad2019-03-12 16:11:42 +0100864 gfc_error ("FUNCTION result %s cannot be a POINTER in "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000865 "FUNCTION %s at %L", sym->name,
866 ns->entries->sym->name, &sym->declared_at);
867 else
Martin Liska1fe61ad2019-03-12 16:11:42 +0100868 gfc_error ("ENTRY result %s cannot be a POINTER in "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000869 "FUNCTION %s at %L", sym->name,
870 ns->entries->sym->name, &sym->declared_at);
871 }
Jakub Jelinekd198b592005-04-29 17:31:39 +0200872 else
873 {
874 ts = &sym->ts;
875 if (ts->type == BT_UNKNOWN)
Janus Weil713485c2009-05-06 23:17:16 +0200876 ts = gfc_get_default_type (sym->name, NULL);
Jakub Jelinekd198b592005-04-29 17:31:39 +0200877 switch (ts->type)
878 {
879 case BT_INTEGER:
880 if (ts->kind == gfc_default_integer_kind)
881 sym = NULL;
882 break;
883 case BT_REAL:
884 if (ts->kind == gfc_default_real_kind
885 || ts->kind == gfc_default_double_kind)
886 sym = NULL;
887 break;
888 case BT_COMPLEX:
889 if (ts->kind == gfc_default_complex_kind)
890 sym = NULL;
891 break;
892 case BT_LOGICAL:
893 if (ts->kind == gfc_default_logical_kind)
894 sym = NULL;
895 break;
Jakub Jelinekcf4d2462005-06-01 12:00:19 +0200896 case BT_UNKNOWN:
897 /* We will issue error elsewhere. */
898 sym = NULL;
899 break;
Jakub Jelinekd198b592005-04-29 17:31:39 +0200900 default:
901 break;
902 }
903 if (sym)
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000904 {
905 if (el == ns->entries)
Martin Liska1fe61ad2019-03-12 16:11:42 +0100906 gfc_error ("FUNCTION result %s cannot be of type %s "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000907 "in FUNCTION %s at %L", sym->name,
908 gfc_typename (ts), ns->entries->sym->name,
909 &sym->declared_at);
910 else
Martin Liska1fe61ad2019-03-12 16:11:42 +0100911 gfc_error ("ENTRY result %s cannot be of type %s "
Steven G. Kargledf1eac2007-01-20 22:01:41 +0000912 "in FUNCTION %s at %L", sym->name,
913 gfc_typename (ts), ns->entries->sym->name,
914 &sym->declared_at);
915 }
Jakub Jelinekd198b592005-04-29 17:31:39 +0200916 }
917 }
918 }
Paul Brook3d79abb2004-08-17 15:34:12 +0000919 }
Harald Anlaufb305ec92021-09-14 20:23:27 +0200920
921cleanup:
Paul Brook3d79abb2004-08-17 15:34:12 +0000922 proc->attr.access = ACCESS_PRIVATE;
923 proc->attr.entry_master = 1;
924
925 /* Merge all the entry point arguments. */
926 for (el = ns->entries; el; el = el->next)
927 merge_argument_lists (proc, el->sym->formal);
928
Paul Thomas54129a62006-12-22 20:49:00 +0000929 /* Check the master formal arguments for any that are not
930 present in all entry points. */
931 for (el = ns->entries; el; el = el->next)
932 check_argument_lists (proc, el->sym->formal);
933
Tobias Schlüter7be7d412004-08-24 18:54:52 +0200934 /* Use the master function for the function body. */
Paul Brook3d79abb2004-08-17 15:34:12 +0000935 ns->proc_name = proc;
936
Tobias Schlüter7be7d412004-08-24 18:54:52 +0200937 /* Finalize the new symbols. */
Paul Brook3d79abb2004-08-17 15:34:12 +0000938 gfc_commit_symbols ();
939
940 /* Restore the original namespace. */
941 gfc_current_ns = old_ns;
942}
943
944
Tobias Burnus346ecba2008-01-06 19:17:14 +0100945/* Resolve common variables. */
Tobias Burnusad22b1f2007-07-03 23:41:34 +0200946static void
Mikael Morin6dcab502015-10-04 12:07:50 +0000947resolve_common_vars (gfc_common_head *common_block, bool named_common)
Tobias Burnusad22b1f2007-07-03 23:41:34 +0200948{
Mikael Morin6dcab502015-10-04 12:07:50 +0000949 gfc_symbol *csym = common_block->head;
Mark Eggleston4d2a56a2020-06-11 14:33:51 +0100950 gfc_gsymbol *gsym;
Tobias Burnusad22b1f2007-07-03 23:41:34 +0200951
Tobias Burnus346ecba2008-01-06 19:17:14 +0100952 for (; csym; csym = csym->common_next)
Tobias Burnus041cf982007-08-26 20:29:45 +0200953 {
Mark Eggleston4d2a56a2020-06-11 14:33:51 +0100954 gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name);
955 if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM))
956 gfc_error_now ("Global entity %qs at %L cannot appear in a "
957 "COMMON block at %L", gsym->name,
958 &gsym->where, &csym->common_block->where);
959
Mikael Morin2b3f52a2015-10-04 12:30:16 +0000960 /* gfc_add_in_common may have been called before, but the reported errors
961 have been ignored to continue parsing.
962 We do the checks again here. */
963 if (!csym->attr.use_assoc)
Harald Anlauf0f7cec02019-02-17 21:19:20 +0000964 {
965 gfc_add_in_common (&csym->attr, csym->name, &common_block->where);
966 gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L",
967 &common_block->where);
968 }
Mikael Morin2b3f52a2015-10-04 12:30:16 +0000969
Tobias Burnus346ecba2008-01-06 19:17:14 +0100970 if (csym->value || csym->attr.data)
971 {
972 if (!csym->ns->is_block_data)
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100973 gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON "
Tobias Burnus346ecba2008-01-06 19:17:14 +0100974 "but only in BLOCK DATA initialization is "
975 "allowed", csym->name, &csym->declared_at);
976 else if (!named_common)
Tobias Burnusa4d9b222014-12-13 00:12:06 +0100977 gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is "
Tobias Burnus346ecba2008-01-06 19:17:14 +0100978 "in a blank COMMON but initialization is only "
979 "allowed in named common blocks", csym->name,
980 &csym->declared_at);
981 }
982
Paul Thomas8b704312012-12-20 00:15:00 +0000983 if (UNLIMITED_POLY (csym))
Harald Anlaufa88280c2021-09-01 19:05:47 +0200984 gfc_error_now ("%qs at %L cannot appear in COMMON "
Paul Thomas8b704312012-12-20 00:15:00 +0000985 "[F2008:C5100]", csym->name, &csym->declared_at);
986
Tobias Schlüter448d2cd2007-10-03 13:37:44 +0200987 if (csym->ts.type != BT_DERIVED)
988 continue;
989
Janus Weilbc21d312009-08-13 21:46:46 +0200990 if (!(csym->ts.u.derived->attr.sequence
991 || csym->ts.u.derived->attr.is_bind_c))
Tobias Burnus4daa1492014-11-25 23:33:32 +0100992 gfc_error_now ("Derived type variable %qs in COMMON at %L "
Tobias Schlüter448d2cd2007-10-03 13:37:44 +0200993 "has neither the SEQUENCE nor the BIND(C) "
994 "attribute", csym->name, &csym->declared_at);
Janus Weilbc21d312009-08-13 21:46:46 +0200995 if (csym->ts.u.derived->attr.alloc_comp)
Tobias Burnus4daa1492014-11-25 23:33:32 +0100996 gfc_error_now ("Derived type variable %qs in COMMON at %L "
Tobias Schlüter448d2cd2007-10-03 13:37:44 +0200997 "has an ultimate component that is "
998 "allocatable", csym->name, &csym->declared_at);
Daniel Franke16e520b2010-05-19 09:07:25 -0400999 if (gfc_has_default_initializer (csym->ts.u.derived))
Tobias Burnus4daa1492014-11-25 23:33:32 +01001000 gfc_error_now ("Derived type variable %qs in COMMON at %L "
Tobias Schlüter448d2cd2007-10-03 13:37:44 +02001001 "may not have default initializer", csym->name,
1002 &csym->declared_at);
Tobias Burnus6f9c9d62009-04-03 20:26:44 +02001003
1004 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
1005 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
Tobias Burnus041cf982007-08-26 20:29:45 +02001006 }
Tobias Burnus346ecba2008-01-06 19:17:14 +01001007}
1008
1009/* Resolve common blocks. */
1010static void
1011resolve_common_blocks (gfc_symtree *common_root)
1012{
1013 gfc_symbol *sym;
Tobias Burnus878cdb72013-05-20 22:03:48 +02001014 gfc_gsymbol * gsym;
Tobias Burnus346ecba2008-01-06 19:17:14 +01001015
1016 if (common_root == NULL)
1017 return;
1018
1019 if (common_root->left)
1020 resolve_common_blocks (common_root->left);
1021 if (common_root->right)
1022 resolve_common_blocks (common_root->right);
1023
Mikael Morin6dcab502015-10-04 12:07:50 +00001024 resolve_common_vars (common_root->n.common, true);
Tobias Burnusad22b1f2007-07-03 23:41:34 +02001025
Tobias Burnus878cdb72013-05-20 22:03:48 +02001026 /* The common name is a global name - in Fortran 2003 also if it has a
1027 C binding name, since Fortran 2008 only the C binding name is a global
1028 identifier. */
1029 if (!common_root->n.common->binding_label
1030 || gfc_notification_std (GFC_STD_F2008))
1031 {
1032 gsym = gfc_find_gsymbol (gfc_gsym_root,
1033 common_root->n.common->name);
1034
1035 if (gsym && gfc_notification_std (GFC_STD_F2008)
1036 && gsym->type == GSYM_COMMON
1037 && ((common_root->n.common->binding_label
1038 && (!gsym->binding_label
1039 || strcmp (common_root->n.common->binding_label,
1040 gsym->binding_label) != 0))
1041 || (!common_root->n.common->binding_label
1042 && gsym->binding_label)))
1043 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00001044 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global "
Tobias Burnus878cdb72013-05-20 22:03:48 +02001045 "identifier and must thus have the same binding name "
1046 "as the same-named COMMON block at %L: %s vs %s",
1047 common_root->n.common->name, &common_root->n.common->where,
1048 &gsym->where,
1049 common_root->n.common->binding_label
1050 ? common_root->n.common->binding_label : "(blank)",
1051 gsym->binding_label ? gsym->binding_label : "(blank)");
1052 return;
1053 }
1054
1055 if (gsym && gsym->type != GSYM_COMMON
1056 && !common_root->n.common->binding_label)
1057 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00001058 gfc_error ("COMMON block %qs at %L uses the same global identifier "
Tobias Burnus878cdb72013-05-20 22:03:48 +02001059 "as entity at %L",
1060 common_root->n.common->name, &common_root->n.common->where,
1061 &gsym->where);
1062 return;
1063 }
1064 if (gsym && gsym->type != GSYM_COMMON)
1065 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00001066 gfc_error ("Fortran 2008: COMMON block %qs with binding label at "
Tobias Burnus878cdb72013-05-20 22:03:48 +02001067 "%L sharing the identifier with global non-COMMON-block "
1068 "entity at %L", common_root->n.common->name,
1069 &common_root->n.common->where, &gsym->where);
1070 return;
1071 }
1072 if (!gsym)
1073 {
Thomas Koenig55b9c612019-03-13 07:21:33 +00001074 gsym = gfc_get_gsymbol (common_root->n.common->name, false);
Tobias Burnus878cdb72013-05-20 22:03:48 +02001075 gsym->type = GSYM_COMMON;
1076 gsym->where = common_root->n.common->where;
1077 gsym->defined = 1;
1078 }
1079 gsym->used = 1;
1080 }
1081
1082 if (common_root->n.common->binding_label)
1083 {
1084 gsym = gfc_find_gsymbol (gfc_gsym_root,
1085 common_root->n.common->binding_label);
1086 if (gsym && gsym->type != GSYM_COMMON)
1087 {
Dominique d'Humieres98452462017-12-10 20:11:18 +01001088 gfc_error ("COMMON block at %L with binding label %qs uses the same "
Tobias Burnus878cdb72013-05-20 22:03:48 +02001089 "global identifier as entity at %L",
1090 &common_root->n.common->where,
1091 common_root->n.common->binding_label, &gsym->where);
1092 return;
1093 }
1094 if (!gsym)
1095 {
Thomas Koenig55b9c612019-03-13 07:21:33 +00001096 gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true);
Tobias Burnus878cdb72013-05-20 22:03:48 +02001097 gsym->type = GSYM_COMMON;
1098 gsym->where = common_root->n.common->where;
1099 gsym->defined = 1;
1100 }
1101 gsym->used = 1;
1102 }
1103
Tobias Burnus041cf982007-08-26 20:29:45 +02001104 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
1105 if (sym == NULL)
1106 return;
Tobias Burnusad22b1f2007-07-03 23:41:34 +02001107
Tobias Burnus041cf982007-08-26 20:29:45 +02001108 if (sym->attr.flavor == FL_PARAMETER)
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00001109 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L",
Tobias Burnus041cf982007-08-26 20:29:45 +02001110 sym->name, &common_root->n.common->where, &sym->declared_at);
1111
Janus Weilef71fdd2011-09-26 22:05:43 +02001112 if (sym->attr.external)
Sandra Loosemore67914692019-01-09 16:37:45 -05001113 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute",
Janus Weilef71fdd2011-09-26 22:05:43 +02001114 sym->name, &common_root->n.common->where);
1115
Tobias Burnus041cf982007-08-26 20:29:45 +02001116 if (sym->attr.intrinsic)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001117 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
Tobias Burnus041cf982007-08-26 20:29:45 +02001118 sym->name, &common_root->n.common->where);
1119 else if (sym->attr.result
Janus Weil2d71b912009-11-26 20:01:02 +01001120 || gfc_is_function_return_value (sym, gfc_current_ns))
Tobias Burnusa4d9b222014-12-13 00:12:06 +01001121 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
Tobias Burnus041cf982007-08-26 20:29:45 +02001122 "that is also a function result", sym->name,
1123 &common_root->n.common->where);
1124 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
1125 && sym->attr.proc != PROC_ST_FUNCTION)
Tobias Burnusa4d9b222014-12-13 00:12:06 +01001126 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L "
Tobias Burnus041cf982007-08-26 20:29:45 +02001127 "that is also a global procedure", sym->name,
1128 &common_root->n.common->where);
Tobias Burnusad22b1f2007-07-03 23:41:34 +02001129}
1130
1131
Diego Novillo6de9cd92004-05-13 02:41:07 -04001132/* Resolve contained function types. Because contained functions can call one
1133 another, they have to be worked out before any of the contained procedures
1134 can be resolved.
1135
1136 The good news is that if a function doesn't already have a type, the only
1137 way it can get one is through an IMPLICIT type or a RESULT variable, because
1138 by definition contained functions are contained namespace they're contained
1139 in, not in a sibling or parent namespace. */
1140
1141static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001142resolve_contained_functions (gfc_namespace *ns)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001143{
Diego Novillo6de9cd92004-05-13 02:41:07 -04001144 gfc_namespace *child;
Paul Brook3d79abb2004-08-17 15:34:12 +00001145 gfc_entry_list *el;
Diego Novillo6de9cd92004-05-13 02:41:07 -04001146
1147 resolve_formal_arglists (ns);
1148
1149 for (child = ns->contained; child; child = child->sibling)
1150 {
Paul Brook3d79abb2004-08-17 15:34:12 +00001151 /* Resolve alternate entry points first. */
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02001152 resolve_entries (child);
Diego Novillo6de9cd92004-05-13 02:41:07 -04001153
Paul Brook3d79abb2004-08-17 15:34:12 +00001154 /* Then check function return types. */
1155 resolve_contained_fntype (child->proc_name, child);
1156 for (el = child->entries; el; el = el->next)
1157 resolve_contained_fntype (el->sym, child);
Diego Novillo6de9cd92004-05-13 02:41:07 -04001158 }
1159}
1160
1161
Paul Thomas5bab4c92017-09-09 11:10:42 +00001162
1163/* A Parameterized Derived Type constructor must contain values for
1164 the PDT KIND parameters or they must have a default initializer.
1165 Go through the constructor picking out the KIND expressions,
1166 storing them in 'param_list' and then call gfc_get_pdt_instance
1167 to obtain the PDT instance. */
1168
1169static gfc_actual_arglist *param_list, *param_tail, *param;
1170
1171static bool
1172get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
1173{
1174 param = gfc_get_actual_arglist ();
1175 if (!param_list)
1176 param_list = param_tail = param;
1177 else
1178 {
1179 param_tail->next = param;
1180 param_tail = param_tail->next;
1181 }
1182
1183 param_tail->name = c->name;
1184 if (expr)
1185 param_tail->expr = gfc_copy_expr (expr);
1186 else if (c->initializer)
1187 param_tail->expr = gfc_copy_expr (c->initializer);
1188 else
1189 {
1190 param_tail->spec_type = SPEC_ASSUMED;
1191 if (c->attr.pdt_kind)
1192 {
Paul Thomas2fcd5882017-10-07 21:14:06 +00001193 gfc_error ("The KIND parameter %qs in the PDT constructor "
1194 "at %C has no value", param->name);
Paul Thomas5bab4c92017-09-09 11:10:42 +00001195 return false;
1196 }
1197 }
1198
1199 return true;
1200}
1201
1202static bool
1203get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
1204 gfc_symbol *derived)
1205{
Paul Thomas276515e2017-12-01 15:05:55 +00001206 gfc_constructor *cons = NULL;
Paul Thomas5bab4c92017-09-09 11:10:42 +00001207 gfc_component *comp;
1208 bool t = true;
1209
1210 if (expr && expr->expr_type == EXPR_STRUCTURE)
1211 cons = gfc_constructor_first (expr->value.constructor);
1212 else if (constr)
1213 cons = *constr;
1214 gcc_assert (cons);
1215
1216 comp = derived->components;
1217
1218 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
1219 {
Paul Thomas2fcd5882017-10-07 21:14:06 +00001220 if (cons->expr
1221 && cons->expr->expr_type == EXPR_STRUCTURE
Paul Thomas5bab4c92017-09-09 11:10:42 +00001222 && comp->ts.type == BT_DERIVED)
1223 {
1224 t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
1225 if (!t)
1226 return t;
1227 }
1228 else if (comp->ts.type == BT_DERIVED)
1229 {
1230 t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived);
1231 if (!t)
1232 return t;
1233 }
1234 else if ((comp->attr.pdt_kind || comp->attr.pdt_len)
1235 && derived->attr.pdt_template)
1236 {
1237 t = get_pdt_spec_expr (comp, cons->expr);
1238 if (!t)
1239 return t;
1240 }
1241 }
1242 return t;
1243}
1244
1245
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001246static bool resolve_fl_derived0 (gfc_symbol *sym);
Fritz Reesef6288c22016-05-07 23:16:23 +00001247static bool resolve_fl_struct (gfc_symbol *sym);
Janus Weil0291fa22011-07-31 12:25:07 +02001248
1249
Diego Novillo6de9cd92004-05-13 02:41:07 -04001250/* Resolve all of the elements of a structure constructor and make sure that
Janus Weil80f95222010-08-19 00:32:22 +02001251 the types are correct. The 'init' flag indicates that the given
1252 constructor is an initializer. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04001253
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001254static bool
Janus Weil80f95222010-08-19 00:32:22 +02001255resolve_structure_cons (gfc_expr *expr, int init)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001256{
1257 gfc_constructor *cons;
1258 gfc_component *comp;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001259 bool t;
Paul Thomas5046aff2006-10-08 16:21:55 +00001260 symbol_attribute a;
Diego Novillo6de9cd92004-05-13 02:41:07 -04001261
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001262 t = true;
Janus Weilbd48f1232010-08-29 23:29:38 +02001263
Fritz Reesef6288c22016-05-07 23:16:23 +00001264 if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
1265 {
1266 if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
1267 resolve_fl_derived0 (expr->ts.u.derived);
1268 else
1269 resolve_fl_struct (expr->ts.u.derived);
Paul Thomas5bab4c92017-09-09 11:10:42 +00001270
1271 /* If this is a Parameterized Derived Type template, find the
1272 instance corresponding to the PDT kind parameters. */
1273 if (expr->ts.u.derived->attr.pdt_template)
1274 {
1275 param_list = NULL;
1276 t = get_pdt_constructor (expr, NULL, expr->ts.u.derived);
1277 if (!t)
1278 return t;
1279 gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL);
1280
1281 expr->param_list = gfc_copy_actual_arglist (param_list);
1282
1283 if (param_list)
1284 gfc_free_actual_arglist (param_list);
1285
1286 if (!expr->ts.u.derived->attr.pdt_type)
1287 return false;
1288 }
Fritz Reesef6288c22016-05-07 23:16:23 +00001289 }
Janus Weilbd48f1232010-08-29 23:29:38 +02001290
Tobias Burnusc3f34952011-11-16 22:37:43 +01001291 /* A constructor may have references if it is the result of substituting a
1292 parameter variable. In this case we just pull out the component we
1293 want. */
1294 if (expr->ref)
1295 comp = expr->ref->u.c.sym->components;
Harald Anlauf12463f12022-03-01 23:13:17 +01001296 else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS
1297 || expr->ts.type == BT_UNION)
1298 && expr->ts.u.derived)
Tobias Burnusc3f34952011-11-16 22:37:43 +01001299 comp = expr->ts.u.derived->components;
Harald Anlauf12463f12022-03-01 23:13:17 +01001300 else
1301 return false;
1302
1303 cons = gfc_constructor_first (expr->value.constructor);
Tobias Burnusc3f34952011-11-16 22:37:43 +01001304
Jerry DeLisleb7e75772010-04-13 01:59:35 +00001305 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
Diego Novillo6de9cd92004-05-13 02:41:07 -04001306 {
Francois-Xavier Coudert0df50e72007-11-21 18:32:40 +00001307 int rank;
1308
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001309 if (!cons->expr)
Paul Thomas404d8402006-10-04 04:48:35 +00001310 continue;
Diego Novillo6de9cd92004-05-13 02:41:07 -04001311
Fritz Reesef8da53e2016-10-27 17:21:46 +00001312 /* Unions use an EXPR_NULL contrived expression to tell the translation
1313 phase to generate an initializer of the appropriate length.
1314 Ignore it here. */
1315 if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
1316 continue;
1317
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001318 if (!gfc_resolve_expr (cons->expr))
Diego Novillo6de9cd92004-05-13 02:41:07 -04001319 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001320 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04001321 continue;
1322 }
1323
Francois-Xavier Coudert0df50e72007-11-21 18:32:40 +00001324 rank = comp->as ? comp->as->rank : 0;
Louis Krupp75a3c612018-01-16 01:09:11 +00001325 if (comp->ts.type == BT_CLASS
1326 && !comp->ts.u.derived->attr.unlimited_polymorphic
1327 && CLASS_DATA (comp)->as)
Paul Thomas3cd52c12015-02-05 08:02:58 +00001328 rank = CLASS_DATA (comp)->as->rank;
1329
Francois-Xavier Coudert0df50e72007-11-21 18:32:40 +00001330 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
Janus Weild4b7d0f2008-08-23 23:04:01 +02001331 && (comp->attr.allocatable || cons->expr->rank))
Paul Thomas5046aff2006-10-08 16:21:55 +00001332 {
Janus Weil6a38e152011-09-08 00:20:47 +02001333 gfc_error ("The rank of the element in the structure "
Paul Thomas5046aff2006-10-08 16:21:55 +00001334 "constructor at %L does not match that of the "
1335 "component (%d/%d)", &cons->expr->where,
Francois-Xavier Coudert0df50e72007-11-21 18:32:40 +00001336 cons->expr->rank, rank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001337 t = false;
Paul Thomas5046aff2006-10-08 16:21:55 +00001338 }
1339
Diego Novillo6de9cd92004-05-13 02:41:07 -04001340 /* If we don't have the right type, try to convert it. */
1341
Janus Weil80f95222010-08-19 00:32:22 +02001342 if (!comp->attr.proc_pointer &&
1343 !gfc_compare_types (&cons->expr->ts, &comp->ts))
Paul Thomase0e85e02005-12-22 07:05:22 +00001344 {
Janus Weilb04533a2010-11-09 11:39:46 +01001345 if (strcmp (comp->name, "_extends") == 0)
Paul Thomaseece1eb2010-04-29 19:10:48 +00001346 {
Janus Weilb04533a2010-11-09 11:39:46 +01001347 /* Can afford to be brutal with the _extends initializer.
Paul Thomaseece1eb2010-04-29 19:10:48 +00001348 The derived type can get lost because it is PRIVATE
1349 but it is not usage constrained by the standard. */
1350 cons->expr->ts = comp->ts;
Paul Thomaseece1eb2010-04-29 19:10:48 +00001351 }
1352 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
Tobias Burnuse35e87d2013-01-07 19:30:11 +01001353 {
1354 gfc_error ("The element in the structure constructor at %L, "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001355 "for pointer component %qs, is %s but should be %s",
Tobias Burnuse35e87d2013-01-07 19:30:11 +01001356 &cons->expr->where, comp->name,
1357 gfc_basic_typename (cons->expr->ts.type),
1358 gfc_basic_typename (comp->ts.type));
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001359 t = false;
Tobias Burnuse35e87d2013-01-07 19:30:11 +01001360 }
Paul Thomase0e85e02005-12-22 07:05:22 +00001361 else
Tobias Burnuse35e87d2013-01-07 19:30:11 +01001362 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001363 bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1);
1364 if (t)
Tobias Burnuse35e87d2013-01-07 19:30:11 +01001365 t = t2;
1366 }
Paul Thomase0e85e02005-12-22 07:05:22 +00001367 }
Paul Thomas5046aff2006-10-08 16:21:55 +00001368
Tobias Burnusa48a9172010-08-04 13:51:32 +02001369 /* For strings, the length of the constructor should be the same as
1370 the one of the structure, ensure this if the lengths are known at
1371 compile time and when we are dealing with PARAMETER or structure
1372 constructors. */
1373 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
1374 && comp->ts.u.cl->length
1375 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
1376 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
1377 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1378 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
1379 comp->ts.u.cl->length->value.integer) != 0)
1380 {
Harald Anlauf0712f352022-03-27 21:35:15 +02001381 if (comp->attr.pointer)
1382 {
1383 HOST_WIDE_INT la, lb;
1384 la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
1385 lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
1386 gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
1387 "component %qs in constructor at %L",
1388 la, lb, comp->name, &cons->expr->where);
1389 t = false;
1390 }
1391
Tobias Burnusa48a9172010-08-04 13:51:32 +02001392 if (cons->expr->expr_type == EXPR_VARIABLE
Harald Anlauf0712f352022-03-27 21:35:15 +02001393 && cons->expr->rank != 0
Tobias Burnusa48a9172010-08-04 13:51:32 +02001394 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
1395 {
1396 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1397 to make use of the gfc_resolve_character_array_constructor
1398 machinery. The expression is later simplified away to
1399 an array of string literals. */
1400 gfc_expr *para = cons->expr;
1401 cons->expr = gfc_get_expr ();
1402 cons->expr->ts = para->ts;
1403 cons->expr->where = para->where;
1404 cons->expr->expr_type = EXPR_ARRAY;
1405 cons->expr->rank = para->rank;
1406 cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
1407 gfc_constructor_append_expr (&cons->expr->value.constructor,
1408 para, &cons->expr->where);
1409 }
Paul Thomasc3879be2016-12-10 18:35:47 +00001410
Tobias Burnusa48a9172010-08-04 13:51:32 +02001411 if (cons->expr->expr_type == EXPR_ARRAY)
1412 {
Paul Thomasc3879be2016-12-10 18:35:47 +00001413 /* Rely on the cleanup of the namespace to deal correctly with
1414 the old charlen. (There was a block here that attempted to
1415 remove the charlen but broke the chain in so doing.) */
Tobias Burnusc130efd2010-08-04 20:49:23 +02001416 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
Tobias Burnusa48a9172010-08-04 13:51:32 +02001417 cons->expr->ts.u.cl->length_from_typespec = true;
1418 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
1419 gfc_resolve_character_array_constructor (cons->expr);
1420 }
1421 }
1422
Paul Thomasc1203a72008-03-24 19:11:24 +00001423 if (cons->expr->expr_type == EXPR_NULL
Janus Weil713485c2009-05-06 23:17:16 +02001424 && !(comp->attr.pointer || comp->attr.allocatable
Tobias Burnuscadddfd2013-03-25 16:40:26 +01001425 || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02001426 || (comp->ts.type == BT_CLASS
Janus Weild40477b2010-07-11 09:55:11 +02001427 && (CLASS_DATA (comp)->attr.class_pointer
Janus Weil7a08eda12010-05-30 23:56:11 +02001428 || CLASS_DATA (comp)->attr.allocatable))))
Paul Thomasc1203a72008-03-24 19:11:24 +00001429 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001430 t = false;
Janus Weil6a38e152011-09-08 00:20:47 +02001431 gfc_error ("The NULL in the structure constructor at %L is "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001432 "being applied to component %qs, which is neither "
Paul Thomasc1203a72008-03-24 19:11:24 +00001433 "a POINTER nor ALLOCATABLE", &cons->expr->where,
1434 comp->name);
1435 }
1436
Janus Weil6a38e152011-09-08 00:20:47 +02001437 if (comp->attr.proc_pointer && comp->ts.interface)
1438 {
1439 /* Check procedure pointer interface. */
1440 gfc_symbol *s2 = NULL;
1441 gfc_component *c2;
1442 const char *name;
1443 char err[200];
1444
Mikael Morin2a573572012-08-14 16:28:29 +00001445 c2 = gfc_get_proc_ptr_comp (cons->expr);
1446 if (c2)
Janus Weil6a38e152011-09-08 00:20:47 +02001447 {
1448 s2 = c2->ts.interface;
1449 name = c2->name;
1450 }
1451 else if (cons->expr->expr_type == EXPR_FUNCTION)
1452 {
1453 s2 = cons->expr->symtree->n.sym->result;
1454 name = cons->expr->symtree->n.sym->result->name;
1455 }
1456 else if (cons->expr->expr_type != EXPR_NULL)
1457 {
1458 s2 = cons->expr->symtree->n.sym;
1459 name = cons->expr->symtree->n.sym->name;
1460 }
1461
1462 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
Janus Weil6f3ab302012-06-22 23:05:51 +02001463 err, sizeof (err), NULL, NULL))
Janus Weil6a38e152011-09-08 00:20:47 +02001464 {
Thomas Koenige0b9e5f2019-09-14 20:40:55 +00001465 gfc_error_opt (0, "Interface mismatch for procedure-pointer "
Jakub Jelinek2700d0e2016-12-27 16:17:19 +01001466 "component %qs in structure constructor at %L:"
1467 " %s", comp->name, &cons->expr->where, err);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001468 return false;
Janus Weil6a38e152011-09-08 00:20:47 +02001469 }
1470 }
1471
Harald Anlauf1e819bd2021-10-15 21:23:17 +02001472 /* Validate shape, except for dynamic or PDT arrays. */
1473 if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank
1474 && comp->as && !comp->attr.allocatable && !comp->attr.pointer
1475 && !comp->attr.pdt_array)
1476 {
1477 mpz_t len;
1478 mpz_init (len);
1479 for (int n = 0; n < rank; n++)
1480 {
Harald Anlauf99af0b22021-10-26 20:51:46 +02001481 if (comp->as->upper[n]->expr_type != EXPR_CONSTANT
1482 || comp->as->lower[n]->expr_type != EXPR_CONSTANT)
1483 {
1484 gfc_error ("Bad array spec of component %qs referenced in "
1485 "structure constructor at %L",
1486 comp->name, &cons->expr->where);
1487 t = false;
1488 break;
1489 };
Harald Anlaufbc66b472022-02-21 22:49:05 +01001490 if (cons->expr->shape == NULL)
1491 continue;
Harald Anlauf1e819bd2021-10-15 21:23:17 +02001492 mpz_set_ui (len, 1);
1493 mpz_add (len, len, comp->as->upper[n]->value.integer);
1494 mpz_sub (len, len, comp->as->lower[n]->value.integer);
1495 if (mpz_cmp (cons->expr->shape[n], len) != 0)
1496 {
1497 gfc_error ("The shape of component %qs in the structure "
1498 "constructor at %L differs from the shape of the "
1499 "declared component for dimension %d (%ld/%ld)",
1500 comp->name, &cons->expr->where, n+1,
1501 mpz_get_si (cons->expr->shape[n]),
1502 mpz_get_si (len));
1503 t = false;
1504 }
1505 }
1506 mpz_clear (len);
1507 }
1508
Janus Weile8cd3982010-08-30 23:56:28 +02001509 if (!comp->attr.pointer || comp->attr.proc_pointer
1510 || cons->expr->expr_type == EXPR_NULL)
Paul Thomas5046aff2006-10-08 16:21:55 +00001511 continue;
1512
1513 a = gfc_expr_attr (cons->expr);
1514
1515 if (!a.pointer && !a.target)
1516 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001517 t = false;
Janus Weil6a38e152011-09-08 00:20:47 +02001518 gfc_error ("The element in the structure constructor at %L, "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001519 "for pointer component %qs should be a POINTER or "
Paul Thomas5046aff2006-10-08 16:21:55 +00001520 "a TARGET", &cons->expr->where, comp->name);
1521 }
Tobias Burnus4eceddd2010-03-14 14:18:28 +01001522
Janus Weil80f95222010-08-19 00:32:22 +02001523 if (init)
1524 {
1525 /* F08:C461. Additional checks for pointer initialization. */
1526 if (a.allocatable)
1527 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001528 t = false;
Janus Weil80f95222010-08-19 00:32:22 +02001529 gfc_error ("Pointer initialization target at %L "
Dominique d'Humieres2f029c02017-03-22 17:29:30 +01001530 "must not be ALLOCATABLE", &cons->expr->where);
Janus Weil80f95222010-08-19 00:32:22 +02001531 }
1532 if (!a.save)
1533 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001534 t = false;
Janus Weil80f95222010-08-19 00:32:22 +02001535 gfc_error ("Pointer initialization target at %L "
1536 "must have the SAVE attribute", &cons->expr->where);
1537 }
1538 }
1539
Tobias Burnus4eceddd2010-03-14 14:18:28 +01001540 /* F2003, C1272 (3). */
Tobias Burnusccd77512014-03-19 22:03:14 +01001541 bool impure = cons->expr->expr_type == EXPR_VARIABLE
1542 && (gfc_impure_variable (cons->expr->symtree->n.sym)
1543 || gfc_is_coindexed (cons->expr));
1544 if (impure && gfc_pure (NULL))
Tobias Burnus4eceddd2010-03-14 14:18:28 +01001545 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001546 t = false;
Janus Weil6a38e152011-09-08 00:20:47 +02001547 gfc_error ("Invalid expression in the structure constructor for "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001548 "pointer component %qs at %L in PURE procedure",
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02001549 comp->name, &cons->expr->where);
Tobias Burnus4eceddd2010-03-14 14:18:28 +01001550 }
Janus Weil80f95222010-08-19 00:32:22 +02001551
Tobias Burnusccd77512014-03-19 22:03:14 +01001552 if (impure)
1553 gfc_unset_implicit_pure (NULL);
Diego Novillo6de9cd92004-05-13 02:41:07 -04001554 }
1555
1556 return t;
1557}
1558
1559
Diego Novillo6de9cd92004-05-13 02:41:07 -04001560/****************** Expression name resolution ******************/
1561
1562/* Returns 0 if a symbol was not declared with a type or
Tobias Schlüter4f613942004-08-13 17:24:09 +00001563 attribute declaration statement, nonzero otherwise. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04001564
1565static int
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001566was_declared (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001567{
1568 symbol_attribute a;
1569
1570 a = sym->attr;
1571
1572 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
1573 return 1;
1574
Tobias Schlüter9439ae42005-03-19 20:45:45 +01001575 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001576 || a.optional || a.pointer || a.save || a.target || a.volatile_
Tobias Burnus1eee5622010-01-08 10:23:26 +01001577 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
Tobias Burnusbe59db22010-04-06 20:16:13 +02001578 || a.asynchronous || a.codimension)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001579 return 1;
1580
1581 return 0;
1582}
1583
1584
1585/* Determine if a symbol is generic or not. */
1586
1587static int
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001588generic_sym (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001589{
1590 gfc_symbol *s;
1591
1592 if (sym->attr.generic ||
1593 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
1594 return 1;
1595
1596 if (was_declared (sym) || sym->ns->parent == NULL)
1597 return 0;
1598
1599 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00001600
Jerry DeLisle6d023ec2007-07-28 21:17:20 +00001601 if (s != NULL)
1602 {
1603 if (s == sym)
1604 return 0;
1605 else
1606 return generic_sym (s);
1607 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04001608
Jerry DeLisle6d023ec2007-07-28 21:17:20 +00001609 return 0;
Diego Novillo6de9cd92004-05-13 02:41:07 -04001610}
1611
1612
1613/* Determine if a symbol is specific or not. */
1614
1615static int
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001616specific_sym (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001617{
1618 gfc_symbol *s;
1619
1620 if (sym->attr.if_source == IFSRC_IFBODY
1621 || sym->attr.proc == PROC_MODULE
1622 || sym->attr.proc == PROC_INTERNAL
1623 || sym->attr.proc == PROC_ST_FUNCTION
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001624 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
Diego Novillo6de9cd92004-05-13 02:41:07 -04001625 || sym->attr.external)
1626 return 1;
1627
1628 if (was_declared (sym) || sym->ns->parent == NULL)
1629 return 0;
1630
1631 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
1632
1633 return (s == NULL) ? 0 : specific_sym (s);
1634}
1635
1636
1637/* Figure out if the procedure is specific, generic or unknown. */
1638
Trevor Saundersa79683d2015-08-19 02:48:48 +00001639enum proc_type
1640{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN };
Diego Novillo6de9cd92004-05-13 02:41:07 -04001641
1642static proc_type
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001643procedure_kind (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001644{
Diego Novillo6de9cd92004-05-13 02:41:07 -04001645 if (generic_sym (sym))
1646 return PTYPE_GENERIC;
1647
1648 if (specific_sym (sym))
1649 return PTYPE_SPECIFIC;
1650
1651 return PTYPE_UNKNOWN;
1652}
1653
Paul Thomas48474142006-01-07 14:14:08 +00001654/* Check references to assumed size arrays. The flag need_full_assumed_size
Kazu Hiratab82feea2006-04-08 14:31:12 +00001655 is nonzero when matching actual arguments. */
Paul Thomas48474142006-01-07 14:14:08 +00001656
1657static int need_full_assumed_size = 0;
1658
1659static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001660check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
Paul Thomas48474142006-01-07 14:14:08 +00001661{
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001662 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
Paul Thomas48474142006-01-07 14:14:08 +00001663 return false;
1664
Ian Lance Taylore0c68ce2008-09-04 17:32:38 +00001665 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1666 What should it be? */
Janus Weil582f2172013-05-30 12:19:16 +02001667 if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
Paul Thomasc52938e2008-03-16 19:14:17 +00001668 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
Ian Lance Taylore0c68ce2008-09-04 17:32:38 +00001669 && (e->ref->u.ar.type == AR_FULL))
Paul Thomas48474142006-01-07 14:14:08 +00001670 {
1671 gfc_error ("The upper bound in the last dimension must "
1672 "appear in the reference to the assumed size "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001673 "array %qs at %L", sym->name, &e->where);
Paul Thomas48474142006-01-07 14:14:08 +00001674 return true;
1675 }
1676 return false;
1677}
1678
1679
1680/* Look for bad assumed size array references in argument expressions
1681 of elemental and array valued intrinsic procedures. Since this is
1682 called from procedure resolution functions, it only recurses at
1683 operators. */
1684
1685static bool
1686resolve_assumed_size_actual (gfc_expr *e)
1687{
1688 if (e == NULL)
1689 return false;
1690
1691 switch (e->expr_type)
1692 {
1693 case EXPR_VARIABLE:
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001694 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
Paul Thomas48474142006-01-07 14:14:08 +00001695 return true;
1696 break;
1697
1698 case EXPR_OP:
1699 if (resolve_assumed_size_actual (e->value.op.op1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001700 || resolve_assumed_size_actual (e->value.op.op2))
Paul Thomas48474142006-01-07 14:14:08 +00001701 return true;
1702 break;
1703
1704 default:
1705 break;
1706 }
1707 return false;
1708}
1709
Diego Novillo6de9cd92004-05-13 02:41:07 -04001710
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001711/* Check a generic procedure, passed as an actual argument, to see if
1712 there is a matching specific name. If none, it is an error, and if
1713 more than one, the reference is ambiguous. */
1714static int
1715count_specific_procs (gfc_expr *e)
1716{
1717 int n;
1718 gfc_interface *p;
1719 gfc_symbol *sym;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00001720
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001721 n = 0;
1722 sym = e->symtree->n.sym;
1723
1724 for (p = sym->generic; p; p = p->next)
1725 if (strcmp (sym->name, p->sym->name) == 0)
1726 {
1727 e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
1728 sym->name);
1729 n++;
1730 }
1731
1732 if (n > 1)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001733 gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001734 &e->where);
1735
1736 if (n == 0)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001737 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001738 "argument at %L", sym->name, &e->where);
1739
1740 return n;
1741}
1742
Daniel Krafta03826d2008-11-24 14:10:37 +01001743
Daniel Kraft1933ba02008-11-30 21:36:10 +01001744/* See if a call to sym could possibly be a not allowed RECURSION because of
Tobias Burnuseea58ad2012-05-30 08:26:09 +02001745 a missing RECURSIVE declaration. This means that either sym is the current
Daniel Kraft1933ba02008-11-30 21:36:10 +01001746 context itself, or sym is the parent of a contained procedure calling its
1747 non-RECURSIVE containing procedure.
1748 This also works if sym is an ENTRY. */
1749
1750static bool
1751is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
1752{
1753 gfc_symbol* proc_sym;
1754 gfc_symbol* context_proc;
Daniel Kraft9abe5e52009-09-29 09:42:42 +02001755 gfc_namespace* real_context;
Daniel Kraft1933ba02008-11-30 21:36:10 +01001756
Tobias Burnusc3f34952011-11-16 22:37:43 +01001757 if (sym->attr.flavor == FL_PROGRAM
Fritz Reesef6288c22016-05-07 23:16:23 +00001758 || gfc_fl_struct (sym->attr.flavor))
Jerry DeLisle6f7e06c2009-11-07 02:30:08 +00001759 return false;
1760
Daniel Kraft1933ba02008-11-30 21:36:10 +01001761 /* If we've got an ENTRY, find real procedure. */
1762 if (sym->attr.entry && sym->ns->entries)
1763 proc_sym = sym->ns->entries->sym;
1764 else
1765 proc_sym = sym;
1766
1767 /* If sym is RECURSIVE, all is well of course. */
Tobias Burnusc61819f2014-12-16 21:44:45 +01001768 if (proc_sym->attr.recursive || flag_recursive)
Daniel Kraft1933ba02008-11-30 21:36:10 +01001769 return false;
1770
Daniel Kraft9abe5e52009-09-29 09:42:42 +02001771 /* Find the context procedure's "real" symbol if it has entries.
1772 We look for a procedure symbol, so recurse on the parents if we don't
1773 find one (like in case of a BLOCK construct). */
1774 for (real_context = context; ; real_context = real_context->parent)
1775 {
1776 /* We should find something, eventually! */
1777 gcc_assert (real_context);
1778
1779 context_proc = (real_context->entries ? real_context->entries->sym
1780 : real_context->proc_name);
1781
1782 /* In some special cases, there may not be a proc_name, like for this
1783 invalid code:
1784 real(bad_kind()) function foo () ...
1785 when checking the call to bad_kind ().
1786 In these cases, we simply return here and assume that the
1787 call is ok. */
1788 if (!context_proc)
1789 return false;
1790
1791 if (context_proc->attr.flavor != FL_LABEL)
1792 break;
1793 }
Daniel Kraft1933ba02008-11-30 21:36:10 +01001794
1795 /* A call from sym's body to itself is recursion, of course. */
1796 if (context_proc == proc_sym)
1797 return true;
1798
1799 /* The same is true if context is a contained procedure and sym the
1800 containing one. */
1801 if (context_proc->attr.contained)
1802 {
1803 gfc_symbol* parent_proc;
1804
1805 gcc_assert (context->parent);
1806 parent_proc = (context->parent->entries ? context->parent->entries->sym
1807 : context->parent->proc_name);
1808
1809 if (parent_proc == proc_sym)
1810 return true;
1811 }
1812
1813 return false;
1814}
1815
1816
Janus Weilc73b6472009-04-22 11:05:58 +02001817/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1818 its typespec and formal argument list. */
1819
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001820bool
Janus Weil2dda89a2012-07-30 21:55:41 +02001821gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
Janus Weilc73b6472009-04-22 11:05:58 +02001822{
Tobias Burnusd000aa62010-09-27 00:30:48 +02001823 gfc_intrinsic_sym* isym = NULL;
Janus Weilf6038132009-08-13 13:16:16 +02001824 const char* symstd;
1825
Mark Egglestondbeaa7a2020-04-23 10:33:14 +01001826 if (sym->resolve_symbol_called >= 2)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001827 return true;
Janus Weilf6038132009-08-13 13:16:16 +02001828
Mark Egglestondbeaa7a2020-04-23 10:33:14 +01001829 sym->resolve_symbol_called = 2;
1830
Tobias Burnus13157032011-05-12 19:40:29 +02001831 /* Already resolved. */
1832 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001833 return true;
Tobias Burnus13157032011-05-12 19:40:29 +02001834
Janus Weilf6038132009-08-13 13:16:16 +02001835 /* We already know this one is an intrinsic, so we don't call
1836 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1837 gfc_find_subroutine directly to check whether it is a function or
1838 subroutine. */
1839
Tobias Burnuscadddfd2013-03-25 16:40:26 +01001840 if (sym->intmod_sym_id && sym->attr.subroutine)
1841 {
1842 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1843 isym = gfc_intrinsic_subroutine_by_id (id);
1844 }
1845 else if (sym->intmod_sym_id)
1846 {
1847 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym);
1848 isym = gfc_intrinsic_function_by_id (id);
1849 }
Tobias Burnus2b91eb32012-03-02 12:00:04 +01001850 else if (!sym->attr.subroutine)
Tobias Burnusd000aa62010-09-27 00:30:48 +02001851 isym = gfc_find_function (sym->name);
1852
Tobias Burnuscadddfd2013-03-25 16:40:26 +01001853 if (isym && !sym->attr.subroutine)
Janus Weilc73b6472009-04-22 11:05:58 +02001854 {
Tobias Burnus73e42ee2014-11-30 09:33:25 +01001855 if (sym->ts.type != BT_UNKNOWN && warn_surprising
Janus Weilf6038132009-08-13 13:16:16 +02001856 && !sym->attr.implicit_type)
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +00001857 gfc_warning (OPT_Wsurprising,
1858 "Type specified for intrinsic function %qs at %L is"
Janus Weilf6038132009-08-13 13:16:16 +02001859 " ignored", sym->name, &sym->declared_at);
1860
Janus Weilc73b6472009-04-22 11:05:58 +02001861 if (!sym->attr.function &&
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001862 !gfc_add_function(&sym->attr, sym->name, loc))
1863 return false;
Janus Weilf6038132009-08-13 13:16:16 +02001864
Janus Weilc73b6472009-04-22 11:05:58 +02001865 sym->ts = isym->ts;
1866 }
Tobias Burnuscadddfd2013-03-25 16:40:26 +01001867 else if (isym || (isym = gfc_find_subroutine (sym->name)))
Janus Weilc73b6472009-04-22 11:05:58 +02001868 {
Janus Weilf6038132009-08-13 13:16:16 +02001869 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
1870 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001871 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
Janus Weilf6038132009-08-13 13:16:16 +02001872 " specifier", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001873 return false;
Janus Weilf6038132009-08-13 13:16:16 +02001874 }
1875
Janus Weilc73b6472009-04-22 11:05:58 +02001876 if (!sym->attr.subroutine &&
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001877 !gfc_add_subroutine(&sym->attr, sym->name, loc))
1878 return false;
Janus Weilc73b6472009-04-22 11:05:58 +02001879 }
Janus Weilf6038132009-08-13 13:16:16 +02001880 else
1881 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00001882 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
Janus Weilf6038132009-08-13 13:16:16 +02001883 &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001884 return false;
Janus Weilf6038132009-08-13 13:16:16 +02001885 }
1886
Tobias Burnus8fdcb6a2014-06-12 20:35:00 +02001887 gfc_copy_formal_args_intr (sym, isym, NULL);
Janus Weilf6038132009-08-13 13:16:16 +02001888
Tobias Burnus019c0e52013-12-08 22:34:18 +01001889 sym->attr.pure = isym->pure;
1890 sym->attr.elemental = isym->elemental;
1891
Janus Weilf6038132009-08-13 13:16:16 +02001892 /* Check it is actually available in the standard settings. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001893 if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
Janus Weilf6038132009-08-13 13:16:16 +02001894 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +01001895 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1896 "available in the current standard settings but %s. Use "
1897 "an appropriate %<-std=*%> option or enable "
1898 "%<-fall-intrinsics%> in order to use it.",
Janus Weilf6038132009-08-13 13:16:16 +02001899 sym->name, &sym->declared_at, symstd);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001900 return false;
Janus Weilf6038132009-08-13 13:16:16 +02001901 }
1902
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001903 return true;
Janus Weilc73b6472009-04-22 11:05:58 +02001904}
1905
1906
Daniel Krafta03826d2008-11-24 14:10:37 +01001907/* Resolve a procedure expression, like passing it to a called procedure or as
1908 RHS for a procedure pointer assignment. */
1909
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001910static bool
Daniel Krafta03826d2008-11-24 14:10:37 +01001911resolve_procedure_expression (gfc_expr* expr)
1912{
1913 gfc_symbol* sym;
1914
Daniel Kraft1933ba02008-11-30 21:36:10 +01001915 if (expr->expr_type != EXPR_VARIABLE)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001916 return true;
Daniel Krafta03826d2008-11-24 14:10:37 +01001917 gcc_assert (expr->symtree);
Daniel Kraft1933ba02008-11-30 21:36:10 +01001918
Daniel Krafta03826d2008-11-24 14:10:37 +01001919 sym = expr->symtree->n.sym;
Janus Weilc73b6472009-04-22 11:05:58 +02001920
1921 if (sym->attr.intrinsic)
Janus Weil2dda89a2012-07-30 21:55:41 +02001922 gfc_resolve_intrinsic (sym, &expr->where);
Janus Weilc73b6472009-04-22 11:05:58 +02001923
Daniel Kraft1933ba02008-11-30 21:36:10 +01001924 if (sym->attr.flavor != FL_PROCEDURE
1925 || (sym->attr.function && sym->result == sym))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001926 return true;
Daniel Krafta03826d2008-11-24 14:10:37 +01001927
1928 /* A non-RECURSIVE procedure that is used as procedure expression within its
1929 own body is in danger of being called recursively. */
Daniel Kraft1933ba02008-11-30 21:36:10 +01001930 if (is_illegal_recursion (sym, gfc_current_ns))
Joseph Myersdb30e212015-02-01 00:29:54 +00001931 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
Daniel Krafta03826d2008-11-24 14:10:37 +01001932 " itself recursively. Declare it RECURSIVE or use"
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +00001933 " %<-frecursive%>", sym->name, &expr->where);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00001934
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001935 return true;
Daniel Krafta03826d2008-11-24 14:10:37 +01001936}
1937
1938
Steven G. Karglb00802f2019-06-13 18:40:19 +00001939/* Check that name is not a derived type. */
Paul Thomas70570ec2019-09-01 12:53:02 +00001940
Steven G. Karglb00802f2019-06-13 18:40:19 +00001941static bool
1942is_dt_name (const char *name)
1943{
1944 gfc_symbol *dt_list, *dt_first;
1945
1946 dt_list = dt_first = gfc_derived_types;
1947 for (; dt_list; dt_list = dt_list->dt_next)
1948 {
1949 if (strcmp(dt_list->name, name) == 0)
1950 return true;
1951 if (dt_first == dt_list->dt_next)
1952 break;
1953 }
1954 return false;
1955}
1956
1957
Diego Novillo6de9cd92004-05-13 02:41:07 -04001958/* Resolve an actual argument list. Most of the time, this is just
1959 resolving the expressions in the list.
1960 The exception is that we sometimes have to decide whether arguments
1961 that look like procedure arguments are really simple variable
1962 references. */
1963
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001964static bool
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001965resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
1966 bool no_formal_args)
Diego Novillo6de9cd92004-05-13 02:41:07 -04001967{
1968 gfc_symbol *sym;
1969 gfc_symtree *parent_st;
1970 gfc_expr *e;
Janus Weild06790a2014-12-15 17:10:50 +01001971 gfc_component *comp;
Tobias Burnus5ad63452008-01-13 22:35:33 +01001972 int save_need_full_assumed_size;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03001973 bool return_value = false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02001974 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02001975
Tobias Burnusc62c6622012-07-20 07:56:37 +02001976 actual_arg = true;
1977 first_actual_arg = true;
Tobias Burnus45a69322012-03-03 09:40:24 +01001978
Diego Novillo6de9cd92004-05-13 02:41:07 -04001979 for (; arg; arg = arg->next)
1980 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04001981 e = arg->expr;
1982 if (e == NULL)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001983 {
1984 /* Check the label is a valid branching target. */
1985 if (arg->label)
1986 {
1987 if (arg->label->defined == ST_LABEL_UNKNOWN)
1988 {
1989 gfc_error ("Label %d referenced at %L is never defined",
1990 arg->label->value, &arg->label->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02001991 goto cleanup;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001992 }
1993 }
Tobias Burnusc62c6622012-07-20 07:56:37 +02001994 first_actual_arg = false;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00001995 continue;
1996 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04001997
Paul Thomas67cec812008-11-03 06:44:47 +00001998 if (e->expr_type == EXPR_VARIABLE
Paul Thomas0b4e2af2008-09-17 22:23:51 +00001999 && e->symtree->n.sym->attr.generic
2000 && no_formal_args
2001 && count_specific_procs (e) != 1)
Tobias Burnusc62c6622012-07-20 07:56:37 +02002002 goto cleanup;
Paul Thomas27372c32007-10-12 16:51:53 +00002003
Diego Novillo6de9cd92004-05-13 02:41:07 -04002004 if (e->ts.type != BT_PROCEDURE)
2005 {
Tobias Burnus5ad63452008-01-13 22:35:33 +01002006 save_need_full_assumed_size = need_full_assumed_size;
Ian Lance Taylore0c68ce2008-09-04 17:32:38 +00002007 if (e->expr_type != EXPR_VARIABLE)
Tobias Burnus5ad63452008-01-13 22:35:33 +01002008 need_full_assumed_size = 0;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002009 if (!gfc_resolve_expr (e))
Tobias Burnusc62c6622012-07-20 07:56:37 +02002010 goto cleanup;
Tobias Burnus5ad63452008-01-13 22:35:33 +01002011 need_full_assumed_size = save_need_full_assumed_size;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002012 goto argument_list;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002013 }
2014
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002015 /* See if the expression node should really be a variable reference. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04002016
2017 sym = e->symtree->n.sym;
2018
Steven G. Karglb00802f2019-06-13 18:40:19 +00002019 if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name))
2020 {
2021 gfc_error ("Derived type %qs is used as an actual "
2022 "argument at %L", sym->name, &e->where);
2023 goto cleanup;
2024 }
2025
Diego Novillo6de9cd92004-05-13 02:41:07 -04002026 if (sym->attr.flavor == FL_PROCEDURE
2027 || sym->attr.intrinsic
2028 || sym->attr.external)
2029 {
François-Xavier Coudert0e7e7e62006-10-07 13:34:16 +00002030 int actual_ok;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002031
Paul Thomasd68bd5a2006-06-25 15:11:02 +00002032 /* If a procedure is not already determined to be something else
2033 check if it is intrinsic. */
Janus Weil0e8d8542012-07-31 20:32:41 +02002034 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
Paul Thomasd68bd5a2006-06-25 15:11:02 +00002035 sym->attr.intrinsic = 1;
2036
Paul Thomas2ed8d222006-02-13 21:22:55 +00002037 if (sym->attr.proc == PROC_ST_FUNCTION)
2038 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002039 gfc_error ("Statement function %qs at %L is not allowed as an "
Paul Thomas2ed8d222006-02-13 21:22:55 +00002040 "actual argument", sym->name, &e->where);
2041 }
2042
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002043 actual_ok = gfc_intrinsic_actual_ok (sym->name,
2044 sym->attr.subroutine);
François-Xavier Coudert0e7e7e62006-10-07 13:34:16 +00002045 if (sym->attr.intrinsic && actual_ok == 0)
2046 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002047 gfc_error ("Intrinsic %qs at %L is not allowed as an "
François-Xavier Coudert0e7e7e62006-10-07 13:34:16 +00002048 "actual argument", sym->name, &e->where);
2049 }
François-Xavier Coudert0e7e7e62006-10-07 13:34:16 +00002050
Paul Thomas2ed8d222006-02-13 21:22:55 +00002051 if (sym->attr.contained && !sym->attr.use_assoc
2052 && sym->ns->proc_name->attr.flavor != FL_MODULE)
2053 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +01002054 if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is"
Paul Thomas22c23882014-10-18 14:35:51 +00002055 " used as actual argument at %L",
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002056 sym->name, &e->where))
Tobias Burnusc62c6622012-07-20 07:56:37 +02002057 goto cleanup;
Paul Thomas2ed8d222006-02-13 21:22:55 +00002058 }
2059
2060 if (sym->attr.elemental && !sym->attr.intrinsic)
2061 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002062 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002063 "allowed as an actual argument at %L", sym->name,
Paul Thomas2ed8d222006-02-13 21:22:55 +00002064 &e->where);
2065 }
Francois-Xavier Coudert781e1002005-04-28 13:56:08 +02002066
Paul Thomas36d3fb42007-03-15 06:44:25 +00002067 /* Check if a generic interface has a specific procedure
2068 with the same name before emitting an error. */
Paul Thomas0b4e2af2008-09-17 22:23:51 +00002069 if (sym->attr.generic && count_specific_procs (e) != 1)
Tobias Burnusc62c6622012-07-20 07:56:37 +02002070 goto cleanup;
2071
Paul Thomas0b4e2af2008-09-17 22:23:51 +00002072 /* Just in case a specific was found for the expression. */
2073 sym = e->symtree->n.sym;
Paul Thomas3e978d32006-08-20 05:45:43 +00002074
Diego Novillo6de9cd92004-05-13 02:41:07 -04002075 /* If the symbol is the function that names the current (or
2076 parent) scope, then we really have a variable reference. */
2077
Janus Weil2d71b912009-11-26 20:01:02 +01002078 if (gfc_is_function_return_value (sym, sym->ns))
Diego Novillo6de9cd92004-05-13 02:41:07 -04002079 goto got_variable;
2080
Paul Thomas20a037d2006-12-31 07:51:47 +00002081 /* If all else fails, see if we have a specific intrinsic. */
Jerry DeLisle26033472007-10-31 14:26:57 +00002082 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
Paul Thomas20a037d2006-12-31 07:51:47 +00002083 {
2084 gfc_intrinsic_sym *isym;
Jerry DeLisle6cc309c2007-11-14 00:59:09 +00002085
Paul Thomas20a037d2006-12-31 07:51:47 +00002086 isym = gfc_find_function (sym->name);
2087 if (isym == NULL || !isym->specific)
2088 {
2089 gfc_error ("Unable to find a specific INTRINSIC procedure "
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002090 "for the reference %qs at %L", sym->name,
Paul Thomas20a037d2006-12-31 07:51:47 +00002091 &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002092 goto cleanup;
Paul Thomas20a037d2006-12-31 07:51:47 +00002093 }
2094 sym->ts = isym->ts;
Jerry DeLisle6cc309c2007-11-14 00:59:09 +00002095 sym->attr.intrinsic = 1;
Jerry DeLisle26033472007-10-31 14:26:57 +00002096 sym->attr.function = 1;
Paul Thomas20a037d2006-12-31 07:51:47 +00002097 }
Daniel Krafta03826d2008-11-24 14:10:37 +01002098
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002099 if (!gfc_resolve_expr (e))
Tobias Burnusc62c6622012-07-20 07:56:37 +02002100 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002101 goto argument_list;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002102 }
2103
2104 /* See if the name is a module procedure in a parent unit. */
2105
2106 if (was_declared (sym) || sym->ns->parent == NULL)
2107 goto got_variable;
2108
2109 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
2110 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002111 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002112 goto cleanup;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002113 }
2114
2115 if (parent_st == NULL)
2116 goto got_variable;
2117
2118 sym = parent_st->n.sym;
2119 e->symtree = parent_st; /* Point to the right thing. */
2120
2121 if (sym->attr.flavor == FL_PROCEDURE
2122 || sym->attr.intrinsic
2123 || sym->attr.external)
2124 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002125 if (!gfc_resolve_expr (e))
Tobias Burnusc62c6622012-07-20 07:56:37 +02002126 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002127 goto argument_list;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002128 }
2129
2130 got_variable:
2131 e->expr_type = EXPR_VARIABLE;
2132 e->ts = sym->ts;
Tobias Burnus102344e2012-01-27 14:08:52 +01002133 if ((sym->as != NULL && sym->ts.type != BT_CLASS)
2134 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2135 && CLASS_DATA (sym)->as))
Diego Novillo6de9cd92004-05-13 02:41:07 -04002136 {
Tobias Burnus102344e2012-01-27 14:08:52 +01002137 e->rank = sym->ts.type == BT_CLASS
2138 ? CLASS_DATA (sym)->as->rank : sym->as->rank;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002139 e->ref = gfc_get_ref ();
2140 e->ref->type = REF_ARRAY;
2141 e->ref->u.ar.type = AR_FULL;
Tobias Burnus102344e2012-01-27 14:08:52 +01002142 e->ref->u.ar.as = sym->ts.type == BT_CLASS
2143 ? CLASS_DATA (sym)->as : sym->as;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002144 }
Paul Thomas7fcafa72006-12-31 06:55:16 +00002145
Daniel Franke1b352642007-05-21 18:24:55 -04002146 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
Martin Liskae53b6e52022-01-14 16:57:02 +01002147 primary.cc (match_actual_arg). If above code determines that it
Daniel Franke1b352642007-05-21 18:24:55 -04002148 is a variable instead, it needs to be resolved as it was not
2149 done at the beginning of this function. */
Tobias Burnus5ad63452008-01-13 22:35:33 +01002150 save_need_full_assumed_size = need_full_assumed_size;
Ian Lance Taylore0c68ce2008-09-04 17:32:38 +00002151 if (e->expr_type != EXPR_VARIABLE)
Tobias Burnus5ad63452008-01-13 22:35:33 +01002152 need_full_assumed_size = 0;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002153 if (!gfc_resolve_expr (e))
Tobias Burnusc62c6622012-07-20 07:56:37 +02002154 goto cleanup;
Tobias Burnus5ad63452008-01-13 22:35:33 +01002155 need_full_assumed_size = save_need_full_assumed_size;
Daniel Franke1b352642007-05-21 18:24:55 -04002156
Paul Thomas7fcafa72006-12-31 06:55:16 +00002157 argument_list:
2158 /* Check argument list functions %VAL, %LOC and %REF. There is
2159 nothing to do for %REF. */
2160 if (arg->name && arg->name[0] == '%')
2161 {
Janus Weil2eb37452018-09-20 21:33:05 +02002162 if (strcmp ("%VAL", arg->name) == 0)
Paul Thomas7fcafa72006-12-31 06:55:16 +00002163 {
2164 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
2165 {
2166 gfc_error ("By-value argument at %L is not of numeric "
2167 "type", &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002168 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002169 }
2170
2171 if (e->rank)
2172 {
2173 gfc_error ("By-value argument at %L cannot be an array or "
2174 "an array section", &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002175 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002176 }
2177
2178 /* Intrinsics are still PROC_UNKNOWN here. However,
2179 since same file external procedures are not resolvable
2180 in gfortran, it is a good deal easier to leave them to
Martin Liskae53b6e52022-01-14 16:57:02 +01002181 intrinsic.cc. */
Tobias Burnus7193e302007-02-28 19:17:34 +01002182 if (ptype != PROC_UNKNOWN
2183 && ptype != PROC_DUMMY
Tobias Burnus29ea08d2007-04-25 10:32:21 +02002184 && ptype != PROC_EXTERNAL
2185 && ptype != PROC_MODULE)
Paul Thomas7fcafa72006-12-31 06:55:16 +00002186 {
2187 gfc_error ("By-value argument at %L is not allowed "
2188 "in this context", &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002189 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002190 }
Paul Thomas7fcafa72006-12-31 06:55:16 +00002191 }
2192
2193 /* Statement functions have already been excluded above. */
Janus Weil2eb37452018-09-20 21:33:05 +02002194 else if (strcmp ("%LOC", arg->name) == 0
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002195 && e->ts.type == BT_PROCEDURE)
Paul Thomas7fcafa72006-12-31 06:55:16 +00002196 {
2197 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
2198 {
2199 gfc_error ("Passing internal procedure at %L by location "
2200 "not allowed", &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002201 goto cleanup;
Paul Thomas7fcafa72006-12-31 06:55:16 +00002202 }
2203 }
2204 }
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02002205
Janus Weild06790a2014-12-15 17:10:50 +01002206 comp = gfc_get_proc_ptr_comp(e);
Mikael Morinbc0c7f32015-05-24 14:55:50 +00002207 if (e->expr_type == EXPR_VARIABLE
2208 && comp && comp->attr.elemental)
Janus Weild06790a2014-12-15 17:10:50 +01002209 {
2210 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
2211 "allowed as an actual argument at %L", comp->name,
2212 &e->where);
2213 }
2214
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02002215 /* Fortran 2008, C1237. */
2216 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
Tobias Burnusc62c6622012-07-20 07:56:37 +02002217 && gfc_has_ultimate_pointer (e))
2218 {
2219 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02002220 "component", &e->where);
Tobias Burnusc62c6622012-07-20 07:56:37 +02002221 goto cleanup;
2222 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04002223
Tobias Burnusc62c6622012-07-20 07:56:37 +02002224 first_actual_arg = false;
2225 }
2226
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002227 return_value = true;
Tobias Burnusc62c6622012-07-20 07:56:37 +02002228
2229cleanup:
2230 actual_arg = actual_arg_sav;
2231 first_actual_arg = first_actual_arg_sav;
2232
2233 return return_value;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002234}
2235
2236
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002237/* Do the checks of the actual argument list that are specific to elemental
2238 procedures. If called with c == NULL, we have a function, otherwise if
2239 expr == NULL, we have a subroutine. */
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002240
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002241static bool
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002242resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
2243{
2244 gfc_actual_arglist *arg0;
2245 gfc_actual_arglist *arg;
2246 gfc_symbol *esym = NULL;
2247 gfc_intrinsic_sym *isym = NULL;
2248 gfc_expr *e = NULL;
2249 gfc_intrinsic_arg *iformal = NULL;
2250 gfc_formal_arglist *eformal = NULL;
2251 bool formal_optional = false;
2252 bool set_by_optional = false;
2253 int i;
2254 int rank = 0;
2255
2256 /* Is this an elemental procedure? */
2257 if (expr && expr->value.function.actual != NULL)
2258 {
2259 if (expr->value.function.esym != NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002260 && expr->value.function.esym->attr.elemental)
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002261 {
2262 arg0 = expr->value.function.actual;
2263 esym = expr->value.function.esym;
2264 }
2265 else if (expr->value.function.isym != NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002266 && expr->value.function.isym->elemental)
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002267 {
2268 arg0 = expr->value.function.actual;
2269 isym = expr->value.function.isym;
2270 }
2271 else
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002272 return true;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002273 }
Daniel Kraftdd9315d2008-10-16 18:28:23 +02002274 else if (c && c->ext.actual != NULL)
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002275 {
2276 arg0 = c->ext.actual;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00002277
Daniel Kraftdd9315d2008-10-16 18:28:23 +02002278 if (c->resolved_sym)
2279 esym = c->resolved_sym;
2280 else
2281 esym = c->symtree->n.sym;
2282 gcc_assert (esym);
2283
2284 if (!esym->attr.elemental)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002285 return true;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002286 }
2287 else
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002288 return true;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002289
2290 /* The rank of an elemental is the rank of its array argument(s). */
2291 for (arg = arg0; arg; arg = arg->next)
2292 {
Tobias Burnusc62c6622012-07-20 07:56:37 +02002293 if (arg->expr != NULL && arg->expr->rank != 0)
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002294 {
2295 rank = arg->expr->rank;
2296 if (arg->expr->expr_type == EXPR_VARIABLE
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002297 && arg->expr->symtree->n.sym->attr.optional)
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002298 set_by_optional = true;
2299
2300 /* Function specific; set the result rank and shape. */
2301 if (expr)
2302 {
2303 expr->rank = rank;
2304 if (!expr->shape && arg->expr->shape)
2305 {
2306 expr->shape = gfc_get_shape (rank);
2307 for (i = 0; i < rank; i++)
2308 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
2309 }
2310 }
2311 break;
2312 }
2313 }
2314
2315 /* If it is an array, it shall not be supplied as an actual argument
2316 to an elemental procedure unless an array of the same rank is supplied
2317 as an actual argument corresponding to a nonoptional dummy argument of
2318 that elemental procedure(12.4.1.5). */
2319 formal_optional = false;
2320 if (isym)
2321 iformal = isym->formal;
2322 else
2323 eformal = esym->formal;
2324
2325 for (arg = arg0; arg; arg = arg->next)
2326 {
2327 if (eformal)
2328 {
2329 if (eformal->sym && eformal->sym->attr.optional)
2330 formal_optional = true;
2331 eformal = eformal->next;
2332 }
2333 else if (isym && iformal)
2334 {
2335 if (iformal->optional)
2336 formal_optional = true;
2337 iformal = iformal->next;
2338 }
2339 else if (isym)
2340 formal_optional = true;
2341
Steven G. Kargl994c1cc2006-08-06 01:38:46 +00002342 if (pedantic && arg->expr != NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002343 && arg->expr->expr_type == EXPR_VARIABLE
2344 && arg->expr->symtree->n.sym->attr.optional
2345 && formal_optional
2346 && arg->expr->rank
2347 && (set_by_optional || arg->expr->rank != rank)
Daniel Frankecd5ecab2007-05-29 17:10:48 -04002348 && !(isym && isym->id == GFC_ISYM_CONVERSION))
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002349 {
Mark Eggleston685d8da2020-06-01 14:56:00 +01002350 bool t = false;
2351 gfc_actual_arglist *a;
2352
2353 /* Scan the argument list for a non-optional argument with the
2354 same rank as arg. */
2355 for (a = arg0; a; a = a->next)
2356 if (a != arg
2357 && a->expr->rank == arg->expr->rank
2358 && !a->expr->symtree->n.sym->attr.optional)
2359 {
2360 t = true;
2361 break;
2362 }
2363
2364 if (!t)
2365 gfc_warning (OPT_Wpedantic,
2366 "%qs at %L is an array and OPTIONAL; If it is not "
2367 "present, then it cannot be the actual argument of "
2368 "an ELEMENTAL procedure unless there is a non-optional"
2369 " argument with the same rank "
2370 "(Fortran 2018, 15.5.2.12)",
2371 arg->expr->symtree->n.sym->name, &arg->expr->where);
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002372 }
2373 }
2374
2375 for (arg = arg0; arg; arg = arg->next)
2376 {
2377 if (arg->expr == NULL || arg->expr->rank == 0)
2378 continue;
2379
2380 /* Being elemental, the last upper bound of an assumed size array
2381 argument must be present. */
2382 if (resolve_assumed_size_actual (arg->expr))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002383 return false;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002384
Tobias Burnus3c7b91d2007-09-13 20:08:04 +02002385 /* Elemental procedure's array actual arguments must conform. */
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002386 if (e != NULL)
2387 {
Mark Eggleston0a7183f2020-06-02 08:38:01 +01002388 if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002389 return false;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002390 }
2391 else
2392 e = arg->expr;
2393 }
2394
Tobias Burnus4a965822007-09-18 08:34:30 +02002395 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2396 is an array, the intent inout/out variable needs to be also an array. */
2397 if (rank > 0 && esym && expr == NULL)
2398 for (eformal = esym->formal, arg = arg0; arg && eformal;
2399 arg = arg->next, eformal = eformal->next)
Harald Anlauf69db6e72022-03-29 22:12:15 +02002400 if (eformal->sym
2401 && (eformal->sym->attr.intent == INTENT_OUT
2402 || eformal->sym->attr.intent == INTENT_INOUT)
Tobias Burnus4a965822007-09-18 08:34:30 +02002403 && arg->expr && arg->expr->rank == 0)
2404 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002405 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2406 "ELEMENTAL subroutine %qs is a scalar, but another "
Tobias Burnus4a965822007-09-18 08:34:30 +02002407 "actual argument is an array", &arg->expr->where,
2408 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
2409 : "INOUT", eformal->sym->name, esym->name);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002410 return false;
Tobias Burnus4a965822007-09-18 08:34:30 +02002411 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002412 return true;
Paul Thomasb8ea6db2006-07-16 15:01:59 +00002413}
2414
2415
Paul Thomas68ea3552006-01-21 09:08:54 +00002416/* This function does the checking of references to global procedures
2417 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2418 77 and 95 standards. It checks for a gsymbol for the name, making
2419 one if it does not already exist. If it already exists, then the
2420 reference being resolved must correspond to the type of gsymbol.
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02002421 Otherwise, the new symbol is equipped with the attributes of the
Paul Thomas68ea3552006-01-21 09:08:54 +00002422 reference. The corresponding code that is called in creating
Martin Liskae53b6e52022-01-14 16:57:02 +01002423 global entities is parse.cc.
Paul Thomas71a77782009-03-30 19:35:14 +00002424
2425 In addition, for all but -std=legacy, the gsymbols are used to
2426 check the interfaces of external procedures from the same file.
2427 The namespace of the gsymbol is resolved and then, once this is
2428 done the interface is checked. */
Paul Thomas68ea3552006-01-21 09:08:54 +00002429
Paul Thomas3af8d8c2009-08-01 13:45:12 +00002430
2431static bool
2432not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
2433{
2434 if (!gsym_ns->proc_name->attr.recursive)
2435 return true;
2436
2437 if (sym->ns == gsym_ns)
2438 return false;
2439
2440 if (sym->ns->parent && sym->ns->parent == gsym_ns)
2441 return false;
2442
2443 return true;
2444}
2445
2446static bool
2447not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
2448{
2449 if (gsym_ns->entries)
2450 {
2451 gfc_entry_list *entry = gsym_ns->entries;
2452
2453 for (; entry; entry = entry->next)
2454 {
2455 if (strcmp (sym->name, entry->sym->name) == 0)
2456 {
2457 if (strcmp (gsym_ns->proc_name->name,
2458 sym->ns->proc_name->name) == 0)
2459 return false;
2460
2461 if (sym->ns->parent
2462 && strcmp (gsym_ns->proc_name->name,
2463 sym->ns->parent->proc_name->name) == 0)
2464 return false;
2465 }
2466 }
2467 }
2468 return true;
2469}
2470
Janus Weil96486992013-04-12 16:21:39 +02002471
2472/* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2473
2474bool
2475gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
2476{
2477 gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym);
2478
2479 for ( ; arg; arg = arg->next)
2480 {
2481 if (!arg->sym)
2482 continue;
2483
2484 if (arg->sym->attr.allocatable) /* (2a) */
2485 {
2486 strncpy (errmsg, _("allocatable argument"), err_len);
2487 return true;
2488 }
2489 else if (arg->sym->attr.asynchronous)
2490 {
2491 strncpy (errmsg, _("asynchronous argument"), err_len);
2492 return true;
2493 }
2494 else if (arg->sym->attr.optional)
2495 {
2496 strncpy (errmsg, _("optional argument"), err_len);
2497 return true;
2498 }
2499 else if (arg->sym->attr.pointer)
2500 {
2501 strncpy (errmsg, _("pointer argument"), err_len);
2502 return true;
2503 }
2504 else if (arg->sym->attr.target)
2505 {
2506 strncpy (errmsg, _("target argument"), err_len);
2507 return true;
2508 }
2509 else if (arg->sym->attr.value)
2510 {
2511 strncpy (errmsg, _("value argument"), err_len);
2512 return true;
2513 }
2514 else if (arg->sym->attr.volatile_)
2515 {
2516 strncpy (errmsg, _("volatile argument"), err_len);
2517 return true;
2518 }
2519 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */
2520 {
2521 strncpy (errmsg, _("assumed-shape argument"), err_len);
2522 return true;
2523 }
2524 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */
2525 {
2526 strncpy (errmsg, _("assumed-rank argument"), err_len);
2527 return true;
2528 }
2529 else if (arg->sym->attr.codimension) /* (2c) */
2530 {
2531 strncpy (errmsg, _("coarray argument"), err_len);
2532 return true;
2533 }
2534 else if (false) /* (2d) TODO: parametrized derived type */
2535 {
2536 strncpy (errmsg, _("parametrized derived type argument"), err_len);
2537 return true;
2538 }
2539 else if (arg->sym->ts.type == BT_CLASS) /* (2e) */
2540 {
2541 strncpy (errmsg, _("polymorphic argument"), err_len);
2542 return true;
2543 }
Tobias Burnuse7ac6a72013-04-16 22:54:21 +02002544 else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
2545 {
2546 strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len);
2547 return true;
2548 }
Janus Weil96486992013-04-12 16:21:39 +02002549 else if (arg->sym->ts.type == BT_ASSUMED)
2550 {
2551 /* As assumed-type is unlimited polymorphic (cf. above).
2552 See also TS 29113, Note 6.1. */
2553 strncpy (errmsg, _("assumed-type argument"), err_len);
2554 return true;
2555 }
2556 }
2557
2558 if (sym->attr.function)
2559 {
2560 gfc_symbol *res = sym->result ? sym->result : sym;
2561
2562 if (res->attr.dimension) /* (3a) */
2563 {
2564 strncpy (errmsg, _("array result"), err_len);
2565 return true;
2566 }
2567 else if (res->attr.pointer || res->attr.allocatable) /* (3b) */
2568 {
2569 strncpy (errmsg, _("pointer or allocatable result"), err_len);
2570 return true;
2571 }
2572 else if (res->ts.type == BT_CHARACTER && res->ts.u.cl
2573 && res->ts.u.cl->length
2574 && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */
2575 {
2576 strncpy (errmsg, _("result with non-constant character length"), err_len);
2577 return true;
2578 }
2579 }
2580
Tobias Burnus019c0e52013-12-08 22:34:18 +01002581 if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
Janus Weil96486992013-04-12 16:21:39 +02002582 {
2583 strncpy (errmsg, _("elemental procedure"), err_len);
2584 return true;
2585 }
2586 else if (sym->attr.is_bind_c) /* (5) */
2587 {
2588 strncpy (errmsg, _("bind(c) procedure"), err_len);
2589 return true;
2590 }
2591
2592 return false;
2593}
2594
2595
Paul Thomasff604882007-01-02 14:23:36 +00002596static void
Thomas Koenigfb078362019-08-15 22:52:40 +00002597resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
Paul Thomas68ea3552006-01-21 09:08:54 +00002598{
2599 gfc_gsymbol * gsym;
Paul Thomas71a77782009-03-30 19:35:14 +00002600 gfc_namespace *ns;
Ian Lance Taylor32e8bb82009-04-24 15:31:38 +00002601 enum gfc_symbol_type type;
Janus Weil96486992013-04-12 16:21:39 +02002602 char reason[200];
Paul Thomas68ea3552006-01-21 09:08:54 +00002603
2604 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2605
Thomas Koenig55b9c612019-03-13 07:21:33 +00002606 gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
2607 sym->binding_label != NULL);
Paul Thomas68ea3552006-01-21 09:08:54 +00002608
2609 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
Francois-Xavier Coudertca39e6f2007-10-05 12:33:07 +00002610 gfc_global_used (gsym, where);
Paul Thomas68ea3552006-01-21 09:08:54 +00002611
Tobias Burnus9fa52232013-03-18 10:50:23 +01002612 if ((sym->attr.if_source == IFSRC_UNKNOWN
2613 || sym->attr.if_source == IFSRC_IFBODY)
2614 && gsym->type != GSYM_UNKNOWN
Janus Weil04ba12e2014-01-06 12:31:34 +01002615 && !gsym->binding_label
Tobias Burnus9fa52232013-03-18 10:50:23 +01002616 && gsym->ns
Tobias Burnus9fa52232013-03-18 10:50:23 +01002617 && gsym->ns->proc_name
2618 && not_in_recursive (sym, gsym->ns)
2619 && not_entry_self_reference (sym, gsym->ns))
Paul Thomas71a77782009-03-30 19:35:14 +00002620 {
Tobias Burnus48a32c42010-07-23 22:07:30 +02002621 gfc_symbol *def_sym;
Tobias Burnus48a32c42010-07-23 22:07:30 +02002622 def_sym = gsym->ns->proc_name;
Tobias Burnus77f86822013-05-20 22:08:05 +02002623
Thomas Koenig866664a2019-03-24 12:51:19 +00002624 if (gsym->ns->resolved != -1)
Tobias Burnus48a32c42010-07-23 22:07:30 +02002625 {
Thomas Koenig866664a2019-03-24 12:51:19 +00002626
2627 /* Resolve the gsymbol namespace if needed. */
2628 if (!gsym->ns->resolved)
2629 {
2630 gfc_symbol *old_dt_list;
2631
2632 /* Stash away derived types so that the backend_decls
2633 do not get mixed up. */
2634 old_dt_list = gfc_derived_types;
2635 gfc_derived_types = NULL;
2636
2637 gfc_resolve (gsym->ns);
2638
2639 /* Store the new derived types with the global namespace. */
2640 if (gfc_derived_types)
2641 gsym->ns->derived_types = gfc_derived_types;
2642
2643 /* Restore the derived types of this namespace. */
2644 gfc_derived_types = old_dt_list;
2645 }
2646
2647 /* Make sure that translation for the gsymbol occurs before
2648 the procedure currently being resolved. */
2649 ns = gfc_global_ns_list;
2650 for (; ns && ns != gsym->ns; ns = ns->sibling)
2651 {
2652 if (ns->sibling == gsym->ns)
2653 {
2654 ns->sibling = gsym->ns->sibling;
2655 gsym->ns->sibling = gfc_global_ns_list;
2656 gfc_global_ns_list = gsym->ns;
2657 break;
2658 }
2659 }
2660
2661 /* This can happen if a binding name has been specified. */
2662 if (gsym->binding_label && gsym->sym_name != def_sym->name)
2663 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
2664
Thomas Koenig29557842019-04-06 14:16:01 +00002665 if (def_sym->attr.entry_master || def_sym->attr.entry)
Thomas Koenig866664a2019-03-24 12:51:19 +00002666 {
2667 gfc_entry_list *entry;
2668 for (entry = gsym->ns->entries; entry; entry = entry->next)
2669 if (strcmp (entry->sym->name, sym->name) == 0)
2670 {
2671 def_sym = entry->sym;
2672 break;
2673 }
2674 }
Tobias Burnus48a32c42010-07-23 22:07:30 +02002675 }
2676
Janus Weil96486992013-04-12 16:21:39 +02002677 if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
Daniel Franke30145da2010-05-25 14:10:01 -04002678 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002679 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
Janus Weil96486992013-04-12 16:21:39 +02002680 sym->name, &sym->declared_at, gfc_typename (&sym->ts),
2681 gfc_typename (&def_sym->ts));
2682 goto done;
Daniel Franke30145da2010-05-25 14:10:01 -04002683 }
2684
Janus Weil96486992013-04-12 16:21:39 +02002685 if (sym->attr.if_source == IFSRC_UNKNOWN
2686 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
Daniel Franke30145da2010-05-25 14:10:01 -04002687 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002688 gfc_error ("Explicit interface required for %qs at %L: %s",
Janus Weil96486992013-04-12 16:21:39 +02002689 sym->name, &sym->declared_at, reason);
2690 goto done;
Daniel Franke1b1a6622010-06-12 09:43:48 -04002691 }
2692
Thomas König2298af02020-04-17 19:53:45 +02002693 bool bad_result_characteristics;
Janus Weil96486992013-04-12 16:21:39 +02002694 if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
Thomas König2298af02020-04-17 19:53:45 +02002695 reason, sizeof(reason), NULL, NULL,
2696 &bad_result_characteristics))
Paul Thomas22c23882014-10-18 14:35:51 +00002697 {
Thomas König2298af02020-04-17 19:53:45 +02002698 /* Turn erros into warnings with -std=gnu and -std=legacy,
2699 unless a function returns a wrong type, which can lead
2700 to all kinds of ICEs and wrong code. */
2701
2702 if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)
2703 && !bad_result_characteristics)
2704 gfc_errors_to_warnings (true);
2705
2706 gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
2707 sym->name, &sym->declared_at, reason);
Thomas Koenigcc9a9222020-07-05 20:11:35 +02002708 sym->error = 1;
Thomas König2298af02020-04-17 19:53:45 +02002709 gfc_errors_to_warnings (false);
Janus Weil96486992013-04-12 16:21:39 +02002710 goto done;
Daniel Franke30145da2010-05-25 14:10:01 -04002711 }
Paul Thomas71a77782009-03-30 19:35:14 +00002712 }
Paul Thomas22c23882014-10-18 14:35:51 +00002713
Janus Weil96486992013-04-12 16:21:39 +02002714done:
Paul Thomas71a77782009-03-30 19:35:14 +00002715
Paul Thomas68ea3552006-01-21 09:08:54 +00002716 if (gsym->type == GSYM_UNKNOWN)
2717 {
2718 gsym->type = type;
2719 gsym->where = *where;
2720 }
2721
2722 gsym->used = 1;
2723}
Richard Sandiford1524f802005-12-13 05:23:12 +00002724
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002725
Diego Novillo6de9cd92004-05-13 02:41:07 -04002726/************* Function resolution *************/
2727
2728/* Resolve a function call known to be generic.
2729 Section 14.1.2.4.1. */
2730
2731static match
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002732resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002733{
2734 gfc_symbol *s;
2735
2736 if (sym->attr.generic)
2737 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002738 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
Diego Novillo6de9cd92004-05-13 02:41:07 -04002739 if (s != NULL)
2740 {
2741 expr->value.function.name = s->name;
2742 expr->value.function.esym = s;
Paul Thomasf5f701a2006-04-16 03:45:24 +00002743
2744 if (s->ts.type != BT_UNKNOWN)
2745 expr->ts = s->ts;
2746 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
2747 expr->ts = s->result->ts;
2748
Diego Novillo6de9cd92004-05-13 02:41:07 -04002749 if (s->as != NULL)
2750 expr->rank = s->as->rank;
Paul Thomasf5f701a2006-04-16 03:45:24 +00002751 else if (s->result != NULL && s->result->as != NULL)
2752 expr->rank = s->result->as->rank;
2753
Paul Thomas0a164a32007-12-16 11:34:08 +00002754 gfc_set_sym_referenced (expr->value.function.esym);
2755
Diego Novillo6de9cd92004-05-13 02:41:07 -04002756 return MATCH_YES;
2757 }
2758
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002759 /* TODO: Need to search for elemental references in generic
2760 interface. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04002761 }
2762
2763 if (sym->attr.intrinsic)
2764 return gfc_intrinsic_func_interface (expr, 0);
2765
2766 return MATCH_NO;
2767}
2768
2769
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002770static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002771resolve_generic_f (gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002772{
2773 gfc_symbol *sym;
2774 match m;
Tobias Burnusc3f34952011-11-16 22:37:43 +01002775 gfc_interface *intr = NULL;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002776
2777 sym = expr->symtree->n.sym;
2778
2779 for (;;)
2780 {
2781 m = resolve_generic_f0 (expr, sym);
2782 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002783 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002784 else if (m == MATCH_ERROR)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002785 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002786
2787generic:
Tobias Burnusc3f34952011-11-16 22:37:43 +01002788 if (!intr)
2789 for (intr = sym->generic; intr; intr = intr->next)
Fritz Reesef6288c22016-05-07 23:16:23 +00002790 if (gfc_fl_struct (intr->sym->attr.flavor))
Tobias Burnusc3f34952011-11-16 22:37:43 +01002791 break;
2792
Diego Novillo6de9cd92004-05-13 02:41:07 -04002793 if (sym->ns->parent == NULL)
2794 break;
2795 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2796
2797 if (sym == NULL)
2798 break;
2799 if (!generic_sym (sym))
2800 goto generic;
2801 }
2802
Paul Thomas71f77fd2006-12-20 13:48:06 +00002803 /* Last ditch attempt. See if the reference is to an intrinsic
2804 that possesses a matching interface. 14.1.2.4 */
Tobias Burnusc3f34952011-11-16 22:37:43 +01002805 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
Diego Novillo6de9cd92004-05-13 02:41:07 -04002806 {
Jerry DeLisle1d101212016-01-24 22:18:20 +00002807 if (gfc_init_expr_flag)
2808 gfc_error ("Function %qs in initialization expression at %L "
2809 "must be an intrinsic function",
2810 expr->symtree->n.sym->name, &expr->where);
2811 else
2812 gfc_error ("There is no specific function for the generic %qs "
2813 "at %L", expr->symtree->n.sym->name, &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002814 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002815 }
2816
Tobias Burnusc3f34952011-11-16 22:37:43 +01002817 if (intr)
2818 {
Paul Thomas22c23882014-10-18 14:35:51 +00002819 if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002820 NULL, false))
2821 return false;
Paul Thomasde624be2017-10-21 09:02:17 +00002822 if (!gfc_use_derived (expr->ts.u.derived))
2823 return false;
Tobias Burnusc3f34952011-11-16 22:37:43 +01002824 return resolve_structure_cons (expr, 0);
2825 }
2826
Diego Novillo6de9cd92004-05-13 02:41:07 -04002827 m = gfc_intrinsic_func_interface (expr, 0);
2828 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002829 return true;
Tobias Burnusc3f34952011-11-16 22:37:43 +01002830
Diego Novillo6de9cd92004-05-13 02:41:07 -04002831 if (m == MATCH_NO)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002832 gfc_error ("Generic function %qs at %L is not consistent with a "
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002833 "specific intrinsic interface", expr->symtree->n.sym->name,
2834 &expr->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -04002835
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002836 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002837}
2838
2839
2840/* Resolve a function call known to be specific. */
2841
2842static match
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002843resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002844{
2845 match m;
2846
2847 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
2848 {
2849 if (sym->attr.dummy)
2850 {
2851 sym->attr.proc = PROC_DUMMY;
2852 goto found;
2853 }
2854
2855 sym->attr.proc = PROC_EXTERNAL;
2856 goto found;
2857 }
2858
2859 if (sym->attr.proc == PROC_MODULE
2860 || sym->attr.proc == PROC_ST_FUNCTION
2861 || sym->attr.proc == PROC_INTERNAL)
2862 goto found;
2863
2864 if (sym->attr.intrinsic)
2865 {
2866 m = gfc_intrinsic_func_interface (expr, 1);
2867 if (m == MATCH_YES)
2868 return MATCH_YES;
2869 if (m == MATCH_NO)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002870 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002871 "with an intrinsic", sym->name, &expr->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -04002872
2873 return MATCH_ERROR;
2874 }
2875
2876 return MATCH_NO;
2877
2878found:
2879 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
2880
Janus Weila7c0b112009-07-04 14:28:43 +02002881 if (sym->result)
2882 expr->ts = sym->result->ts;
2883 else
2884 expr->ts = sym->ts;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002885 expr->value.function.name = sym->name;
2886 expr->value.function.esym = sym;
Andre Vehreschild6c25f792015-03-16 11:29:59 +01002887 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2888 error(s). */
2889 if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym))
2890 return MATCH_ERROR;
Janus Weil36ad06d2013-12-07 20:27:19 +01002891 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
2892 expr->rank = CLASS_DATA (sym)->as->rank;
2893 else if (sym->as != NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002894 expr->rank = sym->as->rank;
2895
2896 return MATCH_YES;
2897}
2898
2899
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002900static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002901resolve_specific_f (gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002902{
2903 gfc_symbol *sym;
2904 match m;
2905
2906 sym = expr->symtree->n.sym;
2907
2908 for (;;)
2909 {
2910 m = resolve_specific_f0 (sym, expr);
2911 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002912 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002913 if (m == MATCH_ERROR)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002914 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002915
2916 if (sym->ns->parent == NULL)
2917 break;
2918
2919 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
2920
2921 if (sym == NULL)
2922 break;
2923 }
2924
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00002925 gfc_error ("Unable to resolve the specific function %qs at %L",
Diego Novillo6de9cd92004-05-13 02:41:07 -04002926 expr->symtree->n.sym->name, &expr->where);
2927
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002928 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002929}
2930
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02002931/* Recursively append candidate SYM to CANDIDATES. Store the number of
2932 candidates in CANDIDATES_LEN. */
2933
2934static void
2935lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
2936 char **&candidates,
2937 size_t &candidates_len)
2938{
2939 gfc_symtree *p;
2940
2941 if (sym == NULL)
2942 return;
2943 if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
2944 && sym->n.sym->attr.flavor == FL_PROCEDURE)
2945 vec_push (candidates, candidates_len, sym->name);
2946
2947 p = sym->left;
2948 if (p)
2949 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2950
2951 p = sym->right;
2952 if (p)
2953 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
2954}
2955
2956
2957/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
2958
2959const char*
2960gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
2961{
2962 char **candidates = NULL;
2963 size_t candidates_len = 0;
2964 lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
2965 return gfc_closest_fuzzy_match (fn, candidates);
2966}
2967
Diego Novillo6de9cd92004-05-13 02:41:07 -04002968
2969/* Resolve a procedure call not known to be generic nor specific. */
2970
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002971static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00002972resolve_unknown_f (gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04002973{
2974 gfc_symbol *sym;
2975 gfc_typespec *ts;
2976
2977 sym = expr->symtree->n.sym;
2978
2979 if (sym->attr.dummy)
2980 {
2981 sym->attr.proc = PROC_DUMMY;
2982 expr->value.function.name = sym->name;
2983 goto set_type;
2984 }
2985
2986 /* See if we have an intrinsic function reference. */
2987
Daniel Kraftc3005b02008-07-24 20:52:51 +02002988 if (gfc_is_intrinsic (sym, 0, expr->where))
Diego Novillo6de9cd92004-05-13 02:41:07 -04002989 {
2990 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03002991 return true;
2992 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04002993 }
2994
Bernhard Reutner-Fischer1727bb52021-10-31 17:44:45 +01002995 /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */
2996 /* Intrinsics were handled above, only non-intrinsics left here. */
2997 if (sym->attr.flavor == FL_PROCEDURE
2998 && sym->attr.implicit_type
2999 && sym->ns
3000 && sym->ns->has_implicit_none_export)
3001 {
3002 gfc_error ("Missing explicit declaration with EXTERNAL attribute "
3003 "for symbol %qs at %L", sym->name, &sym->declared_at);
3004 sym->error = 1;
3005 return false;
3006 }
3007
Diego Novillo6de9cd92004-05-13 02:41:07 -04003008 /* The reference is to an external name. */
3009
3010 sym->attr.proc = PROC_EXTERNAL;
3011 expr->value.function.name = sym->name;
3012 expr->value.function.esym = expr->symtree->n.sym;
3013
3014 if (sym->as != NULL)
3015 expr->rank = sym->as->rank;
3016
3017 /* Type of the expression is either the type of the symbol or the
3018 default type of the symbol. */
3019
3020set_type:
3021 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
3022
3023 if (sym->ts.type != BT_UNKNOWN)
3024 expr->ts = sym->ts;
3025 else
3026 {
Janus Weil713485c2009-05-06 23:17:16 +02003027 ts = gfc_get_default_type (sym->name, sym->ns);
Diego Novillo6de9cd92004-05-13 02:41:07 -04003028
3029 if (ts->type == BT_UNKNOWN)
3030 {
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02003031 const char *guessed
3032 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
3033 if (guessed)
3034 gfc_error ("Function %qs at %L has no IMPLICIT type"
3035 "; did you mean %qs?",
3036 sym->name, &expr->where, guessed);
3037 else
3038 gfc_error ("Function %qs at %L has no IMPLICIT type",
3039 sym->name, &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003040 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003041 }
3042 else
3043 expr->ts = *ts;
3044 }
3045
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003046 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003047}
3048
3049
Paul Thomase7c8ff52007-07-10 05:11:00 +00003050/* Return true, if the symbol is an external procedure. */
3051static bool
3052is_external_proc (gfc_symbol *sym)
3053{
3054 if (!sym->attr.dummy && !sym->attr.contained
Janus Weil0e8d8542012-07-31 20:32:41 +02003055 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)
Paul Thomase7c8ff52007-07-10 05:11:00 +00003056 && sym->attr.proc != PROC_ST_FUNCTION
Janus Weil68d8db72010-06-29 23:40:38 +02003057 && !sym->attr.proc_pointer
Paul Thomase7c8ff52007-07-10 05:11:00 +00003058 && !sym->attr.use_assoc
3059 && sym->name)
3060 return true;
Daniel Kraftc3005b02008-07-24 20:52:51 +02003061
3062 return false;
Paul Thomase7c8ff52007-07-10 05:11:00 +00003063}
3064
3065
Volker Reichelt2054fc22005-02-24 21:59:24 +00003066/* Figure out if a function reference is pure or not. Also set the name
3067 of the function for a potential error message. Return nonzero if the
Diego Novillo6de9cd92004-05-13 02:41:07 -04003068 function is PURE, zero if not. */
Paul Thomas908a2232007-11-27 20:47:55 +00003069static int
3070pure_stmt_function (gfc_expr *, gfc_symbol *);
Diego Novillo6de9cd92004-05-13 02:41:07 -04003071
Janus Weil6457b1f2018-07-18 20:31:59 +02003072int
3073gfc_pure_function (gfc_expr *e, const char **name)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003074{
3075 int pure;
Janus Weil59308762014-12-14 13:04:49 +01003076 gfc_component *comp;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003077
Paul Thomas36f7dca2007-02-03 13:38:42 +00003078 *name = NULL;
3079
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003080 if (e->symtree != NULL
3081 && e->symtree->n.sym != NULL
3082 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
Paul Thomas908a2232007-11-27 20:47:55 +00003083 return pure_stmt_function (e, e->symtree->n.sym);
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003084
Janus Weil59308762014-12-14 13:04:49 +01003085 comp = gfc_get_proc_ptr_comp (e);
3086 if (comp)
3087 {
3088 pure = gfc_pure (comp->ts.interface);
3089 *name = comp->name;
3090 }
3091 else if (e->value.function.esym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003092 {
3093 pure = gfc_pure (e->value.function.esym);
3094 *name = e->value.function.esym->name;
3095 }
3096 else if (e->value.function.isym)
3097 {
3098 pure = e->value.function.isym->pure
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003099 || e->value.function.isym->elemental;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003100 *name = e->value.function.isym->name;
3101 }
3102 else
3103 {
3104 /* Implicit functions are not pure. */
3105 pure = 0;
3106 *name = e->value.function.name;
3107 }
3108
3109 return pure;
3110}
3111
3112
Janus Weil6457b1f2018-07-18 20:31:59 +02003113/* Check if the expression is a reference to an implicitly pure function. */
3114
3115int
3116gfc_implicit_pure_function (gfc_expr *e)
3117{
3118 gfc_component *comp = gfc_get_proc_ptr_comp (e);
3119 if (comp)
3120 return gfc_implicit_pure (comp->ts.interface);
3121 else if (e->value.function.esym)
3122 return gfc_implicit_pure (e->value.function.esym);
3123 else
3124 return 0;
3125}
3126
3127
Paul Thomas908a2232007-11-27 20:47:55 +00003128static bool
3129impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
3130 int *f ATTRIBUTE_UNUSED)
3131{
3132 const char *name;
3133
3134 /* Don't bother recursing into other statement functions
3135 since they will be checked individually for purity. */
3136 if (e->expr_type != EXPR_FUNCTION
3137 || !e->symtree
3138 || e->symtree->n.sym == sym
3139 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3140 return false;
3141
Janus Weil6457b1f2018-07-18 20:31:59 +02003142 return gfc_pure_function (e, &name) ? false : true;
Paul Thomas908a2232007-11-27 20:47:55 +00003143}
3144
3145
3146static int
3147pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
3148{
3149 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
3150}
3151
3152
Janus Weil41cc1dd2014-12-15 11:34:46 +01003153/* Check if an impure function is allowed in the current context. */
Janus Weil59308762014-12-14 13:04:49 +01003154
3155static bool check_pure_function (gfc_expr *e)
3156{
3157 const char *name = NULL;
Janus Weil6457b1f2018-07-18 20:31:59 +02003158 if (!gfc_pure_function (e, &name) && name)
Janus Weil59308762014-12-14 13:04:49 +01003159 {
3160 if (forall_flag)
3161 {
Janus Weil41cc1dd2014-12-15 11:34:46 +01003162 gfc_error ("Reference to impure function %qs at %L inside a "
Janus Weil59308762014-12-14 13:04:49 +01003163 "FORALL %s", name, &e->where,
3164 forall_flag == 2 ? "mask" : "block");
3165 return false;
3166 }
3167 else if (gfc_do_concurrent_flag)
3168 {
Janus Weil41cc1dd2014-12-15 11:34:46 +01003169 gfc_error ("Reference to impure function %qs at %L inside a "
Janus Weil59308762014-12-14 13:04:49 +01003170 "DO CONCURRENT %s", name, &e->where,
3171 gfc_do_concurrent_flag == 2 ? "mask" : "block");
3172 return false;
3173 }
3174 else if (gfc_pure (NULL))
3175 {
Janus Weil41cc1dd2014-12-15 11:34:46 +01003176 gfc_error ("Reference to impure function %qs at %L "
Janus Weil59308762014-12-14 13:04:49 +01003177 "within a PURE procedure", name, &e->where);
3178 return false;
3179 }
Janus Weil6457b1f2018-07-18 20:31:59 +02003180 if (!gfc_implicit_pure_function (e))
3181 gfc_unset_implicit_pure (NULL);
Janus Weil59308762014-12-14 13:04:49 +01003182 }
3183 return true;
3184}
3185
3186
Paul Thomas30c931d2015-03-23 07:53:31 +00003187/* Update current procedure's array_outer_dependency flag, considering
3188 a call to procedure SYM. */
3189
3190static void
3191update_current_proc_array_outer_dependency (gfc_symbol *sym)
3192{
3193 /* Check to see if this is a sibling function that has not yet
3194 been resolved. */
3195 gfc_namespace *sibling = gfc_current_ns->sibling;
3196 for (; sibling; sibling = sibling->sibling)
3197 {
3198 if (sibling->proc_name == sym)
3199 {
3200 gfc_resolve (sibling);
3201 break;
3202 }
3203 }
3204
3205 /* If SYM has references to outer arrays, so has the procedure calling
3206 SYM. If SYM is a procedure pointer, we can assume the worst. */
Steven G. Kargl55157d52018-05-25 00:39:23 +00003207 if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer)
3208 && gfc_current_ns->proc_name)
Paul Thomas30c931d2015-03-23 07:53:31 +00003209 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3210}
3211
3212
Diego Novillo6de9cd92004-05-13 02:41:07 -04003213/* Resolve a function call, which means resolving the arguments, then figuring
3214 out which entity the name refers to. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04003215
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003216static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003217resolve_function (gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003218{
3219 gfc_actual_arglist *arg;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003220 gfc_symbol *sym;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003221 bool t;
Paul Thomas48474142006-01-07 14:14:08 +00003222 int temp;
Paul Thomas7fcafa72006-12-31 06:55:16 +00003223 procedure_type p = PROC_INTRINSIC;
Paul Thomas0b4e2af2008-09-17 22:23:51 +00003224 bool no_formal_args;
Paul Thomas48474142006-01-07 14:14:08 +00003225
Paul Thomas20236f92006-01-26 20:19:09 +00003226 sym = NULL;
3227 if (expr->symtree)
3228 sym = expr->symtree->n.sym;
3229
Janus Weil6c036622009-11-24 09:16:32 +01003230 /* If this is a procedure pointer component, it has already been resolved. */
Mikael Morin2a573572012-08-14 16:28:29 +00003231 if (gfc_is_proc_ptr_comp (expr))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003232 return true;
Mikael Morin2a573572012-08-14 16:28:29 +00003233
Tobias Burnus63617e32016-06-21 20:36:25 +02003234 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting
3235 another caf_get. */
3236 if (sym && sym->attr.intrinsic
3237 && (sym->intmod_sym_id == GFC_ISYM_CAF_GET
3238 || sym->intmod_sym_id == GFC_ISYM_CAF_SEND))
3239 return true;
3240
Thomas König52354da2020-01-16 22:09:37 +01003241 if (expr->ref)
3242 {
3243 gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name,
3244 &expr->where);
3245 return false;
3246 }
3247
Steven G. Kargl2c68bc82008-09-06 17:11:29 +02003248 if (sym && sym->attr.intrinsic
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003249 && !gfc_resolve_intrinsic (sym, &expr->where))
3250 return false;
Steven G. Kargl2c68bc82008-09-06 17:11:29 +02003251
Janus Weil726d8562008-12-02 12:58:16 +01003252 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
Paul Thomas20a037d2006-12-31 07:51:47 +00003253 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003254 gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003255 return false;
Paul Thomas20a037d2006-12-31 07:51:47 +00003256 }
3257
Paul Thomas77f72c92018-06-21 22:38:55 +00003258 /* If this is a deferred TBP with an abstract interface (which may
Janus Weilb3d286b2010-03-08 10:35:04 +01003259 of course be referenced), expr->value.function.esym will be set. */
3260 if (sym && sym->attr.abstract && !expr->value.function.esym)
Tobias Burnus9e1d7122007-08-18 16:57:21 +02003261 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003262 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
Tobias Burnus9e1d7122007-08-18 16:57:21 +02003263 sym->name, &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003264 return false;
Tobias Burnus9e1d7122007-08-18 16:57:21 +02003265 }
3266
Paul Thomas77f72c92018-06-21 22:38:55 +00003267 /* If this is a deferred TBP with an abstract interface, its result
3268 cannot be an assumed length character (F2003: C418). */
3269 if (sym && sym->attr.abstract && sym->attr.function
Paul Thomas474f2532018-06-22 22:31:17 +00003270 && sym->result->ts.u.cl
Paul Thomas99d22932018-07-05 16:27:38 +00003271 && sym->result->ts.u.cl->length == NULL
3272 && !sym->result->ts.deferred)
Paul Thomas77f72c92018-06-21 22:38:55 +00003273 {
3274 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed "
Paul Thomas99d22932018-07-05 16:27:38 +00003275 "character length result (F2008: C418)", sym->name,
Paul Thomas77f72c92018-06-21 22:38:55 +00003276 &sym->declared_at);
3277 return false;
3278 }
3279
Paul Thomas48474142006-01-07 14:14:08 +00003280 /* Switch off assumed size checking and do this again for certain kinds
3281 of procedure, once the procedure itself is resolved. */
3282 need_full_assumed_size++;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003283
Paul Thomas7fcafa72006-12-31 06:55:16 +00003284 if (expr->symtree && expr->symtree->n.sym)
3285 p = expr->symtree->n.sym->attr.proc;
3286
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02003287 if (expr->value.function.isym && expr->value.function.isym->inquiry)
3288 inquiry_argument = true;
Janus Weil4cbc9032013-01-29 22:40:51 +01003289 no_formal_args = sym && is_external_proc (sym)
3290 && gfc_sym_get_dummy_args (sym) == NULL;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02003291
Paul Thomas22c23882014-10-18 14:35:51 +00003292 if (!resolve_actual_arglist (expr->value.function.actual,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003293 p, no_formal_args))
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02003294 {
3295 inquiry_argument = false;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003296 return false;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02003297 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04003298
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02003299 inquiry_argument = false;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00003300
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +00003301 /* Resume assumed_size checking. */
Paul Thomas48474142006-01-07 14:14:08 +00003302 need_full_assumed_size--;
3303
Paul Thomas71a77782009-03-30 19:35:14 +00003304 /* If the procedure is external, check for usage. */
3305 if (sym && is_external_proc (sym))
Thomas Koenigfb078362019-08-15 22:52:40 +00003306 resolve_global_procedure (sym, &expr->where, 0);
Paul Thomas71a77782009-03-30 19:35:14 +00003307
Paul Thomas20236f92006-01-26 20:19:09 +00003308 if (sym && sym->ts.type == BT_CHARACTER
Janus Weilbc21d312009-08-13 21:46:46 +02003309 && sym->ts.u.cl
3310 && sym->ts.u.cl->length == NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003311 && !sym->attr.dummy
Paul Thomas8d51f262011-01-28 13:53:19 +00003312 && !sym->ts.deferred
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003313 && expr->value.function.esym == NULL
3314 && !sym->attr.contained)
Paul Thomas20236f92006-01-26 20:19:09 +00003315 {
Paul Thomas20236f92006-01-26 20:19:09 +00003316 /* Internal procedures are taken care of in resolve_contained_fntype. */
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003317 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
Paul Thomas0e3e65b2006-04-21 05:10:22 +00003318 "be used at %L since it is not a dummy argument",
3319 sym->name, &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003320 return false;
Paul Thomas20236f92006-01-26 20:19:09 +00003321 }
3322
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003323 /* See if function is already resolved. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04003324
Jakub Jelinekb46ebd62014-06-24 09:45:22 +02003325 if (expr->value.function.name != NULL
3326 || expr->value.function.isym != NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003327 {
3328 if (expr->ts.type == BT_UNKNOWN)
Paul Thomas20236f92006-01-26 20:19:09 +00003329 expr->ts = sym->ts;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003330 t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003331 }
3332 else
3333 {
3334 /* Apply the rules of section 14.1.2. */
3335
Paul Thomas20236f92006-01-26 20:19:09 +00003336 switch (procedure_kind (sym))
Diego Novillo6de9cd92004-05-13 02:41:07 -04003337 {
3338 case PTYPE_GENERIC:
3339 t = resolve_generic_f (expr);
3340 break;
3341
3342 case PTYPE_SPECIFIC:
3343 t = resolve_specific_f (expr);
3344 break;
3345
3346 case PTYPE_UNKNOWN:
3347 t = resolve_unknown_f (expr);
3348 break;
3349
3350 default:
3351 gfc_internal_error ("resolve_function(): bad function type");
3352 }
3353 }
3354
3355 /* If the expression is still a function (it might have simplified),
3356 then we check to see if we are calling an elemental function. */
3357
3358 if (expr->expr_type != EXPR_FUNCTION)
3359 return t;
3360
Steven G. Kargl8b4e5e72019-10-02 17:01:30 +00003361 /* Walk the argument list looking for invalid BOZ. */
Steven G. Kargl405e87e2019-10-11 17:52:27 +00003362 for (arg = expr->value.function.actual; arg; arg = arg->next)
3363 if (arg->expr && arg->expr->ts.type == BT_BOZ)
3364 {
3365 gfc_error ("A BOZ literal constant at %L cannot appear as an "
3366 "actual argument in a function reference",
3367 &arg->expr->where);
3368 return false;
3369 }
Steven G. Kargl8b4e5e72019-10-02 17:01:30 +00003370
Paul Thomas48474142006-01-07 14:14:08 +00003371 temp = need_full_assumed_size;
3372 need_full_assumed_size = 0;
3373
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003374 if (!resolve_elemental_actual (expr, NULL))
3375 return false;
Paul Thomas48474142006-01-07 14:14:08 +00003376
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +01003377 if (omp_workshare_flag
3378 && expr->value.function.esym
3379 && ! gfc_elemental (expr->value.function.esym))
3380 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003381 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003382 "in WORKSHARE construct", expr->value.function.esym->name,
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +01003383 &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003384 t = false;
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +01003385 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04003386
Daniel Frankecd5ecab2007-05-29 17:10:48 -04003387#define GENERIC_ID expr->value.function.isym->id
Paul Thomas48474142006-01-07 14:14:08 +00003388 else if (expr->value.function.actual != NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003389 && expr->value.function.isym != NULL
3390 && GENERIC_ID != GFC_ISYM_LBOUND
Tobias Burnus2c060872014-04-30 21:08:19 +02003391 && GENERIC_ID != GFC_ISYM_LCOBOUND
3392 && GENERIC_ID != GFC_ISYM_UCOBOUND
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003393 && GENERIC_ID != GFC_ISYM_LEN
3394 && GENERIC_ID != GFC_ISYM_LOC
Tobias Burnuscadddfd2013-03-25 16:40:26 +01003395 && GENERIC_ID != GFC_ISYM_C_LOC
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003396 && GENERIC_ID != GFC_ISYM_PRESENT)
Paul Thomas48474142006-01-07 14:14:08 +00003397 {
Tobias Burnusfa951692006-10-16 13:17:29 +02003398 /* Array intrinsics must also have the last upper bound of an
Kazu Hiratab82feea2006-04-08 14:31:12 +00003399 assumed size array argument. UBOUND and SIZE have to be
Paul Thomas48474142006-01-07 14:14:08 +00003400 excluded from the check if the second argument is anything
3401 than a constant. */
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02003402
Paul Thomas48474142006-01-07 14:14:08 +00003403 for (arg = expr->value.function.actual; arg; arg = arg->next)
3404 {
Tobias Burnus7a687b22008-09-06 17:27:50 +02003405 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
Tobias Burnus1634e532013-05-02 18:29:14 +02003406 && arg == expr->value.function.actual
Tobias Burnus7a687b22008-09-06 17:27:50 +02003407 && arg->next != NULL && arg->next->expr)
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003408 {
3409 if (arg->next->expr->expr_type != EXPR_CONSTANT)
3410 break;
3411
Janus Weil2eb37452018-09-20 21:33:05 +02003412 if (arg->next->name && strcmp (arg->next->name, "kind") == 0)
Tobias Burnus7a687b22008-09-06 17:27:50 +02003413 break;
3414
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003415 if ((int)mpz_get_si (arg->next->expr->value.integer)
3416 < arg->expr->rank)
3417 break;
3418 }
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02003419
Paul Thomas48474142006-01-07 14:14:08 +00003420 if (arg->expr != NULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003421 && arg->expr->rank > 0
3422 && resolve_assumed_size_actual (arg->expr))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003423 return false;
Paul Thomas48474142006-01-07 14:14:08 +00003424 }
3425 }
Paul Thomas4d4074e2006-12-09 20:41:51 +00003426#undef GENERIC_ID
Paul Thomas48474142006-01-07 14:14:08 +00003427
3428 need_full_assumed_size = temp;
3429
Janus Weil59308762014-12-14 13:04:49 +01003430 if (!check_pure_function(expr))
3431 t = false;
Paul Thomasf1f39032011-01-08 19:17:03 +00003432
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003433 /* Functions without the RECURSIVE attribution are not allowed to
3434 * call themselves. */
3435 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
3436 {
Daniel Kraft1933ba02008-11-30 21:36:10 +01003437 gfc_symbol *esym;
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003438 esym = expr->value.function.esym;
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003439
Daniel Kraft1933ba02008-11-30 21:36:10 +01003440 if (is_illegal_recursion (esym, gfc_current_ns))
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003441 {
Daniel Kraft1933ba02008-11-30 21:36:10 +01003442 if (esym->attr.entry && esym->ns->entries)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003443 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3444 " function %qs is not RECURSIVE",
Daniel Kraft1933ba02008-11-30 21:36:10 +01003445 esym->name, &expr->where, esym->ns->entries->sym->name);
3446 else
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003447 gfc_error ("Function %qs at %L cannot be called recursively, as it"
Daniel Kraft1933ba02008-11-30 21:36:10 +01003448 " is not RECURSIVE", esym->name, &expr->where);
3449
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003450 t = false;
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003451 }
3452 }
3453
Erik Edelmann47992a42006-01-05 00:22:39 +00003454 /* Character lengths of use associated functions may contains references to
3455 symbols not referenced from the current program unit otherwise. Make sure
3456 those symbols are marked as referenced. */
3457
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02003458 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
Erik Edelmann47992a42006-01-05 00:22:39 +00003459 && expr->value.function.esym->attr.use_assoc)
3460 {
Janus Weilbc21d312009-08-13 21:46:46 +02003461 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
Erik Edelmann47992a42006-01-05 00:22:39 +00003462 }
3463
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003464 /* Make sure that the expression has a typespec that works. */
3465 if (expr->ts.type == BT_UNKNOWN)
3466 {
3467 if (expr->symtree->n.sym->result
Janus Weil3070bab2009-04-09 11:39:09 +02003468 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
3469 && !expr->symtree->n.sym->result->attr.proc_pointer)
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003470 expr->ts = expr->symtree->n.sym->result->ts;
Paul Thomas9ebe2d22007-01-15 08:16:17 +00003471 }
3472
Paul Thomas30c931d2015-03-23 07:53:31 +00003473 if (!expr->ref && !expr->value.function.isym)
3474 {
3475 if (expr->value.function.esym)
3476 update_current_proc_array_outer_dependency (expr->value.function.esym);
3477 else
3478 update_current_proc_array_outer_dependency (sym);
3479 }
3480 else if (expr->ref)
3481 /* typebound procedure: Assume the worst. */
3482 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3483
Tobias Burnus0caf4002020-11-03 09:55:58 +01003484 if (expr->value.function.esym
3485 && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3486 gfc_warning (OPT_Wdeprecated_declarations,
3487 "Using function %qs at %L is deprecated",
3488 sym->name, &expr->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -04003489 return t;
3490}
3491
3492
3493/************* Subroutine resolution *************/
3494
Janus Weil59308762014-12-14 13:04:49 +01003495static bool
3496pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003497{
Diego Novillo6de9cd92004-05-13 02:41:07 -04003498 if (gfc_pure (sym))
Janus Weil59308762014-12-14 13:04:49 +01003499 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003500
3501 if (forall_flag)
Janus Weil59308762014-12-14 13:04:49 +01003502 {
3503 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3504 name, loc);
3505 return false;
3506 }
Thomas Koenigce96d372013-09-02 22:09:07 +00003507 else if (gfc_do_concurrent_flag)
Janus Weil59308762014-12-14 13:04:49 +01003508 {
3509 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3510 "PURE", name, loc);
3511 return false;
3512 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04003513 else if (gfc_pure (NULL))
Janus Weil59308762014-12-14 13:04:49 +01003514 {
3515 gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
3516 return false;
3517 }
Tobias Burnus3d2cea82011-11-24 18:57:41 +01003518
Tobias Burnusccd77512014-03-19 22:03:14 +01003519 gfc_unset_implicit_pure (NULL);
Janus Weil59308762014-12-14 13:04:49 +01003520 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003521}
3522
3523
3524static match
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003525resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003526{
3527 gfc_symbol *s;
3528
3529 if (sym->attr.generic)
3530 {
3531 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
3532 if (s != NULL)
3533 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003534 c->resolved_sym = s;
Janus Weil59308762014-12-14 13:04:49 +01003535 if (!pure_subroutine (s, s->name, &c->loc))
3536 return MATCH_ERROR;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003537 return MATCH_YES;
3538 }
3539
3540 /* TODO: Need to search for elemental references in generic interface. */
3541 }
3542
3543 if (sym->attr.intrinsic)
3544 return gfc_intrinsic_sub_interface (c, 0);
3545
3546 return MATCH_NO;
3547}
3548
3549
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003550static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003551resolve_generic_s (gfc_code *c)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003552{
3553 gfc_symbol *sym;
3554 match m;
3555
3556 sym = c->symtree->n.sym;
3557
Paul Thomas8c086c92006-08-30 05:18:36 +00003558 for (;;)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003559 {
Paul Thomas8c086c92006-08-30 05:18:36 +00003560 m = resolve_generic_s0 (c, sym);
3561 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003562 return true;
Paul Thomas8c086c92006-08-30 05:18:36 +00003563 else if (m == MATCH_ERROR)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003564 return false;
Paul Thomas8c086c92006-08-30 05:18:36 +00003565
3566generic:
3567 if (sym->ns->parent == NULL)
3568 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003569 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
Paul Thomas8c086c92006-08-30 05:18:36 +00003570
3571 if (sym == NULL)
3572 break;
3573 if (!generic_sym (sym))
3574 goto generic;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003575 }
3576
Paul Thomas71f77fd2006-12-20 13:48:06 +00003577 /* Last ditch attempt. See if the reference is to an intrinsic
3578 that possesses a matching interface. 14.1.2.4 */
Paul Thomas8c086c92006-08-30 05:18:36 +00003579 sym = c->symtree->n.sym;
Paul Thomas71f77fd2006-12-20 13:48:06 +00003580
Daniel Kraftc3005b02008-07-24 20:52:51 +02003581 if (!gfc_is_intrinsic (sym, 1, c->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -04003582 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003583 gfc_error ("There is no specific subroutine for the generic %qs at %L",
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003584 sym->name, &c->loc);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003585 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003586 }
3587
3588 m = gfc_intrinsic_sub_interface (c, 0);
3589 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003590 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003591 if (m == MATCH_NO)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003592 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
Diego Novillo6de9cd92004-05-13 02:41:07 -04003593 "intrinsic subroutine interface", sym->name, &c->loc);
3594
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003595 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003596}
3597
3598
3599/* Resolve a subroutine call known to be specific. */
3600
3601static match
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003602resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003603{
3604 match m;
3605
3606 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
3607 {
3608 if (sym->attr.dummy)
3609 {
3610 sym->attr.proc = PROC_DUMMY;
3611 goto found;
3612 }
3613
3614 sym->attr.proc = PROC_EXTERNAL;
3615 goto found;
3616 }
3617
3618 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
3619 goto found;
3620
3621 if (sym->attr.intrinsic)
3622 {
3623 m = gfc_intrinsic_sub_interface (c, 1);
3624 if (m == MATCH_YES)
3625 return MATCH_YES;
3626 if (m == MATCH_NO)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003627 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
Diego Novillo6de9cd92004-05-13 02:41:07 -04003628 "with an intrinsic", sym->name, &c->loc);
3629
3630 return MATCH_ERROR;
3631 }
3632
3633 return MATCH_NO;
3634
3635found:
3636 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3637
3638 c->resolved_sym = sym;
Janus Weil59308762014-12-14 13:04:49 +01003639 if (!pure_subroutine (sym, sym->name, &c->loc))
3640 return MATCH_ERROR;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003641
3642 return MATCH_YES;
3643}
3644
3645
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003646static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003647resolve_specific_s (gfc_code *c)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003648{
3649 gfc_symbol *sym;
3650 match m;
3651
3652 sym = c->symtree->n.sym;
3653
Paul Thomas8c086c92006-08-30 05:18:36 +00003654 for (;;)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003655 {
3656 m = resolve_specific_s0 (c, sym);
3657 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003658 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003659 if (m == MATCH_ERROR)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003660 return false;
Paul Thomas8c086c92006-08-30 05:18:36 +00003661
3662 if (sym->ns->parent == NULL)
3663 break;
3664
3665 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
3666
3667 if (sym == NULL)
3668 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003669 }
3670
Paul Thomas8c086c92006-08-30 05:18:36 +00003671 sym = c->symtree->n.sym;
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003672 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
Diego Novillo6de9cd92004-05-13 02:41:07 -04003673 sym->name, &c->loc);
3674
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003675 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003676}
3677
3678
3679/* Resolve a subroutine call not known to be generic nor specific. */
3680
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003681static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003682resolve_unknown_s (gfc_code *c)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003683{
3684 gfc_symbol *sym;
3685
3686 sym = c->symtree->n.sym;
3687
3688 if (sym->attr.dummy)
3689 {
3690 sym->attr.proc = PROC_DUMMY;
3691 goto found;
3692 }
3693
3694 /* See if we have an intrinsic function reference. */
3695
Daniel Kraftc3005b02008-07-24 20:52:51 +02003696 if (gfc_is_intrinsic (sym, 1, c->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -04003697 {
3698 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003699 return true;
3700 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003701 }
3702
3703 /* The reference is to an external name. */
3704
3705found:
3706 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
3707
3708 c->resolved_sym = sym;
3709
Janus Weil59308762014-12-14 13:04:49 +01003710 return pure_subroutine (sym, sym->name, &c->loc);
Diego Novillo6de9cd92004-05-13 02:41:07 -04003711}
3712
3713
3714/* Resolve a subroutine call. Although it was tempting to use the same code
3715 for functions, subroutines and functions are stored differently and this
3716 makes things awkward. */
3717
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003718static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003719resolve_call (gfc_code *c)
Diego Novillo6de9cd92004-05-13 02:41:07 -04003720{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003721 bool t;
Paul Thomas7fcafa72006-12-31 06:55:16 +00003722 procedure_type ptype = PROC_INTRINSIC;
Paul Thomas67cec812008-11-03 06:44:47 +00003723 gfc_symbol *csym, *sym;
Paul Thomas0b4e2af2008-09-17 22:23:51 +00003724 bool no_formal_args;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003725
Paul Thomas0b4e2af2008-09-17 22:23:51 +00003726 csym = c->symtree ? c->symtree->n.sym : NULL;
3727
3728 if (csym && csym->ts.type != BT_UNKNOWN)
Paul Thomas2ed8d222006-02-13 21:22:55 +00003729 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00003730 gfc_error ("%qs at %L has a type, which is not consistent with "
Paul Thomas0b4e2af2008-09-17 22:23:51 +00003731 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003732 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +00003733 }
3734
Paul Thomas67cec812008-11-03 06:44:47 +00003735 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
3736 {
Paul Thomas79b1d362009-01-03 17:47:20 +00003737 gfc_symtree *st;
Mikael Morind932cea2013-01-06 15:50:09 +00003738 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
Paul Thomas79b1d362009-01-03 17:47:20 +00003739 sym = st ? st->n.sym : NULL;
Paul Thomas67cec812008-11-03 06:44:47 +00003740 if (sym && csym != sym
3741 && sym->ns == gfc_current_ns
3742 && sym->attr.flavor == FL_PROCEDURE
3743 && sym->attr.contained)
3744 {
3745 sym->refs++;
Paul Thomas79b1d362009-01-03 17:47:20 +00003746 if (csym->attr.generic)
3747 c->symtree->n.sym = sym;
3748 else
3749 c->symtree = st;
3750 csym = c->symtree->n.sym;
Paul Thomas67cec812008-11-03 06:44:47 +00003751 }
3752 }
3753
Janus Weilfdb1fa92013-02-12 13:15:26 +01003754 /* If this ia a deferred TBP, c->expr1 will be set. */
3755 if (!c->expr1 && csym)
Janus Weil8bae6272009-11-05 11:42:48 +01003756 {
Janus Weilfdb1fa92013-02-12 13:15:26 +01003757 if (csym->attr.abstract)
3758 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003759 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
Janus Weilfdb1fa92013-02-12 13:15:26 +01003760 csym->name, &c->loc);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003761 return false;
Janus Weilfdb1fa92013-02-12 13:15:26 +01003762 }
Janus Weil8bae6272009-11-05 11:42:48 +01003763
Janus Weilfdb1fa92013-02-12 13:15:26 +01003764 /* Subroutines without the RECURSIVE attribution are not allowed to
3765 call themselves. */
3766 if (is_illegal_recursion (csym, gfc_current_ns))
3767 {
3768 if (csym->attr.entry && csym->ns->entries)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003769 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3770 "as subroutine %qs is not RECURSIVE",
Janus Weilfdb1fa92013-02-12 13:15:26 +01003771 csym->name, &c->loc, csym->ns->entries->sym->name);
3772 else
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +00003773 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
Janus Weilfdb1fa92013-02-12 13:15:26 +01003774 "as it is not RECURSIVE", csym->name, &c->loc);
Daniel Kraft1933ba02008-11-30 21:36:10 +01003775
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003776 t = false;
Janus Weilfdb1fa92013-02-12 13:15:26 +01003777 }
Francois-Xavier Coudert77f131c2006-05-17 16:11:40 +02003778 }
3779
Paul Thomas48474142006-01-07 14:14:08 +00003780 /* Switch off assumed size checking and do this again for certain kinds
3781 of procedure, once the procedure itself is resolved. */
3782 need_full_assumed_size++;
3783
Paul Thomas0b4e2af2008-09-17 22:23:51 +00003784 if (csym)
3785 ptype = csym->attr.proc;
Paul Thomas7fcafa72006-12-31 06:55:16 +00003786
Janus Weil4cbc9032013-01-29 22:40:51 +01003787 no_formal_args = csym && is_external_proc (csym)
3788 && gfc_sym_get_dummy_args (csym) == NULL;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003789 if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args))
3790 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003791
Steven G. Kargl66e4ab32007-06-07 18:10:31 +00003792 /* Resume assumed_size checking. */
Paul Thomas48474142006-01-07 14:14:08 +00003793 need_full_assumed_size--;
3794
Paul Thomas71a77782009-03-30 19:35:14 +00003795 /* If external, check for usage. */
3796 if (csym && is_external_proc (csym))
Thomas Koenigfb078362019-08-15 22:52:40 +00003797 resolve_global_procedure (csym, &c->loc, 1);
Paul Thomas71a77782009-03-30 19:35:14 +00003798
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003799 t = true;
Richard Sandiford1524f802005-12-13 05:23:12 +00003800 if (c->resolved_sym == NULL)
Daniel Kraft12f681a2008-11-01 14:26:19 +01003801 {
3802 c->resolved_isym = NULL;
3803 switch (procedure_kind (csym))
3804 {
3805 case PTYPE_GENERIC:
3806 t = resolve_generic_s (c);
3807 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003808
Daniel Kraft12f681a2008-11-01 14:26:19 +01003809 case PTYPE_SPECIFIC:
3810 t = resolve_specific_s (c);
3811 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003812
Daniel Kraft12f681a2008-11-01 14:26:19 +01003813 case PTYPE_UNKNOWN:
3814 t = resolve_unknown_s (c);
3815 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04003816
Daniel Kraft12f681a2008-11-01 14:26:19 +01003817 default:
3818 gfc_internal_error ("resolve_subroutine(): bad function type");
3819 }
3820 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04003821
Paul Thomasb8ea6db2006-07-16 15:01:59 +00003822 /* Some checks of elemental subroutine actual arguments. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003823 if (!resolve_elemental_actual (NULL, c))
3824 return false;
Paul Thomas48474142006-01-07 14:14:08 +00003825
Paul Thomas30c931d2015-03-23 07:53:31 +00003826 if (!c->expr1)
3827 update_current_proc_array_outer_dependency (csym);
3828 else
3829 /* Typebound procedure: Assume the worst. */
3830 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
3831
Tobias Burnus0caf4002020-11-03 09:55:58 +01003832 if (c->resolved_sym
3833 && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED))
3834 gfc_warning (OPT_Wdeprecated_declarations,
3835 "Using subroutine %qs at %L is deprecated",
3836 c->resolved_sym->name, &c->loc);
3837
Diego Novillo6de9cd92004-05-13 02:41:07 -04003838 return t;
3839}
3840
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003841
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003842/* Compare the shapes of two arrays that have non-NULL shapes. If both
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003843 op1->shape and op2->shape are non-NULL return true if their shapes
3844 match. If both op1->shape and op2->shape are non-NULL return false
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003845 if their shapes do not match. If either op1->shape or op2->shape is
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003846 NULL, return true. */
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003847
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003848static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003849compare_shapes (gfc_expr *op1, gfc_expr *op2)
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003850{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003851 bool t;
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003852 int i;
3853
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003854 t = true;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02003855
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003856 if (op1->shape != NULL && op2->shape != NULL)
3857 {
3858 for (i = 0; i < op1->rank; i++)
3859 {
3860 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
3861 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00003862 gfc_error ("Shapes for operands at %L and %L are not conformable",
3863 &op1->where, &op2->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03003864 t = false;
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00003865 break;
3866 }
3867 }
3868 }
3869
3870 return t;
3871}
Diego Novillo6de9cd92004-05-13 02:41:07 -04003872
Fritz Reesedd90ca32016-10-25 18:27:51 +00003873/* Convert a logical operator to the corresponding bitwise intrinsic call.
3874 For example A .AND. B becomes IAND(A, B). */
3875static gfc_expr *
3876logical_to_bitwise (gfc_expr *e)
3877{
3878 gfc_expr *tmp, *op1, *op2;
3879 gfc_isym_id isym;
3880 gfc_actual_arglist *args = NULL;
3881
3882 gcc_assert (e->expr_type == EXPR_OP);
3883
3884 isym = GFC_ISYM_NONE;
3885 op1 = e->value.op.op1;
3886 op2 = e->value.op.op2;
3887
3888 switch (e->value.op.op)
3889 {
3890 case INTRINSIC_NOT:
3891 isym = GFC_ISYM_NOT;
3892 break;
3893 case INTRINSIC_AND:
3894 isym = GFC_ISYM_IAND;
3895 break;
3896 case INTRINSIC_OR:
3897 isym = GFC_ISYM_IOR;
3898 break;
3899 case INTRINSIC_NEQV:
3900 isym = GFC_ISYM_IEOR;
3901 break;
3902 case INTRINSIC_EQV:
3903 /* "Bitwise eqv" is just the complement of NEQV === IEOR.
3904 Change the old expression to NEQV, which will get replaced by IEOR,
3905 and wrap it in NOT. */
3906 tmp = gfc_copy_expr (e);
3907 tmp->value.op.op = INTRINSIC_NEQV;
3908 tmp = logical_to_bitwise (tmp);
3909 isym = GFC_ISYM_NOT;
3910 op1 = tmp;
3911 op2 = NULL;
3912 break;
3913 default:
3914 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic");
3915 }
3916
3917 /* Inherit the original operation's operands as arguments. */
3918 args = gfc_get_actual_arglist ();
3919 args->expr = op1;
3920 if (op2)
3921 {
3922 args->next = gfc_get_actual_arglist ();
3923 args->next->expr = op2;
3924 }
3925
3926 /* Convert the expression to a function call. */
3927 e->expr_type = EXPR_FUNCTION;
3928 e->value.function.actual = args;
3929 e->value.function.isym = gfc_intrinsic_function_by_id (isym);
3930 e->value.function.name = e->value.function.isym->name;
3931 e->value.function.esym = NULL;
3932
3933 /* Make up a pre-resolved function call symtree if we need to. */
3934 if (!e->symtree || !e->symtree->n.sym)
3935 {
3936 gfc_symbol *sym;
3937 gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree);
3938 sym = e->symtree->n.sym;
3939 sym->result = sym;
3940 sym->attr.flavor = FL_PROCEDURE;
3941 sym->attr.function = 1;
3942 sym->attr.elemental = 1;
3943 sym->attr.pure = 1;
3944 sym->attr.referenced = 1;
3945 gfc_intrinsic_symbol (sym);
3946 gfc_commit_symbol (sym);
3947 }
3948
3949 args->name = e->value.function.isym->formal->name;
3950 if (e->value.function.isym->formal->next)
3951 args->next->name = e->value.function.isym->formal->next->name;
3952
3953 return e;
3954}
Steven G. Kargledf1eac2007-01-20 22:01:41 +00003955
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02003956/* Recursively append candidate UOP to CANDIDATES. Store the number of
3957 candidates in CANDIDATES_LEN. */
3958static void
3959lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
3960 char **&candidates,
3961 size_t &candidates_len)
3962{
3963 gfc_symtree *p;
3964
3965 if (uop == NULL)
3966 return;
3967
3968 /* Not sure how to properly filter here. Use all for a start.
3969 n.uop.op is NULL for empty interface operators (is that legal?) disregard
3970 these as i suppose they don't make terribly sense. */
3971
3972 if (uop->n.uop->op != NULL)
3973 vec_push (candidates, candidates_len, uop->name);
3974
3975 p = uop->left;
3976 if (p)
3977 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3978
3979 p = uop->right;
3980 if (p)
3981 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
3982}
3983
3984/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
3985
3986static const char*
3987lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
3988{
3989 char **candidates = NULL;
3990 size_t candidates_len = 0;
3991 lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
3992 return gfc_closest_fuzzy_match (op, candidates);
3993}
3994
3995
Janus Weil6457b1f2018-07-18 20:31:59 +02003996/* Callback finding an impure function as an operand to an .and. or
3997 .or. expression. Remember the last function warned about to
3998 avoid double warnings when recursing. */
3999
4000static int
4001impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
4002 void *data)
4003{
4004 gfc_expr *f = *e;
4005 const char *name;
4006 static gfc_expr *last = NULL;
4007 bool *found = (bool *) data;
4008
4009 if (f->expr_type == EXPR_FUNCTION)
4010 {
4011 *found = 1;
4012 if (f != last && !gfc_pure_function (f, &name)
4013 && !gfc_implicit_pure_function (f))
4014 {
4015 if (name)
4016 gfc_warning (OPT_Wfunction_elimination,
4017 "Impure function %qs at %L might not be evaluated",
4018 name, &f->where);
4019 else
4020 gfc_warning (OPT_Wfunction_elimination,
4021 "Impure function at %L might not be evaluated",
4022 &f->where);
4023 }
4024 last = f;
4025 }
4026
4027 return 0;
4028}
4029
Mark Eggleston32bef8f2019-11-25 10:36:25 +00004030/* Return true if TYPE is character based, false otherwise. */
4031
4032static int
4033is_character_based (bt type)
4034{
4035 return type == BT_CHARACTER || type == BT_HOLLERITH;
4036}
4037
4038
4039/* If expression is a hollerith, convert it to character and issue a warning
4040 for the conversion. */
4041
4042static void
4043convert_hollerith_to_character (gfc_expr *e)
4044{
4045 if (e->ts.type == BT_HOLLERITH)
4046 {
4047 gfc_typespec t;
4048 gfc_clear_ts (&t);
4049 t.type = BT_CHARACTER;
4050 t.kind = e->ts.kind;
4051 gfc_convert_type_warn (e, &t, 2, 1);
4052 }
4053}
4054
4055/* Convert to numeric and issue a warning for the conversion. */
4056
4057static void
4058convert_to_numeric (gfc_expr *a, gfc_expr *b)
4059{
4060 gfc_typespec t;
4061 gfc_clear_ts (&t);
4062 t.type = b->ts.type;
4063 t.kind = b->ts.kind;
4064 gfc_convert_type_warn (a, &t, 2, 1);
4065}
Janus Weil6457b1f2018-07-18 20:31:59 +02004066
Diego Novillo6de9cd92004-05-13 02:41:07 -04004067/* Resolve an operator expression node. This can involve replacing the
4068 operation with a user defined function call. */
4069
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004070static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004071resolve_operator (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004072{
4073 gfc_expr *op1, *op2;
Tobias Burnusb1790262021-03-24 07:50:22 +01004074 /* One error uses 3 names; additional space for wording (also via gettext). */
4075 char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50];
Francois-Xavier Coudert27189292007-03-25 09:01:23 +00004076 bool dual_locus_error;
Martin Liska53fcf722019-02-13 14:04:56 +01004077 bool t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004078
4079 /* Resolve all subnodes-- give them types. */
4080
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +00004081 switch (e->value.op.op)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004082 {
4083 default:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004084 if (!gfc_resolve_expr (e->value.op.op2))
Sandra Loosemoreee11be72021-11-04 15:43:29 -07004085 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004086
Marek Polacek191816a2016-08-12 10:30:47 +00004087 /* Fall through. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04004088
4089 case INTRINSIC_NOT:
4090 case INTRINSIC_UPLUS:
4091 case INTRINSIC_UMINUS:
Tobias Schlüter2414e1d2006-02-10 01:10:47 +01004092 case INTRINSIC_PARENTHESES:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004093 if (!gfc_resolve_expr (e->value.op.op1))
4094 return false;
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004095 if (e->value.op.op1
4096 && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2)
4097 {
4098 gfc_error ("BOZ literal constant at %L cannot be an operand of "
4099 "unary operator %qs", &e->value.op.op1->where,
4100 gfc_op2string (e->value.op.op));
4101 return false;
4102 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004103 break;
4104 }
4105
4106 /* Typecheck the new node. */
4107
Tobias Schlüter58b03ab2005-02-23 22:34:11 +01004108 op1 = e->value.op.op1;
4109 op2 = e->value.op.op2;
Thomas König4dc64372020-04-19 12:56:32 +02004110 if (op1 == NULL && op2 == NULL)
4111 return false;
Sandra Loosemoreee11be72021-11-04 15:43:29 -07004112 /* Error out if op2 did not resolve. We already diagnosed op1. */
4113 if (t == false)
4114 return false;
Thomas König4dc64372020-04-19 12:56:32 +02004115
Francois-Xavier Coudert27189292007-03-25 09:01:23 +00004116 dual_locus_error = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004117
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004118 /* op1 and op2 cannot both be BOZ. */
4119 if (op1 && op1->ts.type == BT_BOZ
4120 && op2 && op2->ts.type == BT_BOZ)
4121 {
4122 gfc_error ("Operands at %L and %L cannot appear as operands of "
4123 "binary operator %qs", &op1->where, &op2->where,
4124 gfc_op2string (e->value.op.op));
4125 return false;
4126 }
4127
Tobias Burnusbb9e6832007-07-03 10:02:08 +02004128 if ((op1 && op1->expr_type == EXPR_NULL)
4129 || (op2 && op2->expr_type == EXPR_NULL))
4130 {
Tobias Burnusb1790262021-03-24 07:50:22 +01004131 snprintf (msg, sizeof (msg),
4132 _("Invalid context for NULL() pointer at %%L"));
Tobias Burnusbb9e6832007-07-03 10:02:08 +02004133 goto bad_op;
4134 }
4135
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +00004136 switch (e->value.op.op)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004137 {
4138 case INTRINSIC_UPLUS:
4139 case INTRINSIC_UMINUS:
4140 if (op1->ts.type == BT_INTEGER
4141 || op1->ts.type == BT_REAL
4142 || op1->ts.type == BT_COMPLEX)
4143 {
4144 e->ts = op1->ts;
4145 break;
4146 }
4147
Tobias Burnusb1790262021-03-24 07:50:22 +01004148 snprintf (msg, sizeof (msg),
4149 _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
4150 gfc_op2string (e->value.op.op), gfc_typename (e));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004151 goto bad_op;
4152
4153 case INTRINSIC_PLUS:
4154 case INTRINSIC_MINUS:
4155 case INTRINSIC_TIMES:
4156 case INTRINSIC_DIVIDE:
4157 case INTRINSIC_POWER:
4158 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4159 {
Daniel Frankedcea1b22009-12-11 16:08:39 -05004160 gfc_type_convert_binary (e, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04004161 break;
4162 }
4163
Steven G. Kargl1dd88f82018-06-09 15:58:24 +00004164 if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
Tobias Burnusb1790262021-03-24 07:50:22 +01004165 snprintf (msg, sizeof (msg),
4166 _("Unexpected derived-type entities in binary intrinsic "
4167 "numeric operator %%<%s%%> at %%L"),
Steven G. Kargl1dd88f82018-06-09 15:58:24 +00004168 gfc_op2string (e->value.op.op));
4169 else
Tobias Burnusb1790262021-03-24 07:50:22 +01004170 snprintf (msg, sizeof(msg),
4171 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
4172 gfc_op2string (e->value.op.op), gfc_typename (op1),
Mark Egglestonf61e54e2019-10-03 09:40:23 +00004173 gfc_typename (op2));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004174 goto bad_op;
4175
4176 case INTRINSIC_CONCAT:
Francois-Xavier Coudertd393bbd2008-05-18 22:45:05 +00004177 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4178 && op1->ts.kind == op2->ts.kind)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004179 {
4180 e->ts.type = BT_CHARACTER;
4181 e->ts.kind = op1->ts.kind;
4182 break;
4183 }
4184
Tobias Burnusb1790262021-03-24 07:50:22 +01004185 snprintf (msg, sizeof (msg),
4186 _("Operands of string concatenation operator at %%L are %s/%s"),
4187 gfc_typename (op1), gfc_typename (op2));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004188 goto bad_op;
4189
4190 case INTRINSIC_AND:
4191 case INTRINSIC_OR:
4192 case INTRINSIC_EQV:
4193 case INTRINSIC_NEQV:
4194 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
4195 {
4196 e->ts.type = BT_LOGICAL;
4197 e->ts.kind = gfc_kind_max (op1, op2);
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004198 if (op1->ts.kind < e->ts.kind)
4199 gfc_convert_type (op1, &e->ts, 2);
4200 else if (op2->ts.kind < e->ts.kind)
4201 gfc_convert_type (op2, &e->ts, 2);
Janus Weil6457b1f2018-07-18 20:31:59 +02004202
Janus Weilbf9197d2018-08-10 16:08:53 +02004203 if (flag_frontend_optimize &&
4204 (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
Janus Weil6457b1f2018-07-18 20:31:59 +02004205 {
4206 /* Warn about short-circuiting
4207 with impure function as second operand. */
4208 bool op2_f = false;
4209 gfc_expr_walker (&op2, impure_function_callback, &op2_f);
4210 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004211 break;
4212 }
4213
Fritz Reesedd90ca32016-10-25 18:27:51 +00004214 /* Logical ops on integers become bitwise ops with -fdec. */
4215 else if (flag_dec
4216 && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER))
4217 {
4218 e->ts.type = BT_INTEGER;
4219 e->ts.kind = gfc_kind_max (op1, op2);
4220 if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind)
4221 gfc_convert_type (op1, &e->ts, 1);
4222 if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind)
4223 gfc_convert_type (op2, &e->ts, 1);
4224 e = logical_to_bitwise (e);
Martin Liska53fcf722019-02-13 14:04:56 +01004225 goto simplify_op;
Fritz Reesedd90ca32016-10-25 18:27:51 +00004226 }
4227
Tobias Burnusb1790262021-03-24 07:50:22 +01004228 snprintf (msg, sizeof (msg),
4229 _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
4230 gfc_op2string (e->value.op.op), gfc_typename (op1),
4231 gfc_typename (op2));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004232
4233 goto bad_op;
4234
4235 case INTRINSIC_NOT:
Fritz Reesedd90ca32016-10-25 18:27:51 +00004236 /* Logical ops on integers become bitwise ops with -fdec. */
4237 if (flag_dec && op1->ts.type == BT_INTEGER)
4238 {
4239 e->ts.type = BT_INTEGER;
4240 e->ts.kind = op1->ts.kind;
4241 e = logical_to_bitwise (e);
Martin Liska53fcf722019-02-13 14:04:56 +01004242 goto simplify_op;
Fritz Reesedd90ca32016-10-25 18:27:51 +00004243 }
4244
Diego Novillo6de9cd92004-05-13 02:41:07 -04004245 if (op1->ts.type == BT_LOGICAL)
4246 {
4247 e->ts.type = BT_LOGICAL;
4248 e->ts.kind = op1->ts.kind;
4249 break;
4250 }
4251
Tobias Burnusb1790262021-03-24 07:50:22 +01004252 snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"),
4253 gfc_typename (op1));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004254 goto bad_op;
4255
4256 case INTRINSIC_GT:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004257 case INTRINSIC_GT_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004258 case INTRINSIC_GE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004259 case INTRINSIC_GE_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004260 case INTRINSIC_LT:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004261 case INTRINSIC_LT_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004262 case INTRINSIC_LE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004263 case INTRINSIC_LE_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004264 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
4265 {
Francois-Xavier Coudert31043f62005-09-17 20:58:01 +02004266 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004267 goto bad_op;
4268 }
4269
Marek Polacek191816a2016-08-12 10:30:47 +00004270 /* Fall through. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04004271
4272 case INTRINSIC_EQ:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004273 case INTRINSIC_EQ_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004274 case INTRINSIC_NE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004275 case INTRINSIC_NE_OS:
Mark Eggleston32bef8f2019-11-25 10:36:25 +00004276
4277 if (flag_dec
4278 && is_character_based (op1->ts.type)
4279 && is_character_based (op2->ts.type))
4280 {
4281 convert_hollerith_to_character (op1);
4282 convert_hollerith_to_character (op2);
4283 }
4284
Francois-Xavier Coudertd393bbd2008-05-18 22:45:05 +00004285 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
4286 && op1->ts.kind == op2->ts.kind)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004287 {
4288 e->ts.type = BT_LOGICAL;
Tobias Schlüter9d64df12004-08-27 16:49:35 +02004289 e->ts.kind = gfc_default_logical_kind;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004290 break;
4291 }
4292
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004293 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
4294 if (op1->ts.type == BT_BOZ)
4295 {
Mark Eggleston0a7183f2020-06-02 08:38:01 +01004296 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
4297 "as an operand of a relational operator"),
4298 &op1->where))
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004299 return false;
4300
4301 if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
4302 return false;
4303
4304 if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind))
4305 return false;
4306 }
4307
4308 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
4309 if (op2->ts.type == BT_BOZ)
4310 {
Mark Eggleston0a7183f2020-06-02 08:38:01 +01004311 if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
4312 " as an operand of a relational operator"),
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004313 &op2->where))
4314 return false;
4315
4316 if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind))
4317 return false;
4318
4319 if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind))
4320 return false;
4321 }
Mark Eggleston32bef8f2019-11-25 10:36:25 +00004322 if (flag_dec
4323 && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts))
4324 convert_to_numeric (op1, op2);
4325
4326 if (flag_dec
4327 && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH)
4328 convert_to_numeric (op2, op1);
Steven G. Kargl878f88b2019-08-10 18:26:13 +00004329
Diego Novillo6de9cd92004-05-13 02:41:07 -04004330 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
4331 {
Daniel Frankedcea1b22009-12-11 16:08:39 -05004332 gfc_type_convert_binary (e, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04004333
4334 e->ts.type = BT_LOGICAL;
Tobias Schlüter9d64df12004-08-27 16:49:35 +02004335 e->ts.kind = gfc_default_logical_kind;
Thomas Koenigcf215512012-08-19 15:05:41 +00004336
Tobias Burnus73e42ee2014-11-30 09:33:25 +01004337 if (warn_compare_reals)
Thomas Koenigcf215512012-08-19 15:05:41 +00004338 {
4339 gfc_intrinsic_op op = e->value.op.op;
4340
4341 /* Type conversion has made sure that the types of op1 and op2
4342 agree, so it is only necessary to check the first one. */
4343 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX)
4344 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS
4345 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS))
4346 {
4347 const char *msg;
4348
4349 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
Mark Eggleston0a7183f2020-06-02 08:38:01 +01004350 msg = G_("Equality comparison for %s at %L");
Thomas Koenigcf215512012-08-19 15:05:41 +00004351 else
Mark Eggleston0a7183f2020-06-02 08:38:01 +01004352 msg = G_("Inequality comparison for %s at %L");
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00004353
Janus Weil28ce22e2016-11-05 11:35:23 +01004354 gfc_warning (OPT_Wcompare_reals, msg,
Mark Egglestonf61e54e2019-10-03 09:40:23 +00004355 gfc_typename (op1), &op1->where);
Thomas Koenigcf215512012-08-19 15:05:41 +00004356 }
4357 }
4358
Diego Novillo6de9cd92004-05-13 02:41:07 -04004359 break;
4360 }
4361
Volker Reichelt6a28f512005-07-27 08:30:46 +00004362 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
Tobias Burnusb1790262021-03-24 07:50:22 +01004363 snprintf (msg, sizeof (msg),
4364 _("Logicals at %%L must be compared with %s instead of %s"),
4365 (e->value.op.op == INTRINSIC_EQ
4366 || e->value.op.op == INTRINSIC_EQ_OS)
4367 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
Volker Reichelt6a28f512005-07-27 08:30:46 +00004368 else
Tobias Burnusb1790262021-03-24 07:50:22 +01004369 snprintf (msg, sizeof (msg),
4370 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
4371 gfc_op2string (e->value.op.op), gfc_typename (op1),
4372 gfc_typename (op2));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004373
4374 goto bad_op;
4375
4376 case INTRINSIC_USER:
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +00004377 if (e->value.op.uop->op == NULL)
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02004378 {
4379 const char *name = e->value.op.uop->name;
4380 const char *guessed;
4381 guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
4382 if (guessed)
Tobias Burnusb1790262021-03-24 07:50:22 +01004383 snprintf (msg, sizeof (msg),
4384 _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
4385 name, guessed);
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02004386 else
Tobias Burnusb1790262021-03-24 07:50:22 +01004387 snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"),
4388 name);
Bernhard Reutner-Fischerbcc478b2017-10-19 09:24:33 +02004389 }
Daniel Franke622af872007-06-29 15:05:58 -04004390 else if (op2 == NULL)
Tobias Burnusb1790262021-03-24 07:50:22 +01004391 snprintf (msg, sizeof (msg),
4392 _("Operand of user operator %%<%s%%> at %%L is %s"),
4393 e->value.op.uop->name, gfc_typename (op1));
Diego Novillo6de9cd92004-05-13 02:41:07 -04004394 else
Thomas Koenig7c1a49f2010-12-31 11:20:22 +00004395 {
Tobias Burnusb1790262021-03-24 07:50:22 +01004396 snprintf (msg, sizeof (msg),
4397 _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
4398 e->value.op.uop->name, gfc_typename (op1),
4399 gfc_typename (op2));
Thomas Koenig7c1a49f2010-12-31 11:20:22 +00004400 e->value.op.uop->op->sym->attr.referenced = 1;
4401 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004402
4403 goto bad_op;
4404
Tobias Schlüter2414e1d2006-02-10 01:10:47 +01004405 case INTRINSIC_PARENTHESES:
Tobias Schlüterdcdc83a2007-10-04 09:34:38 +02004406 e->ts = op1->ts;
4407 if (e->ts.type == BT_CHARACTER)
Janus Weilbc21d312009-08-13 21:46:46 +02004408 e->ts.u.cl = op1->ts.u.cl;
Tobias Schlüter2414e1d2006-02-10 01:10:47 +01004409 break;
4410
Diego Novillo6de9cd92004-05-13 02:41:07 -04004411 default:
4412 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4413 }
4414
4415 /* Deal with arrayness of an operand through an operator. */
4416
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +00004417 switch (e->value.op.op)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004418 {
4419 case INTRINSIC_PLUS:
4420 case INTRINSIC_MINUS:
4421 case INTRINSIC_TIMES:
4422 case INTRINSIC_DIVIDE:
4423 case INTRINSIC_POWER:
4424 case INTRINSIC_CONCAT:
4425 case INTRINSIC_AND:
4426 case INTRINSIC_OR:
4427 case INTRINSIC_EQV:
4428 case INTRINSIC_NEQV:
4429 case INTRINSIC_EQ:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004430 case INTRINSIC_EQ_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004431 case INTRINSIC_NE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004432 case INTRINSIC_NE_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004433 case INTRINSIC_GT:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004434 case INTRINSIC_GT_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004435 case INTRINSIC_GE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004436 case INTRINSIC_GE_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004437 case INTRINSIC_LT:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004438 case INTRINSIC_LT_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004439 case INTRINSIC_LE:
Daniel Franke3bed9dd2007-07-08 17:08:52 -04004440 case INTRINSIC_LE_OS:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004441
4442 if (op1->rank == 0 && op2->rank == 0)
4443 e->rank = 0;
4444
4445 if (op1->rank == 0 && op2->rank != 0)
4446 {
4447 e->rank = op2->rank;
4448
4449 if (e->shape == NULL)
4450 e->shape = gfc_copy_shape (op2->shape, op2->rank);
4451 }
4452
4453 if (op1->rank != 0 && op2->rank == 0)
4454 {
4455 e->rank = op1->rank;
4456
4457 if (e->shape == NULL)
4458 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4459 }
4460
4461 if (op1->rank != 0 && op2->rank != 0)
4462 {
4463 if (op1->rank == op2->rank)
4464 {
4465 e->rank = op1->rank;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004466 if (e->shape == NULL)
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00004467 {
Steven G. Kargld1d7b042010-06-11 00:06:30 +00004468 t = compare_shapes (op1, op2);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004469 if (!t)
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00004470 e->shape = NULL;
4471 else
Steven G. Kargld1d7b042010-06-11 00:06:30 +00004472 e->shape = gfc_copy_shape (op1->shape, op1->rank);
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00004473 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004474 }
4475 else
4476 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004477 /* Allow higher level expressions to work. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04004478 e->rank = 0;
Francois-Xavier Coudert27189292007-03-25 09:01:23 +00004479
4480 /* Try user-defined operators, and otherwise throw an error. */
4481 dual_locus_error = true;
Tobias Burnusb1790262021-03-24 07:50:22 +01004482 snprintf (msg, sizeof (msg),
4483 _("Inconsistent ranks for operator at %%L and %%L"));
Francois-Xavier Coudert27189292007-03-25 09:01:23 +00004484 goto bad_op;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004485 }
4486 }
4487
4488 break;
4489
Paul Thomas08113c72007-07-24 19:15:27 +00004490 case INTRINSIC_PARENTHESES:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004491 case INTRINSIC_NOT:
4492 case INTRINSIC_UPLUS:
4493 case INTRINSIC_UMINUS:
Paul Thomas08113c72007-07-24 19:15:27 +00004494 /* Simply copy arrayness attribute */
Diego Novillo6de9cd92004-05-13 02:41:07 -04004495 e->rank = op1->rank;
4496
4497 if (e->shape == NULL)
4498 e->shape = gfc_copy_shape (op1->shape, op1->rank);
4499
Diego Novillo6de9cd92004-05-13 02:41:07 -04004500 break;
4501
4502 default:
4503 break;
4504 }
4505
Martin Liska53fcf722019-02-13 14:04:56 +01004506simplify_op:
4507
Diego Novillo6de9cd92004-05-13 02:41:07 -04004508 /* Attempt to simplify the expression. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004509 if (t)
Paul Thomasdd5ecf42006-12-04 19:30:33 +00004510 {
4511 t = gfc_simplify_expr (e, 0);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004512 /* Some calls do not succeed in simplification and return false
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +00004513 even though there is no error; e.g. variable references to
Paul Thomasdd5ecf42006-12-04 19:30:33 +00004514 PARAMETER arrays. */
4515 if (!gfc_is_constant_expr (e))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004516 t = true;
Paul Thomasdd5ecf42006-12-04 19:30:33 +00004517 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004518 return t;
4519
4520bad_op:
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00004521
Daniel Kraft4a44a722009-08-27 13:42:56 +02004522 {
Janus Weileaee02a2011-11-06 22:36:54 +01004523 match m = gfc_extend_expr (e);
4524 if (m == MATCH_YES)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004525 return true;
Janus Weileaee02a2011-11-06 22:36:54 +01004526 if (m == MATCH_ERROR)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004527 return false;
Daniel Kraft4a44a722009-08-27 13:42:56 +02004528 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004529
Francois-Xavier Coudert27189292007-03-25 09:01:23 +00004530 if (dual_locus_error)
4531 gfc_error (msg, &op1->where, &op2->where);
4532 else
4533 gfc_error (msg, &e->where);
Steven G. Kargl2c5ed582005-03-05 22:13:21 +00004534
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004535 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004536}
4537
4538
4539/************** Array resolution subroutines **************/
4540
Trevor Saundersa79683d2015-08-19 02:48:48 +00004541enum compare_result
4542{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN };
Diego Novillo6de9cd92004-05-13 02:41:07 -04004543
4544/* Compare two integer expressions. */
4545
Martin Liskaff5ed3f2015-02-26 21:18:08 +01004546static compare_result
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004547compare_bound (gfc_expr *a, gfc_expr *b)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004548{
4549 int i;
4550
4551 if (a == NULL || a->expr_type != EXPR_CONSTANT
4552 || b == NULL || b->expr_type != EXPR_CONSTANT)
4553 return CMP_UNKNOWN;
4554
Thomas Koenigdf80a452007-12-16 21:09:34 +00004555 /* If either of the types isn't INTEGER, we must have
4556 raised an error earlier. */
4557
Diego Novillo6de9cd92004-05-13 02:41:07 -04004558 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
Thomas Koenigdf80a452007-12-16 21:09:34 +00004559 return CMP_UNKNOWN;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004560
4561 i = mpz_cmp (a->value.integer, b->value.integer);
4562
4563 if (i < 0)
4564 return CMP_LT;
4565 if (i > 0)
4566 return CMP_GT;
4567 return CMP_EQ;
4568}
4569
4570
4571/* Compare an integer expression with an integer. */
4572
Martin Liskaff5ed3f2015-02-26 21:18:08 +01004573static compare_result
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004574compare_bound_int (gfc_expr *a, int b)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004575{
4576 int i;
4577
4578 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4579 return CMP_UNKNOWN;
4580
4581 if (a->ts.type != BT_INTEGER)
4582 gfc_internal_error ("compare_bound_int(): Bad expression");
4583
4584 i = mpz_cmp_si (a->value.integer, b);
4585
4586 if (i < 0)
4587 return CMP_LT;
4588 if (i > 0)
4589 return CMP_GT;
4590 return CMP_EQ;
4591}
4592
4593
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004594/* Compare an integer expression with a mpz_t. */
4595
Martin Liskaff5ed3f2015-02-26 21:18:08 +01004596static compare_result
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004597compare_bound_mpz_t (gfc_expr *a, mpz_t b)
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004598{
4599 int i;
4600
4601 if (a == NULL || a->expr_type != EXPR_CONSTANT)
4602 return CMP_UNKNOWN;
4603
4604 if (a->ts.type != BT_INTEGER)
4605 gfc_internal_error ("compare_bound_int(): Bad expression");
4606
4607 i = mpz_cmp (a->value.integer, b);
4608
4609 if (i < 0)
4610 return CMP_LT;
4611 if (i > 0)
4612 return CMP_GT;
4613 return CMP_EQ;
4614}
4615
4616
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00004617/* Compute the last value of a sequence given by a triplet.
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004618 Return 0 if it wasn't able to compute the last value, or if the
4619 sequence if empty, and 1 otherwise. */
4620
4621static int
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004622compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
4623 gfc_expr *stride, mpz_t last)
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004624{
4625 mpz_t rem;
4626
4627 if (start == NULL || start->expr_type != EXPR_CONSTANT
4628 || end == NULL || end->expr_type != EXPR_CONSTANT
4629 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
4630 return 0;
4631
4632 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
4633 || (stride != NULL && stride->ts.type != BT_INTEGER))
4634 return 0;
4635
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004636 if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ)
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004637 {
4638 if (compare_bound (start, end) == CMP_GT)
4639 return 0;
4640 mpz_set (last, end->value.integer);
4641 return 1;
4642 }
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02004643
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004644 if (compare_bound_int (stride, 0) == CMP_GT)
4645 {
4646 /* Stride is positive */
4647 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
4648 return 0;
4649 }
4650 else
4651 {
4652 /* Stride is negative */
4653 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
4654 return 0;
4655 }
4656
4657 mpz_init (rem);
4658 mpz_sub (rem, end->value.integer, start->value.integer);
4659 mpz_tdiv_r (rem, rem, stride->value.integer);
4660 mpz_sub (last, end->value.integer, rem);
4661 mpz_clear (rem);
4662
4663 return 1;
4664}
4665
4666
Diego Novillo6de9cd92004-05-13 02:41:07 -04004667/* Compare a single dimension of an array reference to the array
4668 specification. */
4669
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004670static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004671check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004672{
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004673 mpz_t last_value;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004674
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004675 if (ar->dimen_type[i] == DIMEN_STAR)
4676 {
4677 gcc_assert (ar->stride[i] == NULL);
4678 /* This implies [*] as [*:] and [*:3] are not possible. */
4679 if (ar->start[i] == NULL)
4680 {
4681 gcc_assert (ar->end[i] == NULL);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004682 return true;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004683 }
4684 }
4685
Diego Novillo6de9cd92004-05-13 02:41:07 -04004686/* Given start, end and stride values, calculate the minimum and
Kazu Hirataf7b529f2004-11-08 14:56:41 +00004687 maximum referenced indexes. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04004688
Tobias Burnus1954a272007-10-14 22:24:20 +02004689 switch (ar->dimen_type[i])
Diego Novillo6de9cd92004-05-13 02:41:07 -04004690 {
Tobias Burnus1954a272007-10-14 22:24:20 +02004691 case DIMEN_VECTOR:
Tobias Burnusa3935ff2011-04-04 20:35:13 +02004692 case DIMEN_THIS_IMAGE:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004693 break;
4694
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004695 case DIMEN_STAR:
Tobias Burnus1954a272007-10-14 22:24:20 +02004696 case DIMEN_ELEMENT:
Diego Novillo6de9cd92004-05-13 02:41:07 -04004697 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
Tobias Burnus1954a272007-10-14 22:24:20 +02004698 {
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004699 if (i < as->rank)
Joseph Myersdb30e212015-02-01 00:29:54 +00004700 gfc_warning (0, "Array reference at %L is out of bounds "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004701 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4702 mpz_get_si (ar->start[i]->value.integer),
4703 mpz_get_si (as->lower[i]->value.integer), i+1);
4704 else
Joseph Myersdb30e212015-02-01 00:29:54 +00004705 gfc_warning (0, "Array reference at %L is out of bounds "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004706 "(%ld < %ld) in codimension %d", &ar->c_where[i],
4707 mpz_get_si (ar->start[i]->value.integer),
4708 mpz_get_si (as->lower[i]->value.integer),
4709 i + 1 - as->rank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004710 return true;
Tobias Burnus1954a272007-10-14 22:24:20 +02004711 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004712 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
Tobias Burnus1954a272007-10-14 22:24:20 +02004713 {
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004714 if (i < as->rank)
Joseph Myersdb30e212015-02-01 00:29:54 +00004715 gfc_warning (0, "Array reference at %L is out of bounds "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004716 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4717 mpz_get_si (ar->start[i]->value.integer),
4718 mpz_get_si (as->upper[i]->value.integer), i+1);
4719 else
Joseph Myersdb30e212015-02-01 00:29:54 +00004720 gfc_warning (0, "Array reference at %L is out of bounds "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004721 "(%ld > %ld) in codimension %d", &ar->c_where[i],
4722 mpz_get_si (ar->start[i]->value.integer),
4723 mpz_get_si (as->upper[i]->value.integer),
4724 i + 1 - as->rank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004725 return true;
Tobias Burnus1954a272007-10-14 22:24:20 +02004726 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004727
4728 break;
4729
Tobias Burnus1954a272007-10-14 22:24:20 +02004730 case DIMEN_RANGE:
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004731 {
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004732#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4733#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4734
Martin Liskaff5ed3f2015-02-26 21:18:08 +01004735 compare_result comp_start_end = compare_bound (AR_START, AR_END);
Diego Novillo6de9cd92004-05-13 02:41:07 -04004736
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004737 /* Check for zero stride, which is not allowed. */
4738 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
4739 {
4740 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004741 return false;
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004742 }
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004743
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004744 /* if start == len || (stride > 0 && start < len)
4745 || (stride < 0 && start > len),
4746 then the array section contains at least one element. In this
4747 case, there is an out-of-bounds access if
4748 (start < lower || start > upper). */
4749 if (compare_bound (AR_START, AR_END) == CMP_EQ
4750 || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
4751 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
4752 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
4753 && comp_start_end == CMP_GT))
4754 {
Tobias Burnus1954a272007-10-14 22:24:20 +02004755 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
4756 {
Joseph Myersdb30e212015-02-01 00:29:54 +00004757 gfc_warning (0, "Lower array reference at %L is out of bounds "
Tobias Burnus1954a272007-10-14 22:24:20 +02004758 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4759 mpz_get_si (AR_START->value.integer),
4760 mpz_get_si (as->lower[i]->value.integer), i+1);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004761 return true;
Tobias Burnus1954a272007-10-14 22:24:20 +02004762 }
4763 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
4764 {
Joseph Myersdb30e212015-02-01 00:29:54 +00004765 gfc_warning (0, "Lower array reference at %L is out of bounds "
Tobias Burnus1954a272007-10-14 22:24:20 +02004766 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4767 mpz_get_si (AR_START->value.integer),
4768 mpz_get_si (as->upper[i]->value.integer), i+1);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004769 return true;
Tobias Burnus1954a272007-10-14 22:24:20 +02004770 }
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004771 }
4772
4773 /* If we can compute the highest index of the array section,
4774 then it also has to be between lower and upper. */
4775 mpz_init (last_value);
4776 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
4777 last_value))
4778 {
Tobias Burnus1954a272007-10-14 22:24:20 +02004779 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT)
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004780 {
Joseph Myersdb30e212015-02-01 00:29:54 +00004781 gfc_warning (0, "Upper array reference at %L is out of bounds "
Tobias Burnus1954a272007-10-14 22:24:20 +02004782 "(%ld < %ld) in dimension %d", &ar->c_where[i],
4783 mpz_get_si (last_value),
4784 mpz_get_si (as->lower[i]->value.integer), i+1);
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004785 mpz_clear (last_value);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004786 return true;
Tobias Burnus1954a272007-10-14 22:24:20 +02004787 }
4788 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
4789 {
Joseph Myersdb30e212015-02-01 00:29:54 +00004790 gfc_warning (0, "Upper array reference at %L is out of bounds "
Tobias Burnus1954a272007-10-14 22:24:20 +02004791 "(%ld > %ld) in dimension %d", &ar->c_where[i],
4792 mpz_get_si (last_value),
4793 mpz_get_si (as->upper[i]->value.integer), i+1);
4794 mpz_clear (last_value);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004795 return true;
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004796 }
4797 }
4798 mpz_clear (last_value);
François-Xavier Coudert0094f362006-06-05 22:41:29 +00004799
4800#undef AR_START
4801#undef AR_END
Francois-Xavier Coudertd9122402007-03-24 20:19:51 +00004802 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04004803 break;
4804
4805 default:
4806 gfc_internal_error ("check_dimension(): Bad array reference");
4807 }
4808
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004809 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004810}
4811
4812
4813/* Compare an array reference with an array specification. */
4814
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004815static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004816compare_spec_to_ref (gfc_array_ref *ar)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004817{
4818 gfc_array_spec *as;
4819 int i;
4820
4821 as = ar->as;
4822 i = as->rank - 1;
4823 /* TODO: Full array sections are only allowed as actual parameters. */
4824 if (as->type == AS_ASSUMED_SIZE
4825 && (/*ar->type == AR_FULL
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004826 ||*/ (ar->type == AR_SECTION
4827 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
Diego Novillo6de9cd92004-05-13 02:41:07 -04004828 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004829 gfc_error ("Rightmost upper bound of assumed size array section "
4830 "not specified at %L", &ar->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004831 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004832 }
4833
4834 if (ar->type == AR_FULL)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004835 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004836
4837 if (as->rank != ar->dimen)
4838 {
4839 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4840 &ar->where, ar->dimen, as->rank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004841 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004842 }
4843
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004844 /* ar->codimen == 0 is a local array. */
4845 if (as->corank != ar->codimen && ar->codimen != 0)
4846 {
4847 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4848 &ar->where, ar->codimen, as->corank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004849 return false;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004850 }
4851
Diego Novillo6de9cd92004-05-13 02:41:07 -04004852 for (i = 0; i < as->rank; i++)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004853 if (!check_dimension (i, ar, as))
4854 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004855
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004856 /* Local access has no coarray spec. */
4857 if (ar->codimen != 0)
4858 for (i = as->rank; i < as->rank + as->corank; i++)
4859 {
Tobias Burnusa3935ff2011-04-04 20:35:13 +02004860 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
4861 && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004862 {
4863 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4864 i + 1 - as->rank, &ar->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004865 return false;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004866 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004867 if (!check_dimension (i, ar, as))
4868 return false;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02004869 }
4870
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004871 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004872}
4873
4874
4875/* Resolve one part of an array index. */
4876
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004877static bool
Richard Guenther92375a22010-04-22 08:34:41 +00004878gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
4879 int force_index_integer_kind)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004880{
4881 gfc_typespec ts;
4882
4883 if (index == NULL)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004884 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004885
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004886 if (!gfc_resolve_expr (index))
4887 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004888
Diego Novillo6de9cd92004-05-13 02:41:07 -04004889 if (check_scalar && index->rank != 0)
4890 {
4891 gfc_error ("Array index at %L must be scalar", &index->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004892 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004893 }
4894
Tobias Schlüteree943062005-03-13 19:46:36 +01004895 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
4896 {
Jerry DeLisleacb388a2008-05-16 16:44:28 +00004897 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4898 &index->where, gfc_basic_typename (index->ts.type));
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004899 return false;
Tobias Schlüteree943062005-03-13 19:46:36 +01004900 }
4901
4902 if (index->ts.type == BT_REAL)
Paul Thomas22c23882014-10-18 14:35:51 +00004903 if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L",
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004904 &index->where))
4905 return false;
Tobias Schlüteree943062005-03-13 19:46:36 +01004906
Richard Guenther92375a22010-04-22 08:34:41 +00004907 if ((index->ts.kind != gfc_index_integer_kind
4908 && force_index_integer_kind)
Tobias Schlüteree943062005-03-13 19:46:36 +01004909 || index->ts.type != BT_INTEGER)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004910 {
Erik Edelmann810306f2006-01-25 20:46:29 +00004911 gfc_clear_ts (&ts);
Diego Novillo6de9cd92004-05-13 02:41:07 -04004912 ts.type = BT_INTEGER;
4913 ts.kind = gfc_index_integer_kind;
4914
4915 gfc_convert_type_warn (index, &ts, 2, 0);
4916 }
4917
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004918 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004919}
4920
Richard Guenther92375a22010-04-22 08:34:41 +00004921/* Resolve one part of an array index. */
4922
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004923bool
Richard Guenther92375a22010-04-22 08:34:41 +00004924gfc_resolve_index (gfc_expr *index, int check_scalar)
4925{
4926 return gfc_resolve_index_1 (index, check_scalar, 1);
4927}
4928
Thomas Koenigbf302222005-08-10 20:16:29 +00004929/* Resolve a dim argument to an intrinsic function. */
4930
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004931bool
Thomas Koenigbf302222005-08-10 20:16:29 +00004932gfc_resolve_dim_arg (gfc_expr *dim)
4933{
4934 if (dim == NULL)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004935 return true;
Thomas Koenigbf302222005-08-10 20:16:29 +00004936
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004937 if (!gfc_resolve_expr (dim))
4938 return false;
Thomas Koenigbf302222005-08-10 20:16:29 +00004939
4940 if (dim->rank != 0)
4941 {
4942 gfc_error ("Argument dim at %L must be scalar", &dim->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004943 return false;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02004944
Thomas Koenigbf302222005-08-10 20:16:29 +00004945 }
Jerry DeLisle33717d52007-11-18 20:53:16 +00004946
Thomas Koenigbf302222005-08-10 20:16:29 +00004947 if (dim->ts.type != BT_INTEGER)
4948 {
4949 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004950 return false;
Thomas Koenigbf302222005-08-10 20:16:29 +00004951 }
Jerry DeLisle33717d52007-11-18 20:53:16 +00004952
Thomas Koenigbf302222005-08-10 20:16:29 +00004953 if (dim->ts.kind != gfc_index_integer_kind)
4954 {
4955 gfc_typespec ts;
4956
Jakub Jelineka79ff092010-02-11 20:47:20 +01004957 gfc_clear_ts (&ts);
Thomas Koenigbf302222005-08-10 20:16:29 +00004958 ts.type = BT_INTEGER;
4959 ts.kind = gfc_index_integer_kind;
4960
4961 gfc_convert_type_warn (dim, &ts, 2, 0);
4962 }
4963
Janne Blomqvist524af0d2013-04-11 00:36:58 +03004964 return true;
Thomas Koenigbf302222005-08-10 20:16:29 +00004965}
Diego Novillo6de9cd92004-05-13 02:41:07 -04004966
4967/* Given an expression that contains array references, update those array
4968 references to point to the right array specifications. While this is
4969 filled in during matching, this information is difficult to save and load
4970 in a module, so we take care of it here.
4971
4972 The idea here is that the original array reference comes from the
4973 base symbol. We traverse the list of reference structures, setting
4974 the stored reference to references. Component references can
4975 provide an additional array specification. */
Paul Thomas85fb1d72021-01-07 17:34:49 +00004976static void
4977resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
Diego Novillo6de9cd92004-05-13 02:41:07 -04004978
Harald Anlauff838d152022-07-18 22:34:53 +02004979static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00004980find_array_spec (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04004981{
4982 gfc_array_spec *as;
4983 gfc_component *c;
4984 gfc_ref *ref;
Paul Thomas16a51cf2019-04-22 06:50:33 +00004985 bool class_as = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04004986
Paul Thomas85fb1d72021-01-07 17:34:49 +00004987 if (e->symtree->n.sym->assoc)
4988 {
4989 if (e->symtree->n.sym->assoc->target)
4990 gfc_resolve_expr (e->symtree->n.sym->assoc->target);
4991 resolve_assoc_var (e->symtree->n.sym, false);
4992 }
4993
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02004994 if (e->symtree->n.sym->ts.type == BT_CLASS)
Paul Thomas16a51cf2019-04-22 06:50:33 +00004995 {
4996 as = CLASS_DATA (e->symtree->n.sym)->as;
4997 class_as = true;
4998 }
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02004999 else
5000 as = e->symtree->n.sym->as;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005001
5002 for (ref = e->ref; ref; ref = ref->next)
5003 switch (ref->type)
5004 {
5005 case REF_ARRAY:
5006 if (as == NULL)
Harald Anlauff838d152022-07-18 22:34:53 +02005007 {
Steve Kargl2eaa0cc2022-11-22 22:31:51 +01005008 locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where;
Harald Anlauff838d152022-07-18 22:34:53 +02005009 gfc_error ("Invalid array reference of a non-array entity at %L",
Steve Kargl2eaa0cc2022-11-22 22:31:51 +01005010 &loc);
Harald Anlauff838d152022-07-18 22:34:53 +02005011 return false;
5012 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005013
5014 ref->u.ar.as = as;
5015 as = NULL;
5016 break;
5017
5018 case REF_COMPONENT:
Tobias Burnus02139672011-12-04 17:33:15 +01005019 c = ref->u.c.component;
Janus Weild4b7d0f2008-08-23 23:04:01 +02005020 if (c->attr.dimension)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005021 {
Paul Thomas16a51cf2019-04-22 06:50:33 +00005022 if (as != NULL && !(class_as && as == c->as))
Diego Novillo6de9cd92004-05-13 02:41:07 -04005023 gfc_internal_error ("find_array_spec(): unused as(1)");
5024 as = c->as;
5025 }
5026
Diego Novillo6de9cd92004-05-13 02:41:07 -04005027 break;
5028
5029 case REF_SUBSTRING:
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00005030 case REF_INQUIRY:
Diego Novillo6de9cd92004-05-13 02:41:07 -04005031 break;
5032 }
5033
5034 if (as != NULL)
5035 gfc_internal_error ("find_array_spec(): unused as(2)");
Harald Anlauff838d152022-07-18 22:34:53 +02005036
5037 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005038}
5039
5040
5041/* Resolve an array reference. */
5042
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005043static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005044resolve_array_ref (gfc_array_ref *ar)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005045{
5046 int i, check_scalar;
Paul Thomasb6398822006-05-15 17:16:26 +00005047 gfc_expr *e;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005048
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02005049 for (i = 0; i < ar->dimen + ar->codimen; i++)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005050 {
5051 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
5052
Richard Guenther92375a22010-04-22 08:34:41 +00005053 /* Do not force gfc_index_integer_kind for the start. We can
5054 do fine with any integer kind. This avoids temporary arrays
5055 created for indexing with a vector. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005056 if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
5057 return false;
5058 if (!gfc_resolve_index (ar->end[i], check_scalar))
5059 return false;
5060 if (!gfc_resolve_index (ar->stride[i], check_scalar))
5061 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005062
Paul Thomasb6398822006-05-15 17:16:26 +00005063 e = ar->start[i];
5064
Diego Novillo6de9cd92004-05-13 02:41:07 -04005065 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
Paul Thomasb6398822006-05-15 17:16:26 +00005066 switch (e->rank)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005067 {
5068 case 0:
5069 ar->dimen_type[i] = DIMEN_ELEMENT;
5070 break;
5071
5072 case 1:
5073 ar->dimen_type[i] = DIMEN_VECTOR;
Paul Thomasb6398822006-05-15 17:16:26 +00005074 if (e->expr_type == EXPR_VARIABLE
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005075 && e->symtree->n.sym->ts.type == BT_DERIVED)
Paul Thomasb6398822006-05-15 17:16:26 +00005076 ar->start[i] = gfc_get_parentheses (e);
Diego Novillo6de9cd92004-05-13 02:41:07 -04005077 break;
5078
5079 default:
5080 gfc_error ("Array index at %L is an array of rank %d",
Paul Thomasb6398822006-05-15 17:16:26 +00005081 &ar->c_where[i], e->rank);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005082 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005083 }
Thomas Koenigee247632010-08-09 19:34:49 +00005084
5085 /* Fill in the upper bound, which may be lower than the
5086 specified one for something like a(2:10:5), which is
5087 identical to a(2:7:5). Only relevant for strides not equal
Thomas Koenig2d27cb42011-08-21 12:02:12 +00005088 to one. Don't try a division by zero. */
Thomas Koenigee247632010-08-09 19:34:49 +00005089 if (ar->dimen_type[i] == DIMEN_RANGE
5090 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT
Thomas Koenig2d27cb42011-08-21 12:02:12 +00005091 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0
5092 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0)
Thomas Koenigee247632010-08-09 19:34:49 +00005093 {
5094 mpz_t size, end;
5095
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005096 if (gfc_ref_dimen_size (ar, i, &size, &end))
Thomas Koenigee247632010-08-09 19:34:49 +00005097 {
5098 if (ar->end[i] == NULL)
5099 {
5100 ar->end[i] =
5101 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5102 &ar->where);
5103 mpz_set (ar->end[i]->value.integer, end);
5104 }
5105 else if (ar->end[i]->ts.type == BT_INTEGER
5106 && ar->end[i]->expr_type == EXPR_CONSTANT)
5107 {
5108 mpz_set (ar->end[i]->value.integer, end);
5109 }
5110 else
5111 gcc_unreachable ();
5112
5113 mpz_clear (size);
5114 mpz_clear (end);
5115 }
5116 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005117 }
5118
Mikael Morin5551a542011-10-07 21:56:11 +02005119 if (ar->type == AR_FULL)
5120 {
5121 if (ar->as->rank == 0)
5122 ar->type = AR_ELEMENT;
5123
5124 /* Make sure array is the same as array(:,:), this way
5125 we don't need to special case all the time. */
5126 ar->dimen = ar->as->rank;
5127 for (i = 0; i < ar->dimen; i++)
5128 {
5129 ar->dimen_type[i] = DIMEN_RANGE;
5130
5131 gcc_assert (ar->start[i] == NULL);
5132 gcc_assert (ar->end[i] == NULL);
5133 gcc_assert (ar->stride[i] == NULL);
5134 }
5135 }
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02005136
Diego Novillo6de9cd92004-05-13 02:41:07 -04005137 /* If the reference type is unknown, figure out what kind it is. */
5138
5139 if (ar->type == AR_UNKNOWN)
5140 {
5141 ar->type = AR_ELEMENT;
5142 for (i = 0; i < ar->dimen; i++)
5143 if (ar->dimen_type[i] == DIMEN_RANGE
5144 || ar->dimen_type[i] == DIMEN_VECTOR)
5145 {
5146 ar->type = AR_SECTION;
5147 break;
5148 }
5149 }
5150
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005151 if (!ar->as->cray_pointee && !compare_spec_to_ref (ar))
5152 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005153
Mikael Morinb78a06b2011-10-07 21:07:04 +02005154 if (ar->as->corank && ar->codimen == 0)
5155 {
5156 int n;
5157 ar->codimen = ar->as->corank;
5158 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
5159 ar->dimen_type[n] = DIMEN_THIS_IMAGE;
5160 }
5161
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005162 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005163}
5164
5165
Harald Anlaufbdd1b1f2021-01-14 20:25:33 +01005166bool
5167gfc_resolve_substring (gfc_ref *ref, bool *equal_length)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005168{
Francois-Xavier Coudertb0c06812009-05-16 16:53:02 +00005169 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5170
Diego Novillo6de9cd92004-05-13 02:41:07 -04005171 if (ref->u.ss.start != NULL)
5172 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005173 if (!gfc_resolve_expr (ref->u.ss.start))
5174 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005175
5176 if (ref->u.ss.start->ts.type != BT_INTEGER)
5177 {
5178 gfc_error ("Substring start index at %L must be of type INTEGER",
5179 &ref->u.ss.start->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005180 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005181 }
5182
5183 if (ref->u.ss.start->rank != 0)
5184 {
5185 gfc_error ("Substring start index at %L must be scalar",
5186 &ref->u.ss.start->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005187 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005188 }
5189
Francois-Xavier Coudert97bca512006-06-24 20:10:47 +02005190 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
5191 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5192 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
Diego Novillo6de9cd92004-05-13 02:41:07 -04005193 {
5194 gfc_error ("Substring start index at %L is less than one",
5195 &ref->u.ss.start->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005196 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005197 }
5198 }
5199
5200 if (ref->u.ss.end != NULL)
5201 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005202 if (!gfc_resolve_expr (ref->u.ss.end))
5203 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005204
5205 if (ref->u.ss.end->ts.type != BT_INTEGER)
5206 {
5207 gfc_error ("Substring end index at %L must be of type INTEGER",
5208 &ref->u.ss.end->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005209 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005210 }
5211
5212 if (ref->u.ss.end->rank != 0)
5213 {
5214 gfc_error ("Substring end index at %L must be scalar",
5215 &ref->u.ss.end->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005216 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005217 }
5218
5219 if (ref->u.ss.length != NULL
Francois-Xavier Coudert97bca512006-06-24 20:10:47 +02005220 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
5221 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5222 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
Diego Novillo6de9cd92004-05-13 02:41:07 -04005223 {
Francois-Xavier Coudert97bca512006-06-24 20:10:47 +02005224 gfc_error ("Substring end index at %L exceeds the string length",
Diego Novillo6de9cd92004-05-13 02:41:07 -04005225 &ref->u.ss.start->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005226 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005227 }
Francois-Xavier Coudertb0c06812009-05-16 16:53:02 +00005228
5229 if (compare_bound_mpz_t (ref->u.ss.end,
5230 gfc_integer_kinds[k].huge) == CMP_GT
5231 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
5232 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
5233 {
5234 gfc_error ("Substring end index at %L is too large",
5235 &ref->u.ss.end->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005236 return false;
Francois-Xavier Coudertb0c06812009-05-16 16:53:02 +00005237 }
Thomas Koenig0335cc32019-01-15 22:18:55 +00005238 /* If the substring has the same length as the original
5239 variable, the reference itself can be deleted. */
5240
5241 if (ref->u.ss.length != NULL
5242 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ
5243 && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ)
5244 *equal_length = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005245 }
5246
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005247 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005248}
5249
5250
Paul Thomas07368af2007-08-30 22:10:55 +00005251/* This function supplies missing substring charlens. */
5252
5253void
5254gfc_resolve_substring_charlen (gfc_expr *e)
5255{
5256 gfc_ref *char_ref;
5257 gfc_expr *start, *end;
Louis Krupp58864d12015-10-06 23:47:18 +00005258 gfc_typespec *ts = NULL;
Harald Anlauf1fe27032019-02-09 17:25:23 +00005259 mpz_t diff;
Paul Thomas07368af2007-08-30 22:10:55 +00005260
5261 for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
Louis Krupp58864d12015-10-06 23:47:18 +00005262 {
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00005263 if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
5264 break;
Louis Krupp58864d12015-10-06 23:47:18 +00005265 if (char_ref->type == REF_COMPONENT)
5266 ts = &char_ref->u.c.component->ts;
5267 }
Paul Thomas07368af2007-08-30 22:10:55 +00005268
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00005269 if (!char_ref || char_ref->type == REF_INQUIRY)
Paul Thomas07368af2007-08-30 22:10:55 +00005270 return;
5271
5272 gcc_assert (char_ref->next == NULL);
5273
Janus Weilbc21d312009-08-13 21:46:46 +02005274 if (e->ts.u.cl)
Paul Thomas07368af2007-08-30 22:10:55 +00005275 {
Janus Weilbc21d312009-08-13 21:46:46 +02005276 if (e->ts.u.cl->length)
5277 gfc_free_expr (e->ts.u.cl->length);
Steven G. Kargl98a819e2015-10-17 16:50:47 +00005278 else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)
Paul Thomas07368af2007-08-30 22:10:55 +00005279 return;
5280 }
5281
Janus Weilbc21d312009-08-13 21:46:46 +02005282 if (!e->ts.u.cl)
Janus Weilb76e28c2009-08-17 11:11:00 +02005283 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
Paul Thomas07368af2007-08-30 22:10:55 +00005284
5285 if (char_ref->u.ss.start)
5286 start = gfc_copy_expr (char_ref->u.ss.start);
5287 else
Janne Blomqvistf6222212018-01-05 21:01:12 +02005288 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
Paul Thomas07368af2007-08-30 22:10:55 +00005289
5290 if (char_ref->u.ss.end)
5291 end = gfc_copy_expr (char_ref->u.ss.end);
5292 else if (e->expr_type == EXPR_VARIABLE)
Louis Krupp58864d12015-10-06 23:47:18 +00005293 {
5294 if (!ts)
5295 ts = &e->symtree->n.sym->ts;
5296 end = gfc_copy_expr (ts->u.cl->length);
5297 }
Paul Thomas07368af2007-08-30 22:10:55 +00005298 else
5299 end = NULL;
5300
5301 if (!start || !end)
Tobias Burnusefb63362012-10-04 19:32:06 +02005302 {
5303 gfc_free_expr (start);
5304 gfc_free_expr (end);
5305 return;
5306 }
Paul Thomas07368af2007-08-30 22:10:55 +00005307
Harald Anlauf1fe27032019-02-09 17:25:23 +00005308 /* Length = (end - start + 1).
5309 Check first whether it has a constant length. */
5310 if (gfc_dep_difference (end, start, &diff))
5311 {
5312 gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
5313 &e->where);
5314
5315 mpz_add_ui (len->value.integer, diff, 1);
5316 mpz_clear (diff);
5317 e->ts.u.cl->length = len;
5318 /* The check for length < 0 is handled below */
5319 }
5320 else
5321 {
5322 e->ts.u.cl->length = gfc_subtract (end, start);
5323 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
5324 gfc_get_int_expr (gfc_charlen_int_kind,
5325 NULL, 1));
5326 }
Paul Thomas07368af2007-08-30 22:10:55 +00005327
Steven G. Kargl98a819e2015-10-17 16:50:47 +00005328 /* F2008, 6.4.1: Both the starting point and the ending point shall
5329 be within the range 1, 2, ..., n unless the starting point exceeds
5330 the ending point, in which case the substring has length zero. */
5331
5332 if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0)
5333 mpz_set_si (e->ts.u.cl->length->value.integer, 0);
5334
Janus Weilbc21d312009-08-13 21:46:46 +02005335 e->ts.u.cl->length->ts.type = BT_INTEGER;
5336 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
Paul Thomas07368af2007-08-30 22:10:55 +00005337
5338 /* Make sure that the length is simplified. */
Janus Weilbc21d312009-08-13 21:46:46 +02005339 gfc_simplify_expr (e->ts.u.cl->length, 1);
5340 gfc_resolve_expr (e->ts.u.cl->length);
Paul Thomas07368af2007-08-30 22:10:55 +00005341}
5342
5343
Diego Novillo6de9cd92004-05-13 02:41:07 -04005344/* Resolve subtype references. */
5345
Tobias Burnusde89b572019-12-20 11:35:20 +00005346bool
5347gfc_resolve_ref (gfc_expr *expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005348{
Paul Thomas9de42a82020-03-08 18:52:35 +00005349 int current_part_dimension, n_components, seen_part_dimension, dim;
5350 gfc_ref *ref, **prev, *array_ref;
Thomas Koenig0335cc32019-01-15 22:18:55 +00005351 bool equal_length;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005352
5353 for (ref = expr->ref; ref; ref = ref->next)
5354 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
5355 {
Harald Anlauff838d152022-07-18 22:34:53 +02005356 if (!find_array_spec (expr))
5357 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005358 break;
5359 }
5360
Martin Liskaa693d9b2019-02-04 14:28:34 +01005361 for (prev = &expr->ref; *prev != NULL;
5362 prev = *prev == NULL ? prev : &(*prev)->next)
Thomas Koenigb9e25702019-01-19 11:03:28 +00005363 switch ((*prev)->type)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005364 {
5365 case REF_ARRAY:
Thomas Koenigb9e25702019-01-19 11:03:28 +00005366 if (!resolve_array_ref (&(*prev)->u.ar))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005367 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005368 break;
5369
5370 case REF_COMPONENT:
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00005371 case REF_INQUIRY:
Diego Novillo6de9cd92004-05-13 02:41:07 -04005372 break;
5373
5374 case REF_SUBSTRING:
Thomas Koenig0335cc32019-01-15 22:18:55 +00005375 equal_length = false;
Harald Anlaufbdd1b1f2021-01-14 20:25:33 +01005376 if (!gfc_resolve_substring (*prev, &equal_length))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005377 return false;
Thomas Koenig0335cc32019-01-15 22:18:55 +00005378
5379 if (expr->expr_type != EXPR_SUBSTRING && equal_length)
5380 {
5381 /* Remove the reference and move the charlen, if any. */
Thomas Koenigb9e25702019-01-19 11:03:28 +00005382 ref = *prev;
Thomas Koenig0335cc32019-01-15 22:18:55 +00005383 *prev = ref->next;
5384 ref->next = NULL;
5385 expr->ts.u.cl = ref->u.ss.length;
5386 ref->u.ss.length = NULL;
5387 gfc_free_ref_list (ref);
5388 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005389 break;
5390 }
5391
5392 /* Check constraints on part references. */
5393
5394 current_part_dimension = 0;
5395 seen_part_dimension = 0;
5396 n_components = 0;
Paul Thomas9de42a82020-03-08 18:52:35 +00005397 array_ref = NULL;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005398
5399 for (ref = expr->ref; ref; ref = ref->next)
5400 {
5401 switch (ref->type)
5402 {
5403 case REF_ARRAY:
Paul Thomas9de42a82020-03-08 18:52:35 +00005404 array_ref = ref;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005405 switch (ref->u.ar.type)
5406 {
5407 case AR_FULL:
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02005408 /* Coarray scalar. */
5409 if (ref->u.ar.as->rank == 0)
5410 {
5411 current_part_dimension = 0;
5412 break;
5413 }
5414 /* Fall through. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04005415 case AR_SECTION:
5416 current_part_dimension = 1;
5417 break;
5418
5419 case AR_ELEMENT:
Paul Thomas9de42a82020-03-08 18:52:35 +00005420 array_ref = NULL;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005421 current_part_dimension = 0;
5422 break;
5423
5424 case AR_UNKNOWN:
5425 gfc_internal_error ("resolve_ref(): Bad array reference");
5426 }
5427
5428 break;
5429
5430 case REF_COMPONENT:
Erik Edelmann51f824b2006-11-19 21:27:16 +00005431 if (current_part_dimension || seen_part_dimension)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005432 {
Janus Weilef2bbc82009-11-11 23:37:31 +01005433 /* F03:C614. */
5434 if (ref->u.c.component->attr.pointer
Paul Thomas8f75db92012-05-05 08:49:43 +00005435 || ref->u.c.component->attr.proc_pointer
5436 || (ref->u.c.component->ts.type == BT_CLASS
5437 && CLASS_DATA (ref->u.c.component)->attr.pointer))
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005438 {
5439 gfc_error ("Component to the right of a part reference "
5440 "with nonzero rank must not have the POINTER "
5441 "attribute at %L", &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005442 return false;
Erik Edelmann51f824b2006-11-19 21:27:16 +00005443 }
Paul Thomas8f75db92012-05-05 08:49:43 +00005444 else if (ref->u.c.component->attr.allocatable
5445 || (ref->u.c.component->ts.type == BT_CLASS
5446 && CLASS_DATA (ref->u.c.component)->attr.allocatable))
5447
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005448 {
5449 gfc_error ("Component to the right of a part reference "
5450 "with nonzero rank must not have the ALLOCATABLE "
5451 "attribute at %L", &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005452 return false;
Erik Edelmann51f824b2006-11-19 21:27:16 +00005453 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005454 }
5455
5456 n_components++;
5457 break;
5458
5459 case REF_SUBSTRING:
Paul Thomas9de42a82020-03-08 18:52:35 +00005460 break;
5461
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00005462 case REF_INQUIRY:
Paul Thomas9de42a82020-03-08 18:52:35 +00005463 /* Implement requirement in note 9.7 of F2018 that the result of the
5464 LEN inquiry be a scalar. */
Mark Egglestonb0d84ec2020-03-23 14:42:20 +00005465 if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred)
Paul Thomas9de42a82020-03-08 18:52:35 +00005466 {
5467 array_ref->u.ar.type = AR_ELEMENT;
5468 expr->rank = 0;
Jakub Jelinek700d4cb2020-03-17 13:52:19 +01005469 /* INQUIRY_LEN is not evaluated from the rest of the expr
Paul Thomas9de42a82020-03-08 18:52:35 +00005470 but directly from the string length. This means that setting
5471 the array indices to one does not matter but might trigger
5472 a runtime bounds error. Suppress the check. */
5473 expr->no_bounds_check = 1;
5474 for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
5475 {
5476 array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
5477 if (array_ref->u.ar.start[dim])
5478 gfc_free_expr (array_ref->u.ar.start[dim]);
5479 array_ref->u.ar.start[dim]
5480 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5481 if (array_ref->u.ar.end[dim])
5482 gfc_free_expr (array_ref->u.ar.end[dim]);
5483 if (array_ref->u.ar.stride[dim])
5484 gfc_free_expr (array_ref->u.ar.stride[dim]);
5485 }
5486 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005487 break;
5488 }
5489
5490 if (((ref->type == REF_COMPONENT && n_components > 1)
5491 || ref->next == NULL)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005492 && current_part_dimension
Diego Novillo6de9cd92004-05-13 02:41:07 -04005493 && seen_part_dimension)
5494 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04005495 gfc_error ("Two or more part references with nonzero rank must "
5496 "not be specified at %L", &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005497 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005498 }
5499
5500 if (ref->type == REF_COMPONENT)
5501 {
5502 if (current_part_dimension)
5503 seen_part_dimension = 1;
5504
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005505 /* reset to make sure */
Diego Novillo6de9cd92004-05-13 02:41:07 -04005506 current_part_dimension = 0;
5507 }
5508 }
5509
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005510 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005511}
5512
5513
5514/* Given an expression, determine its shape. This is easier than it sounds.
Kazu Hirataf7b529f2004-11-08 14:56:41 +00005515 Leaves the shape array NULL if it is not possible to determine the shape. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04005516
5517static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005518expression_shape (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005519{
5520 mpz_t array[GFC_MAX_DIMENSIONS];
5521 int i;
5522
Tobias Burnusc62c6622012-07-20 07:56:37 +02005523 if (e->rank <= 0 || e->shape != NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005524 return;
5525
5526 for (i = 0; i < e->rank; i++)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005527 if (!gfc_array_dimen_size (e, i, &array[i]))
Diego Novillo6de9cd92004-05-13 02:41:07 -04005528 goto fail;
5529
5530 e->shape = gfc_get_shape (e->rank);
5531
5532 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
5533
5534 return;
5535
5536fail:
5537 for (i--; i >= 0; i--)
5538 mpz_clear (array[i]);
5539}
5540
5541
5542/* Given a variable expression node, compute the rank of the expression by
5543 examining the base symbol and any reference structures it may have. */
5544
Andre Vehreschild76fe9322016-02-11 17:48:45 +01005545void
Tobias Burnusde89b572019-12-20 11:35:20 +00005546gfc_expression_rank (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005547{
5548 gfc_ref *ref;
5549 int i, rank;
5550
Daniel Kraft00ca6642008-09-09 20:08:08 +02005551 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5552 could lead to serious confusion... */
5553 gcc_assert (e->expr_type != EXPR_COMPCALL);
5554
Diego Novillo6de9cd92004-05-13 02:41:07 -04005555 if (e->ref == NULL)
5556 {
5557 if (e->expr_type == EXPR_ARRAY)
5558 goto done;
Kazu Hirataf7b529f2004-11-08 14:56:41 +00005559 /* Constructors can have a rank different from one via RESHAPE(). */
Diego Novillo6de9cd92004-05-13 02:41:07 -04005560
Tobias Burnusde89b572019-12-20 11:35:20 +00005561 e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL)
5562 ? 0 : e->symtree->n.sym->as->rank);
Diego Novillo6de9cd92004-05-13 02:41:07 -04005563 goto done;
5564 }
5565
5566 rank = 0;
5567
5568 for (ref = e->ref; ref; ref = ref->next)
5569 {
Janus Weil2d300fa2011-01-18 23:40:33 +01005570 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer
5571 && ref->u.c.component->attr.function && !ref->next)
5572 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0;
5573
Diego Novillo6de9cd92004-05-13 02:41:07 -04005574 if (ref->type != REF_ARRAY)
5575 continue;
5576
5577 if (ref->u.ar.type == AR_FULL)
5578 {
5579 rank = ref->u.ar.as->rank;
5580 break;
5581 }
5582
5583 if (ref->u.ar.type == AR_SECTION)
5584 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005585 /* Figure out the rank of the section. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04005586 if (rank != 0)
Tobias Burnusde89b572019-12-20 11:35:20 +00005587 gfc_internal_error ("gfc_expression_rank(): Two array specs");
Diego Novillo6de9cd92004-05-13 02:41:07 -04005588
5589 for (i = 0; i < ref->u.ar.dimen; i++)
5590 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5591 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5592 rank++;
5593
5594 break;
5595 }
5596 }
5597
5598 e->rank = rank;
5599
5600done:
5601 expression_shape (e);
5602}
5603
5604
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02005605static void
5606add_caf_get_intrinsic (gfc_expr *e)
5607{
5608 gfc_expr *wrapper, *tmp_expr;
5609 gfc_ref *ref;
5610 int n;
5611
5612 for (ref = e->ref; ref; ref = ref->next)
5613 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5614 break;
5615 if (ref == NULL)
5616 return;
5617
5618 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5619 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
5620 return;
5621
5622 tmp_expr = XCNEW (gfc_expr);
5623 *tmp_expr = *e;
5624 wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
5625 "caf_get", tmp_expr->where, 1, tmp_expr);
5626 wrapper->ts = e->ts;
5627 wrapper->rank = e->rank;
5628 if (e->rank)
5629 wrapper->shape = gfc_copy_shape (e->shape, e->rank);
5630 *e = *wrapper;
5631 free (wrapper);
5632}
5633
5634
5635static void
5636remove_caf_get_intrinsic (gfc_expr *e)
5637{
5638 gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
5639 && e->value.function.isym->id == GFC_ISYM_CAF_GET);
5640 gfc_expr *e2 = e->value.function.actual->expr;
Tobias Burnusb5116262014-06-17 22:54:14 +02005641 e->value.function.actual->expr = NULL;
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02005642 gfc_free_actual_arglist (e->value.function.actual);
5643 gfc_free_shape (&e->shape, e->rank);
5644 *e = *e2;
5645 free (e2);
5646}
5647
5648
Diego Novillo6de9cd92004-05-13 02:41:07 -04005649/* Resolve a variable expression. */
5650
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005651static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005652resolve_variable (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04005653{
5654 gfc_symbol *sym;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005655 bool t;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005656
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005657 t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005658
Paul Thomas3e978d32006-08-20 05:45:43 +00005659 if (e->symtree == NULL)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005660 return false;
Daniel Kraft52bf62f2010-08-15 21:46:21 +02005661 sym = e->symtree->n.sym;
5662
Tobias Burnuse7ac6a72013-04-16 22:54:21 +02005663 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
5664 as ts.type is set to BT_ASSUMED in resolve_symbol. */
5665 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
5666 {
5667 if (!actual_arg || inquiry_argument)
5668 {
5669 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
5670 "be used as actual argument", sym->name, &e->where);
5671 return false;
5672 }
5673 }
Tobias Burnus45a69322012-03-03 09:40:24 +01005674 /* TS 29113, 407b. */
Tobias Burnuse7ac6a72013-04-16 22:54:21 +02005675 else if (e->ts.type == BT_ASSUMED)
Tobias Burnus45a69322012-03-03 09:40:24 +01005676 {
Tobias Burnusc62c6622012-07-20 07:56:37 +02005677 if (!actual_arg)
5678 {
5679 gfc_error ("Assumed-type variable %s at %L may only be used "
5680 "as actual argument", sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005681 return false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02005682 }
5683 else if (inquiry_argument && !first_actual_arg)
5684 {
5685 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5686 for all inquiry functions in resolve_function; the reason is
5687 that the function-name resolution happens too late in that
5688 function. */
5689 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5690 "an inquiry function shall be the first argument",
5691 sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005692 return false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02005693 }
5694 }
Tobias Burnusc62c6622012-07-20 07:56:37 +02005695 /* TS 29113, C535b. */
Paul Thomas70570ec2019-09-01 12:53:02 +00005696 else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +02005697 && sym->ts.u.derived && CLASS_DATA (sym)
Paul Thomas70570ec2019-09-01 12:53:02 +00005698 && CLASS_DATA (sym)->as
5699 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5700 || (sym->ts.type != BT_CLASS && sym->as
5701 && sym->as->type == AS_ASSUMED_RANK))
5702 && !sym->attr.select_rank_temporary)
Tobias Burnusc62c6622012-07-20 07:56:37 +02005703 {
Paul Thomas70570ec2019-09-01 12:53:02 +00005704 if (!actual_arg
5705 && !(cs_base && cs_base->current
5706 && cs_base->current->op == EXEC_SELECT_RANK))
Tobias Burnusc62c6622012-07-20 07:56:37 +02005707 {
5708 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5709 "actual argument", sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005710 return false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02005711 }
5712 else if (inquiry_argument && !first_actual_arg)
5713 {
5714 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5715 for all inquiry functions in resolve_function; the reason is
5716 that the function-name resolution happens too late in that
5717 function. */
5718 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5719 "to an inquiry function shall be the first argument",
5720 sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005721 return false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02005722 }
Tobias Burnus45a69322012-03-03 09:40:24 +01005723 }
5724
Tobias Burnuse7ac6a72013-04-16 22:54:21 +02005725 if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref
Tobias Burnus45a69322012-03-03 09:40:24 +01005726 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
Tobias Burnusc62c6622012-07-20 07:56:37 +02005727 && e->ref->next == NULL))
Tobias Burnus45a69322012-03-03 09:40:24 +01005728 {
Tobias Burnuse7ac6a72013-04-16 22:54:21 +02005729 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
5730 "a subobject reference", sym->name, &e->ref->u.ar.where);
5731 return false;
5732 }
5733 /* TS 29113, 407b. */
5734 else if (e->ts.type == BT_ASSUMED && e->ref
5735 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5736 && e->ref->next == NULL))
5737 {
Tobias Burnusc62c6622012-07-20 07:56:37 +02005738 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5739 "reference", sym->name, &e->ref->u.ar.where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005740 return false;
Tobias Burnus45a69322012-03-03 09:40:24 +01005741 }
5742
Tobias Burnusc62c6622012-07-20 07:56:37 +02005743 /* TS 29113, C535b. */
5744 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +02005745 && sym->ts.u.derived && CLASS_DATA (sym)
Tobias Burnusc62c6622012-07-20 07:56:37 +02005746 && CLASS_DATA (sym)->as
5747 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
5748 || (sym->ts.type != BT_CLASS && sym->as
5749 && sym->as->type == AS_ASSUMED_RANK))
5750 && e->ref
5751 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
5752 && e->ref->next == NULL))
5753 {
5754 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5755 "reference", sym->name, &e->ref->u.ar.where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005756 return false;
Tobias Burnusc62c6622012-07-20 07:56:37 +02005757 }
5758
Andre Vehreschild76540ac2015-06-23 11:07:22 +02005759 /* For variables that are used in an associate (target => object) where
5760 the object's basetype is array valued while the target is scalar,
5761 the ts' type of the component refs is still array valued, which
5762 can't be translated that way. */
5763 if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
Paul Thomas51a025fb2018-11-24 09:07:23 +00005764 && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
Harald Anlaufd8f6c482021-12-27 23:06:18 +01005765 && sym->assoc->target->ts.u.derived
5766 && CLASS_DATA (sym->assoc->target)
Andre Vehreschild76540ac2015-06-23 11:07:22 +02005767 && CLASS_DATA (sym->assoc->target)->as)
5768 {
5769 gfc_ref *ref = e->ref;
5770 while (ref)
5771 {
5772 switch (ref->type)
5773 {
5774 case REF_COMPONENT:
5775 ref->u.c.sym = sym->ts.u.derived;
5776 /* Stop the loop. */
5777 ref = NULL;
5778 break;
5779 default:
5780 ref = ref->next;
5781 break;
5782 }
5783 }
5784 }
Tobias Burnusc62c6622012-07-20 07:56:37 +02005785
Daniel Kraft3e782382010-08-26 21:48:43 +02005786 /* If this is an associate-name, it may be parsed with an array reference
Paul Thomas8f75db92012-05-05 08:49:43 +00005787 in error even though the target is scalar. Fail directly in this case.
5788 TODO Understand why class scalar expressions must be excluded. */
5789 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0))
5790 {
5791 if (sym->ts.type == BT_CLASS)
5792 gfc_fix_class_refs (e);
5793 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005794 return false;
Paul Thomasece66522018-10-17 07:16:16 +00005795 else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
5796 {
5797 /* This can happen because the parser did not detect that the
5798 associate name is an array and the expression had no array
5799 part_ref. */
5800 gfc_ref *ref = gfc_get_ref ();
5801 ref->type = REF_ARRAY;
Paul Thomasece66522018-10-17 07:16:16 +00005802 ref->u.ar.type = AR_FULL;
5803 if (sym->as)
5804 {
5805 ref->u.ar.as = sym->as;
5806 ref->u.ar.dimen = sym->as->rank;
5807 }
5808 ref->next = e->ref;
5809 e->ref = ref;
5810
5811 }
Paul Thomas8f75db92012-05-05 08:49:43 +00005812 }
Daniel Kraft52bf62f2010-08-15 21:46:21 +02005813
Tobias Burnusc3f34952011-11-16 22:37:43 +01005814 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
5815 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
5816
Daniel Kraft52bf62f2010-08-15 21:46:21 +02005817 /* On the other hand, the parser may not have known this is an array;
5818 in this case, we have to add a FULL reference. */
5819 if (sym->assoc && sym->attr.dimension && !e->ref)
5820 {
5821 e->ref = gfc_get_ref ();
5822 e->ref->type = REF_ARRAY;
5823 e->ref->u.ar.type = AR_FULL;
5824 e->ref->u.ar.dimen = 0;
5825 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04005826
Andre Vehreschild76540ac2015-06-23 11:07:22 +02005827 /* Like above, but for class types, where the checking whether an array
5828 ref is present is more complicated. Furthermore make sure not to add
5829 the full array ref to _vptr or _len refs. */
Harald Anlaufd8f6c482021-12-27 23:06:18 +01005830 if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
5831 && CLASS_DATA (sym)
Andre Vehreschild76540ac2015-06-23 11:07:22 +02005832 && CLASS_DATA (sym)->attr.dimension
5833 && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
5834 {
5835 gfc_ref *ref, *newref;
5836
5837 newref = gfc_get_ref ();
5838 newref->type = REF_ARRAY;
5839 newref->u.ar.type = AR_FULL;
5840 newref->u.ar.dimen = 0;
5841 /* Because this is an associate var and the first ref either is a ref to
5842 the _data component or not, no traversal of the ref chain is
5843 needed. The array ref needs to be inserted after the _data ref,
5844 or when that is not present, which may happend for polymorphic
5845 types, then at the first position. */
5846 ref = e->ref;
5847 if (!ref)
5848 e->ref = newref;
5849 else if (ref->type == REF_COMPONENT
5850 && strcmp ("_data", ref->u.c.component->name) == 0)
5851 {
5852 if (!ref->next || ref->next->type != REF_ARRAY)
5853 {
5854 newref->next = ref->next;
5855 ref->next = newref;
5856 }
5857 else
5858 /* Array ref present already. */
5859 gfc_free_ref_list (newref);
5860 }
5861 else if (ref->type == REF_ARRAY)
5862 /* Array ref present already. */
5863 gfc_free_ref_list (newref);
5864 else
5865 {
5866 newref->next = ref;
5867 e->ref = newref;
5868 }
5869 }
5870
Tobias Burnusde89b572019-12-20 11:35:20 +00005871 if (e->ref && !gfc_resolve_ref (e))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005872 return false;
Francois-Xavier Coudert009e94d2005-04-19 09:10:05 +02005873
Janus Weil3070bab2009-04-09 11:39:09 +02005874 if (sym->attr.flavor == FL_PROCEDURE
5875 && (!sym->attr.function
5876 || (sym->attr.function && sym->result
5877 && sym->result->attr.proc_pointer
5878 && !sym->result->attr.function)))
Diego Novillo6de9cd92004-05-13 02:41:07 -04005879 {
5880 e->ts.type = BT_PROCEDURE;
Daniel Krafta03826d2008-11-24 14:10:37 +01005881 goto resolve_procedure;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005882 }
5883
5884 if (sym->ts.type != BT_UNKNOWN)
5885 gfc_variable_attr (e, &e->ts);
Paul Thomas871267e2016-10-17 17:52:05 +00005886 else if (sym->attr.flavor == FL_PROCEDURE
5887 && sym->attr.function && sym->result
5888 && sym->result->ts.type != BT_UNKNOWN
5889 && sym->result->attr.proc_pointer)
5890 e->ts = sym->result->ts;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005891 else
5892 {
5893 /* Must be a simple variable reference. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005894 if (!gfc_set_default_type (sym, 1, sym->ns))
5895 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04005896 e->ts = sym->ts;
5897 }
5898
Paul Thomas48474142006-01-07 14:14:08 +00005899 if (check_assumed_size_reference (sym, e))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005900 return false;
Paul Thomas48474142006-01-07 14:14:08 +00005901
Jakub Jelinekb46ebd62014-06-24 09:45:22 +02005902 /* Deal with forward references to entries during gfc_resolve_code, to
Paul Thomas0e9a4452006-06-07 07:20:39 +00005903 satisfy, at least partially, 12.5.2.5. */
5904 if (gfc_current_ns->entries
Steven G. Kargledf1eac2007-01-20 22:01:41 +00005905 && current_entry_id == sym->entry_id
5906 && cs_base
5907 && cs_base->current
5908 && cs_base->current->op != EXEC_ENTRY)
Paul Thomas0e9a4452006-06-07 07:20:39 +00005909 {
5910 gfc_entry_list *entry;
5911 gfc_formal_arglist *formal;
5912 int n;
Tobias Burnusfd061182012-10-18 19:09:13 +02005913 bool seen, saved_specification_expr;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005914
5915 /* If the symbol is a dummy... */
Tobias Burnus70365b52007-10-20 13:34:21 +02005916 if (sym->attr.dummy && sym->ns == gfc_current_ns)
Paul Thomas0e9a4452006-06-07 07:20:39 +00005917 {
5918 entry = gfc_current_ns->entries;
5919 seen = false;
5920
5921 /* ...test if the symbol is a parameter of previous entries. */
5922 for (; entry && entry->id <= current_entry_id; entry = entry->next)
5923 for (formal = entry->sym->formal; formal; formal = formal->next)
5924 {
5925 if (formal->sym && sym->name == formal->sym->name)
Po-Chun Chang502af492013-07-29 13:08:03 -06005926 {
5927 seen = true;
5928 break;
5929 }
Paul Thomas0e9a4452006-06-07 07:20:39 +00005930 }
5931
5932 /* If it has not been seen as a dummy, this is an error. */
5933 if (!seen)
5934 {
5935 if (specification_expr)
Tobias Burnusa4d9b222014-12-13 00:12:06 +01005936 gfc_error ("Variable %qs, used in a specification expression"
Tobias Burnus70365b52007-10-20 13:34:21 +02005937 ", is referenced at %L before the ENTRY statement "
Paul Thomas0e9a4452006-06-07 07:20:39 +00005938 "in which it is a parameter",
5939 sym->name, &cs_base->current->loc);
5940 else
Tobias Burnusa4d9b222014-12-13 00:12:06 +01005941 gfc_error ("Variable %qs is used at %L before the ENTRY "
Paul Thomas0e9a4452006-06-07 07:20:39 +00005942 "statement in which it is a parameter",
5943 sym->name, &cs_base->current->loc);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005944 t = false;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005945 }
5946 }
5947
5948 /* Now do the same check on the specification expressions. */
Tobias Burnusfd061182012-10-18 19:09:13 +02005949 saved_specification_expr = specification_expr;
5950 specification_expr = true;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005951 if (sym->ts.type == BT_CHARACTER
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005952 && !gfc_resolve_expr (sym->ts.u.cl->length))
5953 t = false;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005954
5955 if (sym->as)
5956 for (n = 0; n < sym->as->rank; n++)
5957 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005958 if (!gfc_resolve_expr (sym->as->lower[n]))
5959 t = false;
5960 if (!gfc_resolve_expr (sym->as->upper[n]))
5961 t = false;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005962 }
Tobias Burnusfd061182012-10-18 19:09:13 +02005963 specification_expr = saved_specification_expr;
Paul Thomas0e9a4452006-06-07 07:20:39 +00005964
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005965 if (t)
Paul Thomas0e9a4452006-06-07 07:20:39 +00005966 /* Update the symbol's entry level. */
5967 sym->entry_id = current_entry_id + 1;
5968 }
5969
Paul Thomas022e30c2010-07-10 14:57:25 +00005970 /* If a symbol has been host_associated mark it. This is used latter,
5971 to identify if aliasing is possible via host association. */
5972 if (sym->attr.flavor == FL_VARIABLE
5973 && gfc_current_ns->parent
5974 && (gfc_current_ns->parent == sym->ns
5975 || (gfc_current_ns->parent->parent
5976 && gfc_current_ns->parent->parent == sym->ns)))
5977 sym->attr.host_assoc = 1;
5978
Paul Thomas30c931d2015-03-23 07:53:31 +00005979 if (gfc_current_ns->proc_name
5980 && sym->attr.dimension
5981 && (sym->ns != gfc_current_ns
5982 || sym->attr.use_assoc
5983 || sym->attr.in_common))
5984 gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
5985
Daniel Krafta03826d2008-11-24 14:10:37 +01005986resolve_procedure:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03005987 if (t && !resolve_procedure_expression (e))
5988 t = false;
Daniel Krafta03826d2008-11-24 14:10:37 +01005989
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02005990 /* F2008, C617 and C1229. */
5991 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
5992 && gfc_is_coindexed (e))
5993 {
5994 gfc_ref *ref, *ref2 = NULL;
5995
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02005996 for (ref = e->ref; ref; ref = ref->next)
5997 {
5998 if (ref->type == REF_COMPONENT)
5999 ref2 = ref;
6000 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6001 break;
6002 }
6003
6004 for ( ; ref; ref = ref->next)
6005 if (ref->type == REF_COMPONENT)
6006 break;
6007
Tobias Burnusa70de212010-12-11 23:04:06 +01006008 /* Expression itself is not coindexed object. */
6009 if (ref && e->ts.type == BT_CLASS)
6010 {
6011 gfc_error ("Polymorphic subobject of coindexed object at %L",
6012 &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006013 t = false;
Tobias Burnusa70de212010-12-11 23:04:06 +01006014 }
6015
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02006016 /* Expression itself is coindexed object. */
6017 if (ref == NULL)
6018 {
6019 gfc_component *c;
6020 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
6021 for ( ; c; c = c->next)
6022 if (c->attr.allocatable && c->ts.type == BT_CLASS)
6023 {
6024 gfc_error ("Coindexed object with polymorphic allocatable "
6025 "subcomponent at %L", &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006026 t = false;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02006027 break;
6028 }
6029 }
6030 }
6031
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02006032 if (t)
Tobias Burnusde89b572019-12-20 11:35:20 +00006033 gfc_expression_rank (e);
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02006034
Tobias Burnusf19626c2014-12-17 07:29:30 +01006035 if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02006036 add_caf_get_intrinsic (e);
6037
Tobias Burnus0caf4002020-11-03 09:55:58 +01006038 if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
6039 gfc_warning (OPT_Wdeprecated_declarations,
6040 "Using variable %qs at %L is deprecated",
6041 sym->name, &e->where);
Thomas Koenig06e8d822018-04-09 21:05:13 +00006042 /* Simplify cases where access to a parameter array results in a
6043 single constant. Suppress errors since those will have been
6044 issued before, as warnings. */
6045 if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER)
6046 {
6047 gfc_push_suppress_errors ();
6048 gfc_simplify_expr (e, 1);
6049 gfc_pop_suppress_errors ();
6050 }
6051
Paul Thomas0e9a4452006-06-07 07:20:39 +00006052 return t;
Diego Novillo6de9cd92004-05-13 02:41:07 -04006053}
6054
6055
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006056/* Checks to see that the correct symbol has been host associated.
6057 The only situation where this arises is that in which a twice
6058 contained function is parsed after the host association is made.
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006059 Therefore, on detecting this, change the symbol in the expression
6060 and convert the array reference into an actual arglist if the old
6061 symbol is a variable. */
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006062static bool
6063check_host_association (gfc_expr *e)
6064{
6065 gfc_symbol *sym, *old_sym;
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006066 gfc_symtree *st;
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006067 int n;
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006068 gfc_ref *ref;
Steve Ellceye4bf01a2009-05-11 15:23:25 +00006069 gfc_actual_arglist *arg, *tail = NULL;
Paul Thomas8de10a62007-06-25 18:27:59 +00006070 bool retval = e->expr_type == EXPR_FUNCTION;
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006071
Paul Thomasa1ab6662009-01-04 23:17:37 +00006072 /* If the expression is the result of substitution in
Martin Liskae53b6e52022-01-14 16:57:02 +01006073 interface.cc(gfc_extend_expr) because there is no way in
Paul Thomasa1ab6662009-01-04 23:17:37 +00006074 which the host association can be wrong. */
6075 if (e->symtree == NULL
6076 || e->symtree->n.sym == NULL
6077 || e->user_operator)
Paul Thomas8de10a62007-06-25 18:27:59 +00006078 return retval;
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006079
6080 old_sym = e->symtree->n.sym;
Paul Thomas8de10a62007-06-25 18:27:59 +00006081
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006082 if (gfc_current_ns->parent
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006083 && old_sym->ns != gfc_current_ns)
6084 {
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006085 /* Use the 'USE' name so that renamed module symbols are
6086 correctly handled. */
Paul Thomas9be36842009-01-10 00:11:18 +00006087 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006088
Paul Thomasa944c792007-10-18 12:48:37 +00006089 if (sym && old_sym != sym
Paul Thomas67cec812008-11-03 06:44:47 +00006090 && sym->ts.type == old_sym->ts.type
Paul Thomasa944c792007-10-18 12:48:37 +00006091 && sym->attr.flavor == FL_PROCEDURE
6092 && sym->attr.contained)
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006093 {
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006094 /* Clear the shape, since it might not be valid. */
Mikael Morind54e80c2011-08-25 19:10:06 +00006095 gfc_free_shape (&e->shape, e->rank);
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006096
Paul Thomas1aafbf92009-07-09 16:48:50 +00006097 /* Give the expression the right symtree! */
6098 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st);
6099 gcc_assert (st != NULL);
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006100
Paul Thomas1aafbf92009-07-09 16:48:50 +00006101 if (old_sym->attr.flavor == FL_PROCEDURE
6102 || e->expr_type == EXPR_FUNCTION)
6103 {
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006104 /* Original was function so point to the new symbol, since
6105 the actual argument list is already attached to the
Joost VandeVondele1cc0e192014-09-20 11:48:00 +00006106 expression. */
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006107 e->value.function.esym = NULL;
6108 e->symtree = st;
6109 }
6110 else
6111 {
6112 /* Original was variable so convert array references into
6113 an actual arglist. This does not need any checking now
Tobias Burnusd8155bf2011-07-18 08:48:19 +02006114 since resolve_function will take care of it. */
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006115 e->value.function.actual = NULL;
6116 e->expr_type = EXPR_FUNCTION;
6117 e->symtree = st;
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006118
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006119 /* Ambiguity will not arise if the array reference is not
6120 the last reference. */
6121 for (ref = e->ref; ref; ref = ref->next)
6122 if (ref->type == REF_ARRAY && ref->next == NULL)
6123 break;
6124
Paul Thomas359815a2020-08-10 06:19:25 +01006125 if ((ref == NULL || ref->type != REF_ARRAY)
6126 && sym->attr.proc == PROC_INTERNAL)
6127 {
6128 gfc_error ("%qs at %L is host associated at %L into "
6129 "a contained procedure with an internal "
6130 "procedure of the same name", sym->name,
6131 &old_sym->declared_at, &e->where);
6132 return false;
6133 }
6134
Paul Thomas5b3b1d02009-01-20 21:56:49 +00006135 gcc_assert (ref->type == REF_ARRAY);
6136
6137 /* Grab the start expressions from the array ref and
6138 copy them into actual arguments. */
6139 for (n = 0; n < ref->u.ar.dimen; n++)
6140 {
6141 arg = gfc_get_actual_arglist ();
6142 arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
6143 if (e->value.function.actual == NULL)
6144 tail = e->value.function.actual = arg;
6145 else
6146 {
6147 tail->next = arg;
6148 tail = arg;
6149 }
6150 }
6151
6152 /* Dump the reference list and set the rank. */
6153 gfc_free_ref_list (e->ref);
6154 e->ref = NULL;
6155 e->rank = sym->as ? sym->as->rank : 0;
6156 }
6157
6158 gfc_resolve_expr (e);
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006159 sym->refs++;
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006160 }
6161 }
Paul Thomas8de10a62007-06-25 18:27:59 +00006162 /* This might have changed! */
Paul Thomaseb77cdd2007-05-12 06:19:43 +00006163 return e->expr_type == EXPR_FUNCTION;
6164}
6165
6166
Paul Thomas07368af2007-08-30 22:10:55 +00006167static void
6168gfc_resolve_character_operator (gfc_expr *e)
6169{
6170 gfc_expr *op1 = e->value.op.op1;
6171 gfc_expr *op2 = e->value.op.op2;
6172 gfc_expr *e1 = NULL;
6173 gfc_expr *e2 = NULL;
6174
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +00006175 gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
Paul Thomas07368af2007-08-30 22:10:55 +00006176
Janus Weilbc21d312009-08-13 21:46:46 +02006177 if (op1->ts.u.cl && op1->ts.u.cl->length)
6178 e1 = gfc_copy_expr (op1->ts.u.cl->length);
Paul Thomas07368af2007-08-30 22:10:55 +00006179 else if (op1->expr_type == EXPR_CONSTANT)
Janne Blomqvistf6222212018-01-05 21:01:12 +02006180 e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
Jerry DeLisleb7e75772010-04-13 01:59:35 +00006181 op1->value.character.length);
Paul Thomas07368af2007-08-30 22:10:55 +00006182
Janus Weilbc21d312009-08-13 21:46:46 +02006183 if (op2->ts.u.cl && op2->ts.u.cl->length)
6184 e2 = gfc_copy_expr (op2->ts.u.cl->length);
Paul Thomas07368af2007-08-30 22:10:55 +00006185 else if (op2->expr_type == EXPR_CONSTANT)
Janne Blomqvistf6222212018-01-05 21:01:12 +02006186 e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
Jerry DeLisleb7e75772010-04-13 01:59:35 +00006187 op2->value.character.length);
Paul Thomas07368af2007-08-30 22:10:55 +00006188
Janus Weilb76e28c2009-08-17 11:11:00 +02006189 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
Paul Thomas07368af2007-08-30 22:10:55 +00006190
6191 if (!e1 || !e2)
Tobias Burnusd7920cf2012-08-27 22:51:52 +02006192 {
6193 gfc_free_expr (e1);
6194 gfc_free_expr (e2);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00006195
Tobias Burnusd7920cf2012-08-27 22:51:52 +02006196 return;
6197 }
Paul Thomas07368af2007-08-30 22:10:55 +00006198
Janus Weilbc21d312009-08-13 21:46:46 +02006199 e->ts.u.cl->length = gfc_add (e1, e2);
6200 e->ts.u.cl->length->ts.type = BT_INTEGER;
6201 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
6202 gfc_simplify_expr (e->ts.u.cl->length, 0);
6203 gfc_resolve_expr (e->ts.u.cl->length);
Paul Thomas07368af2007-08-30 22:10:55 +00006204
6205 return;
6206}
6207
6208
6209/* Ensure that an character expression has a charlen and, if possible, a
6210 length expression. */
6211
6212static void
6213fixup_charlen (gfc_expr *e)
6214{
6215 /* The cases fall through so that changes in expression type and the need
6216 for multiple fixes are picked up. In all circumstances, a charlen should
6217 be available for the middle end to hang a backend_decl on. */
6218 switch (e->expr_type)
6219 {
6220 case EXPR_OP:
6221 gfc_resolve_character_operator (e);
Marek Polacek191816a2016-08-12 10:30:47 +00006222 /* FALLTHRU */
Paul Thomas07368af2007-08-30 22:10:55 +00006223
6224 case EXPR_ARRAY:
6225 if (e->expr_type == EXPR_ARRAY)
6226 gfc_resolve_character_array_constructor (e);
Marek Polacek191816a2016-08-12 10:30:47 +00006227 /* FALLTHRU */
Paul Thomas07368af2007-08-30 22:10:55 +00006228
6229 case EXPR_SUBSTRING:
Janus Weilbc21d312009-08-13 21:46:46 +02006230 if (!e->ts.u.cl && e->ref)
Paul Thomas07368af2007-08-30 22:10:55 +00006231 gfc_resolve_substring_charlen (e);
Marek Polacek191816a2016-08-12 10:30:47 +00006232 /* FALLTHRU */
Paul Thomas07368af2007-08-30 22:10:55 +00006233
6234 default:
Janus Weilbc21d312009-08-13 21:46:46 +02006235 if (!e->ts.u.cl)
Janus Weilb76e28c2009-08-17 11:11:00 +02006236 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
Paul Thomas07368af2007-08-30 22:10:55 +00006237
6238 break;
6239 }
6240}
6241
6242
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006243/* Update an actual argument to include the passed-object for type-bound
6244 procedures at the right position. */
6245
6246static gfc_actual_arglist*
Janus Weil90661f22009-07-25 13:56:35 +02006247update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
6248 const char *name)
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006249{
Daniel Kraftb82657f2008-10-05 08:39:37 +02006250 gcc_assert (argpos > 0);
6251
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006252 if (argpos == 1)
6253 {
6254 gfc_actual_arglist* result;
6255
6256 result = gfc_get_actual_arglist ();
6257 result->expr = po;
6258 result->next = lst;
Janus Weil90661f22009-07-25 13:56:35 +02006259 if (name)
6260 result->name = name;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006261
6262 return result;
6263 }
6264
Janus Weil90661f22009-07-25 13:56:35 +02006265 if (lst)
6266 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
6267 else
6268 lst = update_arglist_pass (NULL, po, argpos - 1, name);
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006269 return lst;
6270}
6271
6272
Daniel Krafte157f7362008-08-31 12:00:30 +02006273/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
6274
6275static gfc_expr*
6276extract_compcall_passed_object (gfc_expr* e)
6277{
6278 gfc_expr* po;
6279
Thomas Koenig7e703f02019-03-18 07:28:42 +00006280 if (e->expr_type == EXPR_UNKNOWN)
6281 {
6282 gfc_error ("Error in typebound call at %L",
6283 &e->where);
6284 return NULL;
6285 }
6286
Daniel Krafte157f7362008-08-31 12:00:30 +02006287 gcc_assert (e->expr_type == EXPR_COMPCALL);
6288
Daniel Kraft4a44a722009-08-27 13:42:56 +02006289 if (e->value.compcall.base_object)
6290 po = gfc_copy_expr (e->value.compcall.base_object);
6291 else
6292 {
6293 po = gfc_get_expr ();
6294 po->expr_type = EXPR_VARIABLE;
6295 po->symtree = e->symtree;
6296 po->ref = gfc_copy_ref (e->ref);
Janus Weil63894de2010-01-19 23:21:35 +01006297 po->where = e->where;
Daniel Kraft4a44a722009-08-27 13:42:56 +02006298 }
Daniel Krafte157f7362008-08-31 12:00:30 +02006299
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006300 if (!gfc_resolve_expr (po))
Daniel Krafte157f7362008-08-31 12:00:30 +02006301 return NULL;
6302
6303 return po;
6304}
6305
6306
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006307/* Update the arglist of an EXPR_COMPCALL expression to include the
6308 passed-object. */
6309
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006310static bool
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006311update_compcall_arglist (gfc_expr* e)
6312{
6313 gfc_expr* po;
6314 gfc_typebound_proc* tbp;
6315
Daniel Krafte157f7362008-08-31 12:00:30 +02006316 tbp = e->value.compcall.tbp;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006317
Daniel Kraftb82657f2008-10-05 08:39:37 +02006318 if (tbp->error)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006319 return false;
Daniel Kraftb82657f2008-10-05 08:39:37 +02006320
Daniel Krafte157f7362008-08-31 12:00:30 +02006321 po = extract_compcall_passed_object (e);
6322 if (!po)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006323 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +02006324
Daniel Kraft4a44a722009-08-27 13:42:56 +02006325 if (tbp->nopass || e->value.compcall.ignore_pass)
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006326 {
6327 gfc_free_expr (po);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006328 return true;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006329 }
6330
Janus Weil859e3092017-11-11 22:54:41 +01006331 if (tbp->pass_arg_num <= 0)
6332 return false;
6333
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006334 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
Janus Weil90661f22009-07-25 13:56:35 +02006335 tbp->pass_arg_num,
6336 tbp->pass_arg);
6337
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006338 return true;
Janus Weil90661f22009-07-25 13:56:35 +02006339}
6340
6341
6342/* Extract the passed object from a PPC call (a copy of it). */
6343
6344static gfc_expr*
6345extract_ppc_passed_object (gfc_expr *e)
6346{
6347 gfc_expr *po;
6348 gfc_ref **ref;
6349
6350 po = gfc_get_expr ();
6351 po->expr_type = EXPR_VARIABLE;
6352 po->symtree = e->symtree;
6353 po->ref = gfc_copy_ref (e->ref);
Janus Weil63894de2010-01-19 23:21:35 +01006354 po->where = e->where;
Janus Weil90661f22009-07-25 13:56:35 +02006355
6356 /* Remove PPC reference. */
6357 ref = &po->ref;
6358 while ((*ref)->next)
Janus Weil63894de2010-01-19 23:21:35 +01006359 ref = &(*ref)->next;
Janus Weil90661f22009-07-25 13:56:35 +02006360 gfc_free_ref_list (*ref);
6361 *ref = NULL;
6362
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006363 if (!gfc_resolve_expr (po))
Janus Weil90661f22009-07-25 13:56:35 +02006364 return NULL;
6365
6366 return po;
6367}
6368
6369
6370/* Update the actual arglist of a procedure pointer component to include the
6371 passed-object. */
6372
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006373static bool
Janus Weil90661f22009-07-25 13:56:35 +02006374update_ppc_arglist (gfc_expr* e)
6375{
6376 gfc_expr* po;
6377 gfc_component *ppc;
6378 gfc_typebound_proc* tb;
6379
Mikael Morin2a573572012-08-14 16:28:29 +00006380 ppc = gfc_get_proc_ptr_comp (e);
6381 if (!ppc)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006382 return false;
Janus Weil90661f22009-07-25 13:56:35 +02006383
6384 tb = ppc->tb;
6385
6386 if (tb->error)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006387 return false;
Janus Weil90661f22009-07-25 13:56:35 +02006388 else if (tb->nopass)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006389 return true;
Janus Weil90661f22009-07-25 13:56:35 +02006390
6391 po = extract_ppc_passed_object (e);
6392 if (!po)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006393 return false;
Janus Weil90661f22009-07-25 13:56:35 +02006394
Janus Weil8b29bd22010-11-28 21:22:29 +01006395 /* F08:R739. */
Tobias Burnusc62c6622012-07-20 07:56:37 +02006396 if (po->rank != 0)
Janus Weil90661f22009-07-25 13:56:35 +02006397 {
6398 gfc_error ("Passed-object at %L must be scalar", &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006399 return false;
Janus Weil90661f22009-07-25 13:56:35 +02006400 }
6401
Janus Weil8b29bd22010-11-28 21:22:29 +01006402 /* F08:C611. */
6403 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
6404 {
6405 gfc_error ("Base object for procedure-pointer component call at %L is of"
Tobias Burnusa4d9b222014-12-13 00:12:06 +01006406 " ABSTRACT type %qs", &e->where, po->ts.u.derived->name);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006407 return false;
Janus Weil8b29bd22010-11-28 21:22:29 +01006408 }
6409
Janus Weil90661f22009-07-25 13:56:35 +02006410 gcc_assert (tb->pass_arg_num > 0);
6411 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
6412 tb->pass_arg_num,
6413 tb->pass_arg);
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006414
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006415 return true;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006416}
6417
6418
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006419/* Check that the object a TBP is called on is valid, i.e. it must not be
6420 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
6421
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006422static bool
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006423check_typebound_baseobject (gfc_expr* e)
6424{
6425 gfc_expr* base;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006426 bool return_value = false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006427
6428 base = extract_compcall_passed_object (e);
6429 if (!base)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006430 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006431
Thomas Koenig7e703f02019-03-18 07:28:42 +00006432 if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS)
6433 {
6434 gfc_error ("Error in typebound call at %L", &e->where);
6435 goto cleanup;
6436 }
Tobias Burnuse56817d2009-09-30 22:45:07 +02006437
Janus Weil0b2d4432012-08-16 00:11:03 +02006438 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006439 return false;
Janus Weil0b2d4432012-08-16 00:11:03 +02006440
Janus Weil8b29bd22010-11-28 21:22:29 +01006441 /* F08:C611. */
Tobias Burnuse56817d2009-09-30 22:45:07 +02006442 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006443 {
6444 gfc_error ("Base object for type-bound procedure call at %L is of"
Tobias Burnusa4d9b222014-12-13 00:12:06 +01006445 " ABSTRACT type %qs", &e->where, base->ts.u.derived->name);
Mikael Morin99b41d52010-10-06 14:52:02 +00006446 goto cleanup;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006447 }
6448
Janus Weil8b29bd22010-11-28 21:22:29 +01006449 /* F08:C1230. If the procedure called is NOPASS,
6450 the base object must be scalar. */
Tobias Burnusc62c6622012-07-20 07:56:37 +02006451 if (e->value.compcall.tbp->nopass && base->rank != 0)
Daniel Kraft41a394b2009-12-08 12:39:20 +01006452 {
6453 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
6454 " be scalar", &e->where);
Mikael Morin99b41d52010-10-06 14:52:02 +00006455 goto cleanup;
Daniel Kraft41a394b2009-12-08 12:39:20 +01006456 }
6457
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006458 return_value = true;
Mikael Morin99b41d52010-10-06 14:52:02 +00006459
6460cleanup:
6461 gfc_free_expr (base);
6462 return return_value;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006463}
6464
6465
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006466/* Resolve a call to a type-bound procedure, either function or subroutine,
6467 statically from the data in an EXPR_COMPCALL expression. The adapted
6468 arglist and the target-procedure symtree are returned. */
6469
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006470static bool
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006471resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
6472 gfc_actual_arglist** actual)
6473{
6474 gcc_assert (e->expr_type == EXPR_COMPCALL);
Daniel Krafte157f7362008-08-31 12:00:30 +02006475 gcc_assert (!e->value.compcall.tbp->is_generic);
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006476
6477 /* Update the actual arglist for PASS. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006478 if (!update_compcall_arglist (e))
6479 return false;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006480
6481 *actual = e->value.compcall.actual;
Daniel Krafte157f7362008-08-31 12:00:30 +02006482 *target = e->value.compcall.tbp->u.specific;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006483
6484 gfc_free_ref_list (e->ref);
6485 e->ref = NULL;
6486 e->value.compcall.actual = NULL;
6487
Paul Thomas003e0ad2012-01-05 21:15:52 +00006488 /* If we find a deferred typebound procedure, check for derived types
Tobias Burnuse3a2ec52012-05-07 10:35:17 +02006489 that an overriding typebound procedure has not been missed. */
6490 if (e->value.compcall.name
6491 && !e->value.compcall.tbp->non_overridable
6492 && e->value.compcall.base_object
6493 && e->value.compcall.base_object->ts.type == BT_DERIVED)
Paul Thomas003e0ad2012-01-05 21:15:52 +00006494 {
6495 gfc_symtree *st;
6496 gfc_symbol *derived;
6497
6498 /* Use the derived type of the base_object. */
6499 derived = e->value.compcall.base_object->ts.u.derived;
6500 st = NULL;
6501
Tobias Burnuseea58ad2012-05-30 08:26:09 +02006502 /* If necessary, go through the inheritance chain. */
Paul Thomas003e0ad2012-01-05 21:15:52 +00006503 while (!st && derived)
6504 {
6505 /* Look for the typebound procedure 'name'. */
6506 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
6507 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root,
6508 e->value.compcall.name);
6509 if (!st)
6510 derived = gfc_get_derived_super_type (derived);
6511 }
6512
6513 /* Now find the specific name in the derived type namespace. */
6514 if (st && st->n.tb && st->n.tb->u.specific)
6515 gfc_find_sym_tree (st->n.tb->u.specific->name,
6516 derived->ns, 1, &st);
6517 if (st)
6518 *target = st;
6519 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006520 return true;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006521}
6522
6523
Paul Thomas15d774f2010-06-06 02:04:04 +00006524/* Get the ultimate declared type from an expression. In addition,
6525 return the last class/derived type reference and the copy of the
Paul Thomas94fae142012-01-02 12:46:08 +00006526 reference list. If check_types is set true, derived types are
6527 identified as well as class references. */
Paul Thomas15d774f2010-06-06 02:04:04 +00006528static gfc_symbol*
6529get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
Paul Thomas94fae142012-01-02 12:46:08 +00006530 gfc_expr *e, bool check_types)
Paul Thomas15d774f2010-06-06 02:04:04 +00006531{
6532 gfc_symbol *declared;
6533 gfc_ref *ref;
6534
6535 declared = NULL;
6536 if (class_ref)
6537 *class_ref = NULL;
6538 if (new_ref)
6539 *new_ref = gfc_copy_ref (e->ref);
6540
6541 for (ref = e->ref; ref; ref = ref->next)
6542 {
6543 if (ref->type != REF_COMPONENT)
6544 continue;
6545
Paul Thomas94fae142012-01-02 12:46:08 +00006546 if ((ref->u.c.component->ts.type == BT_CLASS
Fritz Reesef6288c22016-05-07 23:16:23 +00006547 || (check_types && gfc_bt_struct (ref->u.c.component->ts.type)))
Paul Thomas94fae142012-01-02 12:46:08 +00006548 && ref->u.c.component->attr.flavor != FL_PROCEDURE)
Paul Thomas15d774f2010-06-06 02:04:04 +00006549 {
6550 declared = ref->u.c.component->ts.u.derived;
6551 if (class_ref)
6552 *class_ref = ref;
6553 }
6554 }
6555
6556 if (declared == NULL)
6557 declared = e->symtree->n.sym->ts.u.derived;
6558
6559 return declared;
6560}
6561
6562
Daniel Krafte157f7362008-08-31 12:00:30 +02006563/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
6564 which of the specific bindings (if any) matches the arglist and transform
6565 the expression into a call of that binding. */
6566
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006567static bool
Paul Thomaseece1eb2010-04-29 19:10:48 +00006568resolve_typebound_generic_call (gfc_expr* e, const char **name)
Daniel Krafte157f7362008-08-31 12:00:30 +02006569{
6570 gfc_typebound_proc* genproc;
6571 const char* genname;
Paul Thomas15d774f2010-06-06 02:04:04 +00006572 gfc_symtree *st;
6573 gfc_symbol *derived;
Daniel Krafte157f7362008-08-31 12:00:30 +02006574
6575 gcc_assert (e->expr_type == EXPR_COMPCALL);
6576 genname = e->value.compcall.name;
6577 genproc = e->value.compcall.tbp;
6578
6579 if (!genproc->is_generic)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006580 return true;
Daniel Krafte157f7362008-08-31 12:00:30 +02006581
6582 /* Try the bindings on this type and in the inheritance hierarchy. */
6583 for (; genproc; genproc = genproc->overridden)
6584 {
6585 gfc_tbp_generic* g;
6586
6587 gcc_assert (genproc->is_generic);
6588 for (g = genproc->u.generic; g; g = g->next)
6589 {
6590 gfc_symbol* target;
6591 gfc_actual_arglist* args;
6592 bool matches;
6593
6594 gcc_assert (g->specific);
Daniel Kraftb82657f2008-10-05 08:39:37 +02006595
6596 if (g->specific->error)
6597 continue;
6598
Daniel Krafte157f7362008-08-31 12:00:30 +02006599 target = g->specific->u.specific->n.sym;
6600
6601 /* Get the right arglist by handling PASS/NOPASS. */
6602 args = gfc_copy_actual_arglist (e->value.compcall.actual);
6603 if (!g->specific->nopass)
6604 {
6605 gfc_expr* po;
6606 po = extract_compcall_passed_object (e);
6607 if (!po)
Tobias Burnusefb63362012-10-04 19:32:06 +02006608 {
6609 gfc_free_actual_arglist (args);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006610 return false;
Tobias Burnusefb63362012-10-04 19:32:06 +02006611 }
Daniel Krafte157f7362008-08-31 12:00:30 +02006612
Daniel Kraftb82657f2008-10-05 08:39:37 +02006613 gcc_assert (g->specific->pass_arg_num > 0);
6614 gcc_assert (!g->specific->error);
Janus Weil90661f22009-07-25 13:56:35 +02006615 args = update_arglist_pass (args, po, g->specific->pass_arg_num,
6616 g->specific->pass_arg);
Daniel Krafte157f7362008-08-31 12:00:30 +02006617 }
Daniel Kraftf0ac18b2008-09-23 16:26:47 +02006618 resolve_actual_arglist (args, target->attr.proc,
Janus Weil4cbc9032013-01-29 22:40:51 +01006619 is_external_proc (target)
6620 && gfc_sym_get_dummy_args (target) == NULL);
Daniel Krafte157f7362008-08-31 12:00:30 +02006621
6622 /* Check if this arglist matches the formal. */
Daniel Kraftf0ac18b2008-09-23 16:26:47 +02006623 matches = gfc_arglist_matches_symbol (&args, target);
Daniel Krafte157f7362008-08-31 12:00:30 +02006624
6625 /* Clean up and break out of the loop if we've found it. */
6626 gfc_free_actual_arglist (args);
6627 if (matches)
6628 {
6629 e->value.compcall.tbp = g->specific;
Janus Weilab7306e2010-07-15 15:36:28 +02006630 genname = g->specific_st->name;
Paul Thomaseece1eb2010-04-29 19:10:48 +00006631 /* Pass along the name for CLASS methods, where the vtab
6632 procedure pointer component has to be referenced. */
6633 if (name)
Janus Weilab7306e2010-07-15 15:36:28 +02006634 *name = genname;
Daniel Krafte157f7362008-08-31 12:00:30 +02006635 goto success;
6636 }
6637 }
6638 }
6639
6640 /* Nothing matching found! */
6641 gfc_error ("Found no matching specific binding for the call to the GENERIC"
Tobias Burnusa4d9b222014-12-13 00:12:06 +01006642 " %qs at %L", genname, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006643 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +02006644
6645success:
Paul Thomas15d774f2010-06-06 02:04:04 +00006646 /* Make sure that we have the right specific instance for the name. */
Paul Thomas94fae142012-01-02 12:46:08 +00006647 derived = get_declared_from_expr (NULL, NULL, e, true);
Paul Thomas15d774f2010-06-06 02:04:04 +00006648
Tobias Burnus12578be2011-04-29 18:49:53 +02006649 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
Paul Thomas15d774f2010-06-06 02:04:04 +00006650 if (st)
6651 e->value.compcall.tbp = st->n.tb;
6652
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006653 return true;
Daniel Krafte157f7362008-08-31 12:00:30 +02006654}
6655
6656
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006657/* Resolve a call to a type-bound subroutine. */
6658
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006659static bool
Janus Weil744868a2014-12-16 09:15:38 +01006660resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006661{
6662 gfc_actual_arglist* newactual;
6663 gfc_symtree* target;
6664
Daniel Krafte157f7362008-08-31 12:00:30 +02006665 /* Check that's really a SUBROUTINE. */
Steven G. Kargla5139272009-05-13 20:49:13 +00006666 if (!c->expr1->value.compcall.tbp->subroutine)
Daniel Krafte157f7362008-08-31 12:00:30 +02006667 {
Paul Thomas6ab6c0c2018-08-23 06:27:54 +00006668 if (!c->expr1->value.compcall.tbp->is_generic
6669 && c->expr1->value.compcall.tbp->u.specific
6670 && c->expr1->value.compcall.tbp->u.specific->n.sym
6671 && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
6672 c->expr1->value.compcall.tbp->subroutine = 1;
6673 else
6674 {
6675 gfc_error ("%qs at %L should be a SUBROUTINE",
6676 c->expr1->value.compcall.name, &c->loc);
6677 return false;
6678 }
Daniel Krafte157f7362008-08-31 12:00:30 +02006679 }
6680
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006681 if (!check_typebound_baseobject (c->expr1))
6682 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006683
Paul Thomaseece1eb2010-04-29 19:10:48 +00006684 /* Pass along the name for CLASS methods, where the vtab
6685 procedure pointer component has to be referenced. */
6686 if (name)
6687 *name = c->expr1->value.compcall.name;
6688
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006689 if (!resolve_typebound_generic_call (c->expr1, name))
6690 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +02006691
Janus Weil744868a2014-12-16 09:15:38 +01006692 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
6693 if (overridable)
6694 *overridable = !c->expr1->value.compcall.tbp->non_overridable;
6695
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006696 /* Transform into an ordinary EXEC_CALL for now. */
6697
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006698 if (!resolve_typebound_static (c->expr1, &target, &newactual))
6699 return false;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006700
6701 c->ext.actual = newactual;
6702 c->symtree = target;
Daniel Kraft4a44a722009-08-27 13:42:56 +02006703 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006704
Steven G. Kargla5139272009-05-13 20:49:13 +00006705 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006706
Steven G. Kargla5139272009-05-13 20:49:13 +00006707 gfc_free_expr (c->expr1);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006708 c->expr1 = gfc_get_expr ();
6709 c->expr1->expr_type = EXPR_FUNCTION;
6710 c->expr1->symtree = target;
6711 c->expr1->where = c->loc;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006712
6713 return resolve_call (c);
6714}
6715
6716
Paul Thomaseece1eb2010-04-29 19:10:48 +00006717/* Resolve a component-call expression. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006718static bool
Paul Thomaseece1eb2010-04-29 19:10:48 +00006719resolve_compcall (gfc_expr* e, const char **name)
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006720{
6721 gfc_actual_arglist* newactual;
6722 gfc_symtree* target;
6723
Daniel Krafte157f7362008-08-31 12:00:30 +02006724 /* Check that's really a FUNCTION. */
Paul Thomaseece1eb2010-04-29 19:10:48 +00006725 if (!e->value.compcall.tbp->function)
Daniel Krafte157f7362008-08-31 12:00:30 +02006726 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +01006727 gfc_error ("%qs at %L should be a FUNCTION",
Daniel Krafte157f7362008-08-31 12:00:30 +02006728 e->value.compcall.name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006729 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +02006730 }
6731
Steven G. Kargl878f88b2019-08-10 18:26:13 +00006732
Daniel Kraft4a44a722009-08-27 13:42:56 +02006733 /* These must not be assign-calls! */
6734 gcc_assert (!e->value.compcall.assign);
6735
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006736 if (!check_typebound_baseobject (e))
6737 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +02006738
Paul Thomaseece1eb2010-04-29 19:10:48 +00006739 /* Pass along the name for CLASS methods, where the vtab
6740 procedure pointer component has to be referenced. */
6741 if (name)
6742 *name = e->value.compcall.name;
6743
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006744 if (!resolve_typebound_generic_call (e, name))
6745 return false;
Daniel Kraft00ca6642008-09-09 20:08:08 +02006746 gcc_assert (!e->value.compcall.tbp->is_generic);
6747
6748 /* Take the rank from the function's symbol. */
6749 if (e->value.compcall.tbp->u.specific->n.sym->as)
6750 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
Daniel Krafte157f7362008-08-31 12:00:30 +02006751
6752 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006753 arglist to the TBP's binding target. */
6754
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006755 if (!resolve_typebound_static (e, &target, &newactual))
6756 return false;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006757
6758 e->value.function.actual = newactual;
Janus Weilb3d286b2010-03-08 10:35:04 +01006759 e->value.function.name = NULL;
Paul Thomas37a40b52009-07-05 19:13:59 +00006760 e->value.function.esym = target->n.sym;
Daniel Krafte157f7362008-08-31 12:00:30 +02006761 e->value.function.isym = NULL;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006762 e->symtree = target;
Daniel Kraftf0ac18b2008-09-23 16:26:47 +02006763 e->ts = target->n.sym->ts;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02006764 e->expr_type = EXPR_FUNCTION;
6765
Paul Thomaseece1eb2010-04-29 19:10:48 +00006766 /* Resolution is not necessary if this is a class subroutine; this
6767 function only has to identify the specific proc. Resolution of
6768 the call will be done next in resolve_typebound_call. */
6769 return gfc_resolve_expr (e);
Paul Thomas28188742009-10-16 06:07:09 +00006770}
6771
6772
Janus Weilf0051262013-07-25 23:41:22 +02006773static bool resolve_fl_derived (gfc_symbol *sym);
6774
Paul Thomas28188742009-10-16 06:07:09 +00006775
Paul Thomaseece1eb2010-04-29 19:10:48 +00006776/* Resolve a typebound function, or 'method'. First separate all
6777 the non-CLASS references by calling resolve_compcall directly. */
Paul Thomas6a943ee2010-03-12 22:00:52 +00006778
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006779static bool
Paul Thomas6a943ee2010-03-12 22:00:52 +00006780resolve_typebound_function (gfc_expr* e)
Paul Thomas7cf078d2009-10-05 18:19:55 +00006781{
Paul Thomaseece1eb2010-04-29 19:10:48 +00006782 gfc_symbol *declared;
6783 gfc_component *c;
Paul Thomas28188742009-10-16 06:07:09 +00006784 gfc_ref *new_ref;
6785 gfc_ref *class_ref;
6786 gfc_symtree *st;
Paul Thomaseece1eb2010-04-29 19:10:48 +00006787 const char *name;
Paul Thomaseece1eb2010-04-29 19:10:48 +00006788 gfc_typespec ts;
Paul Thomas974df0f2010-07-19 18:48:44 +00006789 gfc_expr *expr;
Janus Weilfd83db32011-11-07 19:41:12 +01006790 bool overridable;
Paul Thomas7cf078d2009-10-05 18:19:55 +00006791
Paul Thomas28188742009-10-16 06:07:09 +00006792 st = e->symtree;
Paul Thomas974df0f2010-07-19 18:48:44 +00006793
6794 /* Deal with typebound operators for CLASS objects. */
6795 expr = e->value.compcall.base_object;
Janus Weilfd83db32011-11-07 19:41:12 +01006796 overridable = !e->value.compcall.tbp->non_overridable;
Janus Weil061e60b2010-10-07 19:35:18 +02006797 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
Paul Thomas974df0f2010-07-19 18:48:44 +00006798 {
6799 /* Since the typebound operators are generic, we have to ensure
6800 that any delays in resolution are corrected and that the vtab
6801 is present. */
Janus Weil061e60b2010-10-07 19:35:18 +02006802 ts = expr->ts;
Paul Thomas974df0f2010-07-19 18:48:44 +00006803 declared = ts.u.derived;
Fritz Reesef6288c22016-05-07 23:16:23 +00006804 c = gfc_find_component (declared, "_vptr", true, true, NULL);
Paul Thomas974df0f2010-07-19 18:48:44 +00006805 if (c->ts.u.derived == NULL)
6806 c->ts.u.derived = gfc_find_derived_vtab (declared);
6807
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006808 if (!resolve_compcall (e, &name))
6809 return false;
Paul Thomas974df0f2010-07-19 18:48:44 +00006810
6811 /* Use the generic name if it is there. */
6812 name = name ? name : e->value.function.esym->name;
6813 e->symtree = expr->symtree;
Janus Weild3735472010-10-10 23:35:10 +02006814 e->ref = gfc_copy_ref (expr->ref);
Paul Thomas94fae142012-01-02 12:46:08 +00006815 get_declared_from_expr (&class_ref, NULL, e, false);
6816
6817 /* Trim away the extraneous references that emerge from nested
Martin Liskae53b6e52022-01-14 16:57:02 +01006818 use of interface.cc (extend_expr). */
Paul Thomas94fae142012-01-02 12:46:08 +00006819 if (class_ref && class_ref->next)
6820 {
6821 gfc_free_ref_list (class_ref->next);
6822 class_ref->next = NULL;
6823 }
Andre Vehreschild8294f552016-11-20 15:21:43 +01006824 else if (e->ref && !class_ref && expr->ts.type != BT_CLASS)
Paul Thomas94fae142012-01-02 12:46:08 +00006825 {
6826 gfc_free_ref_list (e->ref);
6827 e->ref = NULL;
6828 }
6829
Janus Weilb04533a2010-11-09 11:39:46 +01006830 gfc_add_vptr_component (e);
Paul Thomas974df0f2010-07-19 18:48:44 +00006831 gfc_add_component_ref (e, name);
6832 e->value.function.esym = NULL;
Paul Thomas94fae142012-01-02 12:46:08 +00006833 if (expr->expr_type != EXPR_VARIABLE)
6834 e->base_expr = expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006835 return true;
Paul Thomas974df0f2010-07-19 18:48:44 +00006836 }
6837
Paul Thomas6a943ee2010-03-12 22:00:52 +00006838 if (st == NULL)
Paul Thomaseece1eb2010-04-29 19:10:48 +00006839 return resolve_compcall (e, NULL);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006840
Tobias Burnusde89b572019-12-20 11:35:20 +00006841 if (!gfc_resolve_ref (e))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006842 return false;
Janus Weilf1a0b752010-06-09 16:14:08 +02006843
Paul Thomas28188742009-10-16 06:07:09 +00006844 /* Get the CLASS declared type. */
Paul Thomas94fae142012-01-02 12:46:08 +00006845 declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
Paul Thomas22c23882014-10-18 14:35:51 +00006846
Janus Weilf0051262013-07-25 23:41:22 +02006847 if (!resolve_fl_derived (declared))
6848 return false;
Paul Thomas28188742009-10-16 06:07:09 +00006849
6850 /* Weed out cases of the ultimate component being a derived type. */
Fritz Reesef6288c22016-05-07 23:16:23 +00006851 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
Paul Thomaseece1eb2010-04-29 19:10:48 +00006852 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
Paul Thomas28188742009-10-16 06:07:09 +00006853 {
6854 gfc_free_ref_list (new_ref);
Paul Thomaseece1eb2010-04-29 19:10:48 +00006855 return resolve_compcall (e, NULL);
Paul Thomasf116b2f2009-10-20 04:16:02 +00006856 }
6857
Fritz Reesef6288c22016-05-07 23:16:23 +00006858 c = gfc_find_component (declared, "_data", true, true, NULL);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006859
Paul Thomaseece1eb2010-04-29 19:10:48 +00006860 /* Treat the call as if it is a typebound procedure, in order to roll
6861 out the correct name for the specific function. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006862 if (!resolve_compcall (e, &name))
Tobias Burnusefb63362012-10-04 19:32:06 +02006863 {
6864 gfc_free_ref_list (new_ref);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006865 return false;
Tobias Burnusefb63362012-10-04 19:32:06 +02006866 }
Paul Thomaseece1eb2010-04-29 19:10:48 +00006867 ts = e->ts;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02006868
Janus Weilfd83db32011-11-07 19:41:12 +01006869 if (overridable)
6870 {
6871 /* Convert the expression to a procedure pointer component call. */
6872 e->value.function.esym = NULL;
6873 e->symtree = st;
Paul Thomas7cf078d2009-10-05 18:19:55 +00006874
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00006875 if (new_ref)
Janus Weilfd83db32011-11-07 19:41:12 +01006876 e->ref = new_ref;
Paul Thomas7cf078d2009-10-05 18:19:55 +00006877
Janus Weilfd83db32011-11-07 19:41:12 +01006878 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6879 gfc_add_vptr_component (e);
6880 gfc_add_component_ref (e, name);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006881
Janus Weilfd83db32011-11-07 19:41:12 +01006882 /* Recover the typespec for the expression. This is really only
6883 necessary for generic procedures, where the additional call
6884 to gfc_add_component_ref seems to throw the collection of the
6885 correct typespec. */
6886 e->ts = ts;
6887 }
Tobias Burnus36abe892013-04-18 20:59:38 +02006888 else if (new_ref)
6889 gfc_free_ref_list (new_ref);
Janus Weilfd83db32011-11-07 19:41:12 +01006890
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006891 return true;
Paul Thomas7cf078d2009-10-05 18:19:55 +00006892}
6893
Paul Thomaseece1eb2010-04-29 19:10:48 +00006894/* Resolve a typebound subroutine, or 'method'. First separate all
6895 the non-CLASS references by calling resolve_typebound_call
6896 directly. */
Paul Thomas6a943ee2010-03-12 22:00:52 +00006897
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006898static bool
Paul Thomas6a943ee2010-03-12 22:00:52 +00006899resolve_typebound_subroutine (gfc_code *code)
Paul Thomas7cf078d2009-10-05 18:19:55 +00006900{
Paul Thomas974df0f2010-07-19 18:48:44 +00006901 gfc_symbol *declared;
6902 gfc_component *c;
Paul Thomas28188742009-10-16 06:07:09 +00006903 gfc_ref *new_ref;
6904 gfc_ref *class_ref;
6905 gfc_symtree *st;
Paul Thomaseece1eb2010-04-29 19:10:48 +00006906 const char *name;
6907 gfc_typespec ts;
Paul Thomas974df0f2010-07-19 18:48:44 +00006908 gfc_expr *expr;
Janus Weilfd83db32011-11-07 19:41:12 +01006909 bool overridable;
Paul Thomas7cf078d2009-10-05 18:19:55 +00006910
Paul Thomas28188742009-10-16 06:07:09 +00006911 st = code->expr1->symtree;
Paul Thomas974df0f2010-07-19 18:48:44 +00006912
6913 /* Deal with typebound operators for CLASS objects. */
6914 expr = code->expr1->value.compcall.base_object;
Janus Weilfd83db32011-11-07 19:41:12 +01006915 overridable = !code->expr1->value.compcall.tbp->non_overridable;
Janus Weilb6c77bc2011-01-31 19:11:32 +01006916 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
Paul Thomas974df0f2010-07-19 18:48:44 +00006917 {
Paul Thomas94fae142012-01-02 12:46:08 +00006918 /* If the base_object is not a variable, the corresponding actual
6919 argument expression must be stored in e->base_expression so
6920 that the corresponding tree temporary can be used as the base
6921 object in gfc_conv_procedure_call. */
6922 if (expr->expr_type != EXPR_VARIABLE)
6923 {
6924 gfc_actual_arglist *args;
6925
6926 args= code->expr1->value.function.actual;
6927 for (; args; args = args->next)
6928 if (expr == args->expr)
6929 expr = args->expr;
6930 }
6931
Paul Thomas974df0f2010-07-19 18:48:44 +00006932 /* Since the typebound operators are generic, we have to ensure
6933 that any delays in resolution are corrected and that the vtab
6934 is present. */
Janus Weilb6c77bc2011-01-31 19:11:32 +01006935 declared = expr->ts.u.derived;
Fritz Reesef6288c22016-05-07 23:16:23 +00006936 c = gfc_find_component (declared, "_vptr", true, true, NULL);
Paul Thomas974df0f2010-07-19 18:48:44 +00006937 if (c->ts.u.derived == NULL)
6938 c->ts.u.derived = gfc_find_derived_vtab (declared);
6939
Janus Weil744868a2014-12-16 09:15:38 +01006940 if (!resolve_typebound_call (code, &name, NULL))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006941 return false;
Paul Thomas974df0f2010-07-19 18:48:44 +00006942
6943 /* Use the generic name if it is there. */
6944 name = name ? name : code->expr1->value.function.esym->name;
6945 code->expr1->symtree = expr->symtree;
Janus Weilb6c77bc2011-01-31 19:11:32 +01006946 code->expr1->ref = gfc_copy_ref (expr->ref);
Paul Thomas94fae142012-01-02 12:46:08 +00006947
6948 /* Trim away the extraneous references that emerge from nested
Martin Liskae53b6e52022-01-14 16:57:02 +01006949 use of interface.cc (extend_expr). */
Paul Thomas94fae142012-01-02 12:46:08 +00006950 get_declared_from_expr (&class_ref, NULL, code->expr1, false);
6951 if (class_ref && class_ref->next)
6952 {
6953 gfc_free_ref_list (class_ref->next);
6954 class_ref->next = NULL;
6955 }
6956 else if (code->expr1->ref && !class_ref)
6957 {
6958 gfc_free_ref_list (code->expr1->ref);
6959 code->expr1->ref = NULL;
6960 }
6961
6962 /* Now use the procedure in the vtable. */
Janus Weilb04533a2010-11-09 11:39:46 +01006963 gfc_add_vptr_component (code->expr1);
Paul Thomas974df0f2010-07-19 18:48:44 +00006964 gfc_add_component_ref (code->expr1, name);
6965 code->expr1->value.function.esym = NULL;
Paul Thomas94fae142012-01-02 12:46:08 +00006966 if (expr->expr_type != EXPR_VARIABLE)
6967 code->expr1->base_expr = expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006968 return true;
Paul Thomas974df0f2010-07-19 18:48:44 +00006969 }
6970
Paul Thomas6a943ee2010-03-12 22:00:52 +00006971 if (st == NULL)
Janus Weil744868a2014-12-16 09:15:38 +01006972 return resolve_typebound_call (code, NULL, NULL);
Paul Thomas7cf078d2009-10-05 18:19:55 +00006973
Tobias Burnusde89b572019-12-20 11:35:20 +00006974 if (!gfc_resolve_ref (code->expr1))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006975 return false;
Janus Weilf1a0b752010-06-09 16:14:08 +02006976
Paul Thomas28188742009-10-16 06:07:09 +00006977 /* Get the CLASS declared type. */
Paul Thomas94fae142012-01-02 12:46:08 +00006978 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
Paul Thomas28188742009-10-16 06:07:09 +00006979
6980 /* Weed out cases of the ultimate component being a derived type. */
Fritz Reesef6288c22016-05-07 23:16:23 +00006981 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type))
Paul Thomaseece1eb2010-04-29 19:10:48 +00006982 || (!class_ref && st->n.sym->ts.type != BT_CLASS))
Paul Thomas28188742009-10-16 06:07:09 +00006983 {
6984 gfc_free_ref_list (new_ref);
Janus Weil744868a2014-12-16 09:15:38 +01006985 return resolve_typebound_call (code, NULL, NULL);
Janus Weilab7306e2010-07-15 15:36:28 +02006986 }
Paul Thomasf116b2f2009-10-20 04:16:02 +00006987
Janus Weil744868a2014-12-16 09:15:38 +01006988 if (!resolve_typebound_call (code, &name, &overridable))
Tobias Burnusefb63362012-10-04 19:32:06 +02006989 {
6990 gfc_free_ref_list (new_ref);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03006991 return false;
Tobias Burnusefb63362012-10-04 19:32:06 +02006992 }
Paul Thomaseece1eb2010-04-29 19:10:48 +00006993 ts = code->expr1->ts;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02006994
Janus Weilfd83db32011-11-07 19:41:12 +01006995 if (overridable)
6996 {
6997 /* Convert the expression to a procedure pointer component call. */
6998 code->expr1->value.function.esym = NULL;
6999 code->expr1->symtree = st;
Paul Thomas7cf078d2009-10-05 18:19:55 +00007000
Janus Weilfd83db32011-11-07 19:41:12 +01007001 if (new_ref)
7002 code->expr1->ref = new_ref;
Paul Thomas7cf078d2009-10-05 18:19:55 +00007003
Janus Weilfd83db32011-11-07 19:41:12 +01007004 /* '_vptr' points to the vtab, which contains the procedure pointers. */
7005 gfc_add_vptr_component (code->expr1);
7006 gfc_add_component_ref (code->expr1, name);
Paul Thomas7cf078d2009-10-05 18:19:55 +00007007
Janus Weilfd83db32011-11-07 19:41:12 +01007008 /* Recover the typespec for the expression. This is really only
7009 necessary for generic procedures, where the additional call
7010 to gfc_add_component_ref seems to throw the collection of the
7011 correct typespec. */
7012 code->expr1->ts = ts;
7013 }
Tobias Burnusadede542013-04-15 11:40:28 +02007014 else if (new_ref)
7015 gfc_free_ref_list (new_ref);
Janus Weilfd83db32011-11-07 19:41:12 +01007016
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007017 return true;
Daniel Kraft8e1f7522008-08-28 20:03:02 +02007018}
7019
7020
Janus Weil713485c2009-05-06 23:17:16 +02007021/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
7022
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007023static bool
Janus Weil713485c2009-05-06 23:17:16 +02007024resolve_ppc_call (gfc_code* c)
7025{
7026 gfc_component *comp;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007027
Mikael Morin2a573572012-08-14 16:28:29 +00007028 comp = gfc_get_proc_ptr_comp (c->expr1);
7029 gcc_assert (comp != NULL);
Janus Weil713485c2009-05-06 23:17:16 +02007030
Steven G. Kargla5139272009-05-13 20:49:13 +00007031 c->resolved_sym = c->expr1->symtree->n.sym;
7032 c->expr1->expr_type = EXPR_VARIABLE;
Janus Weil713485c2009-05-06 23:17:16 +02007033
7034 if (!comp->attr.subroutine)
Steven G. Kargla5139272009-05-13 20:49:13 +00007035 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
Janus Weil713485c2009-05-06 23:17:16 +02007036
Tobias Burnusde89b572019-12-20 11:35:20 +00007037 if (!gfc_resolve_ref (c->expr1))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007038 return false;
Janus Weile35bbb22009-05-18 16:44:55 +02007039
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007040 if (!update_ppc_arglist (c->expr1))
7041 return false;
Janus Weil90661f22009-07-25 13:56:35 +02007042
7043 c->ext.actual = c->expr1->value.compcall.actual;
7044
Paul Thomas22c23882014-10-18 14:35:51 +00007045 if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc,
7046 !(comp->ts.interface
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007047 && comp->ts.interface->formal)))
7048 return false;
Janus Weil713485c2009-05-06 23:17:16 +02007049
Janus Weil59308762014-12-14 13:04:49 +01007050 if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
7051 return false;
7052
Janus Weil7e196f82009-06-24 12:59:56 +02007053 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
Janus Weil713485c2009-05-06 23:17:16 +02007054
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007055 return true;
Janus Weil713485c2009-05-06 23:17:16 +02007056}
7057
7058
7059/* Resolve a Function Call to a Procedure Pointer Component (Function). */
7060
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007061static bool
Janus Weil713485c2009-05-06 23:17:16 +02007062resolve_expr_ppc (gfc_expr* e)
7063{
7064 gfc_component *comp;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007065
Mikael Morin2a573572012-08-14 16:28:29 +00007066 comp = gfc_get_proc_ptr_comp (e);
7067 gcc_assert (comp != NULL);
Janus Weil713485c2009-05-06 23:17:16 +02007068
7069 /* Convert to EXPR_FUNCTION. */
7070 e->expr_type = EXPR_FUNCTION;
7071 e->value.function.isym = NULL;
7072 e->value.function.actual = e->value.compcall.actual;
7073 e->ts = comp->ts;
Janus Weilc74b74a2009-05-25 16:48:24 +02007074 if (comp->as != NULL)
7075 e->rank = comp->as->rank;
Janus Weil713485c2009-05-06 23:17:16 +02007076
7077 if (!comp->attr.function)
7078 gfc_add_function (&comp->attr, comp->name, &e->where);
7079
Tobias Burnusde89b572019-12-20 11:35:20 +00007080 if (!gfc_resolve_ref (e))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007081 return false;
Janus Weile35bbb22009-05-18 16:44:55 +02007082
Paul Thomas22c23882014-10-18 14:35:51 +00007083 if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
7084 !(comp->ts.interface
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007085 && comp->ts.interface->formal)))
7086 return false;
Janus Weil713485c2009-05-06 23:17:16 +02007087
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007088 if (!update_ppc_arglist (e))
7089 return false;
Janus Weil90661f22009-07-25 13:56:35 +02007090
Janus Weil59308762014-12-14 13:04:49 +01007091 if (!check_pure_function(e))
7092 return false;
7093
Janus Weil7e196f82009-06-24 12:59:56 +02007094 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
Janus Weil713485c2009-05-06 23:17:16 +02007095
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007096 return true;
Janus Weil713485c2009-05-06 23:17:16 +02007097}
7098
7099
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007100static bool
7101gfc_is_expandable_expr (gfc_expr *e)
7102{
7103 gfc_constructor *con;
7104
7105 if (e->expr_type == EXPR_ARRAY)
7106 {
7107 /* Traverse the constructor looking for variables that are flavor
7108 parameter. Parameters must be expanded since they are fully used at
7109 compile time. */
Jerry DeLisleb7e75772010-04-13 01:59:35 +00007110 con = gfc_constructor_first (e->value.constructor);
7111 for (; con; con = gfc_constructor_next (con))
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007112 {
7113 if (con->expr->expr_type == EXPR_VARIABLE
Jerry DeLisleb7e75772010-04-13 01:59:35 +00007114 && con->expr->symtree
7115 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007116 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
7117 return true;
7118 if (con->expr->expr_type == EXPR_ARRAY
Jerry DeLisleb7e75772010-04-13 01:59:35 +00007119 && gfc_is_expandable_expr (con->expr))
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007120 return true;
7121 }
7122 }
7123
7124 return false;
7125}
7126
Paul Thomasdea71ad2017-02-19 18:27:14 +00007127
7128/* Sometimes variables in specification expressions of the result
7129 of module procedures in submodules wind up not being the 'real'
7130 dummy. Find this, if possible, in the namespace of the first
7131 formal argument. */
7132
7133static void
7134fixup_unique_dummy (gfc_expr *e)
7135{
7136 gfc_symtree *st = NULL;
7137 gfc_symbol *s = NULL;
7138
Harald Anlaufc1a2cf82021-01-14 19:17:05 +01007139 if (e->symtree->n.sym->ns->proc_name
Paul Thomasdea71ad2017-02-19 18:27:14 +00007140 && e->symtree->n.sym->ns->proc_name->formal)
7141 s = e->symtree->n.sym->ns->proc_name->formal->sym;
7142
7143 if (s != NULL)
7144 st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name);
7145
7146 if (st != NULL
7147 && st->n.sym != NULL
7148 && st->n.sym->attr.dummy)
7149 e->symtree = st;
7150}
7151
Diego Novillo6de9cd92004-05-13 02:41:07 -04007152/* Resolve an expression. That is, make sure that types of operands agree
7153 with their operators, intrinsic operators are converted to function calls
7154 for overloaded types and unresolved function references are resolved. */
7155
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007156bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007157gfc_resolve_expr (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007158{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007159 bool t;
Tobias Burnusc62c6622012-07-20 07:56:37 +02007160 bool inquiry_save, actual_arg_save, first_actual_arg_save;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007161
Paul Thomas70570ec2019-09-01 12:53:02 +00007162 if (e == NULL || e->do_not_resolve_again)
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007163 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007164
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007165 /* inquiry_argument only applies to variables. */
7166 inquiry_save = inquiry_argument;
Tobias Burnusc62c6622012-07-20 07:56:37 +02007167 actual_arg_save = actual_arg;
7168 first_actual_arg_save = first_actual_arg;
7169
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007170 if (e->expr_type != EXPR_VARIABLE)
Tobias Burnusc62c6622012-07-20 07:56:37 +02007171 {
7172 inquiry_argument = false;
7173 actual_arg = false;
7174 first_actual_arg = false;
7175 }
Paul Thomasdea71ad2017-02-19 18:27:14 +00007176 else if (e->symtree != NULL
Harald Anlaufc1a2cf82021-01-14 19:17:05 +01007177 && *e->symtree->name == '@'
7178 && e->symtree->n.sym->attr.dummy)
Paul Thomasdea71ad2017-02-19 18:27:14 +00007179 {
7180 /* Deal with submodule specification expressions that are not
Martin Liskae53b6e52022-01-14 16:57:02 +01007181 found to be referenced in module.cc(read_cleanup). */
Paul Thomasdea71ad2017-02-19 18:27:14 +00007182 fixup_unique_dummy (e);
7183 }
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007184
Diego Novillo6de9cd92004-05-13 02:41:07 -04007185 switch (e->expr_type)
7186 {
7187 case EXPR_OP:
7188 t = resolve_operator (e);
7189 break;
7190
7191 case EXPR_FUNCTION:
Diego Novillo6de9cd92004-05-13 02:41:07 -04007192 case EXPR_VARIABLE:
Paul Thomaseb77cdd2007-05-12 06:19:43 +00007193
7194 if (check_host_association (e))
7195 t = resolve_function (e);
7196 else
Tobias Burnus8a8d1a12014-05-08 19:00:07 +02007197 t = resolve_variable (e);
Paul Thomas07368af2007-08-30 22:10:55 +00007198
Janus Weilbc21d312009-08-13 21:46:46 +02007199 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
Tobias Schlüter9de88092007-10-08 22:54:47 +02007200 && e->ref->type != REF_SUBSTRING)
Paul Thomas07368af2007-08-30 22:10:55 +00007201 gfc_resolve_substring_charlen (e);
7202
Diego Novillo6de9cd92004-05-13 02:41:07 -04007203 break;
7204
Daniel Kraft8e1f7522008-08-28 20:03:02 +02007205 case EXPR_COMPCALL:
Paul Thomas6a943ee2010-03-12 22:00:52 +00007206 t = resolve_typebound_function (e);
Daniel Kraft8e1f7522008-08-28 20:03:02 +02007207 break;
7208
Diego Novillo6de9cd92004-05-13 02:41:07 -04007209 case EXPR_SUBSTRING:
Tobias Burnusde89b572019-12-20 11:35:20 +00007210 t = gfc_resolve_ref (e);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007211 break;
7212
7213 case EXPR_CONSTANT:
7214 case EXPR_NULL:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007215 t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007216 break;
7217
Janus Weil713485c2009-05-06 23:17:16 +02007218 case EXPR_PPC:
7219 t = resolve_expr_ppc (e);
7220 break;
7221
Diego Novillo6de9cd92004-05-13 02:41:07 -04007222 case EXPR_ARRAY:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007223 t = false;
Tobias Burnusde89b572019-12-20 11:35:20 +00007224 if (!gfc_resolve_ref (e))
Diego Novillo6de9cd92004-05-13 02:41:07 -04007225 break;
7226
7227 t = gfc_resolve_array_constructor (e);
7228 /* Also try to expand a constructor. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007229 if (t)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007230 {
Tobias Burnusde89b572019-12-20 11:35:20 +00007231 gfc_expression_rank (e);
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007232 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
Tobias Burnus928f0492010-07-06 22:56:07 +02007233 gfc_expand_constructor (e, false);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007234 }
7235
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007236 /* This provides the opportunity for the length of constructors with
Kazu Hirata86bf5202007-07-07 13:15:40 +00007237 character valued function elements to propagate the string length
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007238 to the expression. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007239 if (t && e->ts.type == BT_CHARACTER)
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007240 {
7241 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00007242 here rather then add a duplicate test for it above. */
Tobias Burnus928f0492010-07-06 22:56:07 +02007243 gfc_expand_constructor (e, false);
Jerry DeLislef2ff5772010-01-09 17:47:04 +00007244 t = gfc_resolve_character_array_constructor (e);
7245 }
Paul Thomas18559152006-07-04 20:15:52 +00007246
Diego Novillo6de9cd92004-05-13 02:41:07 -04007247 break;
7248
7249 case EXPR_STRUCTURE:
Tobias Burnusde89b572019-12-20 11:35:20 +00007250 t = gfc_resolve_ref (e);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007251 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007252 break;
7253
Janus Weil80f95222010-08-19 00:32:22 +02007254 t = resolve_structure_cons (e, 0);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007255 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007256 break;
7257
7258 t = gfc_simplify_expr (e, 0);
7259 break;
7260
7261 default:
7262 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
7263 }
7264
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007265 if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl)
Paul Thomas07368af2007-08-30 22:10:55 +00007266 fixup_charlen (e);
7267
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007268 inquiry_argument = inquiry_save;
Tobias Burnusc62c6622012-07-20 07:56:37 +02007269 actual_arg = actual_arg_save;
7270 first_actual_arg = first_actual_arg_save;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007271
Paul Thomas70570ec2019-09-01 12:53:02 +00007272 /* For some reason, resolving these expressions a second time mangles
7273 the typespec of the expression itself. */
7274 if (t && e->expr_type == EXPR_VARIABLE
7275 && e->symtree->n.sym->attr.select_rank_temporary
7276 && UNLIMITED_POLY (e->symtree->n.sym))
7277 e->do_not_resolve_again = 1;
7278
Diego Novillo6de9cd92004-05-13 02:41:07 -04007279 return t;
7280}
7281
7282
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007283/* Resolve an expression from an iterator. They must be scalar and have
7284 INTEGER or (optionally) REAL type. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04007285
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007286static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007287gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
7288 const char *name_msgid)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007289{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007290 if (!gfc_resolve_expr (expr))
7291 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007292
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007293 if (expr->rank != 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007294 {
Francois-Xavier Coudert31043f62005-09-17 20:58:01 +02007295 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007296 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007297 }
7298
Jerry DeLisle79e78402007-06-22 01:50:09 +00007299 if (expr->ts.type != BT_INTEGER)
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007300 {
Jerry DeLisle79e78402007-06-22 01:50:09 +00007301 if (expr->ts.type == BT_REAL)
7302 {
7303 if (real_ok)
7304 return gfc_notify_std (GFC_STD_F95_DEL,
Janus Weil9717f7a2012-07-17 23:51:20 +02007305 "%s at %L must be integer",
Jerry DeLisle79e78402007-06-22 01:50:09 +00007306 _(name_msgid), &expr->where);
7307 else
7308 {
7309 gfc_error ("%s at %L must be INTEGER", _(name_msgid),
7310 &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007311 return false;
Jerry DeLisle79e78402007-06-22 01:50:09 +00007312 }
7313 }
Francois-Xavier Coudert31043f62005-09-17 20:58:01 +02007314 else
Jerry DeLisle79e78402007-06-22 01:50:09 +00007315 {
7316 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007317 return false;
Jerry DeLisle79e78402007-06-22 01:50:09 +00007318 }
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007319 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007320 return true;
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007321}
7322
7323
7324/* Resolve the expressions in an iterator structure. If REAL_OK is
Tobias Burnus57bf28ea2012-10-28 17:57:12 +01007325 false allow only INTEGER type iterators, otherwise allow REAL types.
7326 Set own_scope to true for ac-implied-do and data-implied-do as those
7327 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007328
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007329bool
Tobias Burnus57bf28ea2012-10-28 17:57:12 +01007330gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope)
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007331{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007332 if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable"))
7333 return false;
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007334
Paul Thomas22c23882014-10-18 14:35:51 +00007335 if (!gfc_check_vardef_context (iter->var, false, false, own_scope,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007336 _("iterator variable")))
7337 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007338
Paul Thomas22c23882014-10-18 14:35:51 +00007339 if (!gfc_resolve_iterator_expr (iter->start, real_ok,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007340 "Start expression in DO loop"))
7341 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007342
Paul Thomas22c23882014-10-18 14:35:51 +00007343 if (!gfc_resolve_iterator_expr (iter->end, real_ok,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007344 "End expression in DO loop"))
7345 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007346
Paul Thomas22c23882014-10-18 14:35:51 +00007347 if (!gfc_resolve_iterator_expr (iter->step, real_ok,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007348 "Step expression in DO loop"))
7349 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007350
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007351 /* Convert start, end, and step to the same type as var. */
7352 if (iter->start->ts.kind != iter->var->ts.kind
7353 || iter->start->ts.type != iter->var->ts.type)
Steven G. Karglc8517222016-07-28 19:04:12 +00007354 gfc_convert_type (iter->start, &iter->var->ts, 1);
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007355
7356 if (iter->end->ts.kind != iter->var->ts.kind
7357 || iter->end->ts.type != iter->var->ts.type)
Steven G. Karglc8517222016-07-28 19:04:12 +00007358 gfc_convert_type (iter->end, &iter->var->ts, 1);
Steven G. Kargl8d5cfa22004-12-12 20:27:02 +00007359
7360 if (iter->step->ts.kind != iter->var->ts.kind
7361 || iter->step->ts.type != iter->var->ts.type)
Steven G. Karglc8517222016-07-28 19:04:12 +00007362 gfc_convert_type (iter->step, &iter->var->ts, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007363
Thomas Koenig3e0679c2019-09-15 14:57:48 +00007364 if (iter->step->expr_type == EXPR_CONSTANT)
7365 {
7366 if ((iter->step->ts.type == BT_INTEGER
7367 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
7368 || (iter->step->ts.type == BT_REAL
7369 && mpfr_sgn (iter->step->value.real) == 0))
7370 {
7371 gfc_error ("Step expression in DO loop at %L cannot be zero",
7372 &iter->step->where);
7373 return false;
7374 }
7375 }
7376
Tobias Burnusdc186962009-03-28 14:06:30 +01007377 if (iter->start->expr_type == EXPR_CONSTANT
7378 && iter->end->expr_type == EXPR_CONSTANT
7379 && iter->step->expr_type == EXPR_CONSTANT)
7380 {
7381 int sgn, cmp;
7382 if (iter->start->ts.type == BT_INTEGER)
7383 {
7384 sgn = mpz_cmp_ui (iter->step->value.integer, 0);
7385 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer);
7386 }
7387 else
7388 {
7389 sgn = mpfr_sgn (iter->step->value.real);
7390 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
7391 }
Tobias Burnus73e42ee2014-11-30 09:33:25 +01007392 if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +00007393 gfc_warning (OPT_Wzerotrip,
7394 "DO loop at %L will be executed zero times",
Tobias Burnusdc186962009-03-28 14:06:30 +01007395 &iter->step->where);
7396 }
7397
Martin Liska1c122092016-07-07 15:15:39 +02007398 if (iter->end->expr_type == EXPR_CONSTANT
7399 && iter->end->ts.type == BT_INTEGER
7400 && iter->step->expr_type == EXPR_CONSTANT
7401 && iter->step->ts.type == BT_INTEGER
7402 && (mpz_cmp_si (iter->step->value.integer, -1L) == 0
7403 || mpz_cmp_si (iter->step->value.integer, 1L) == 0))
7404 {
7405 bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0;
7406 int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false);
7407
7408 if (is_step_positive
7409 && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0)
7410 gfc_warning (OPT_Wundefined_do_loop,
7411 "DO loop at %L is undefined as it overflows",
7412 &iter->step->where);
7413 else if (!is_step_positive
7414 && mpz_cmp (iter->end->value.integer,
7415 gfc_integer_kinds[k].min_int) == 0)
7416 gfc_warning (OPT_Wundefined_do_loop,
7417 "DO loop at %L is undefined as it underflows",
7418 &iter->step->where);
7419 }
7420
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007421 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007422}
7423
7424
Paul Thomas640670c2007-10-29 14:13:44 +00007425/* Traversal function for find_forall_index. f == 2 signals that
7426 that variable itself is not to be checked - only the references. */
7427
7428static bool
7429forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
7430{
Paul Thomas908a2232007-11-27 20:47:55 +00007431 if (expr->expr_type != EXPR_VARIABLE)
7432 return false;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00007433
Paul Thomas640670c2007-10-29 14:13:44 +00007434 /* A scalar assignment */
7435 if (!expr->ref || *f == 1)
7436 {
7437 if (expr->symtree->n.sym == sym)
7438 return true;
7439 else
7440 return false;
7441 }
7442
7443 if (*f == 2)
7444 *f = 1;
7445 return false;
7446}
7447
7448
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007449/* Check whether the FORALL index appears in the expression or not.
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007450 Returns true if SYM is found in EXPR. */
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007451
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007452bool
Paul Thomas640670c2007-10-29 14:13:44 +00007453find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007454{
Paul Thomas640670c2007-10-29 14:13:44 +00007455 if (gfc_traverse_expr (expr, sym, forall_index, f))
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007456 return true;
Paul Thomas640670c2007-10-29 14:13:44 +00007457 else
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007458 return false;
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007459}
7460
7461
Steven G. Kargl1c547412006-01-03 22:01:10 +00007462/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
7463 to be a scalar INTEGER variable. The subscripts and stride are scalar
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007464 INTEGERs, and if stride is a constant it must be nonzero.
7465 Furthermore "A subscript or stride in a forall-triplet-spec shall
7466 not contain a reference to any index-name in the
7467 forall-triplet-spec-list in which it appears." (7.5.4.1) */
Diego Novillo6de9cd92004-05-13 02:41:07 -04007468
7469static void
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007470resolve_forall_iterators (gfc_forall_iterator *it)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007471{
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007472 gfc_forall_iterator *iter, *iter2;
7473
7474 for (iter = it; iter; iter = iter->next)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007475 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007476 if (gfc_resolve_expr (iter->var)
Steven G. Kargl1c547412006-01-03 22:01:10 +00007477 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
7478 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
Diego Novillo6de9cd92004-05-13 02:41:07 -04007479 &iter->var->where);
7480
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007481 if (gfc_resolve_expr (iter->start)
Steven G. Kargl1c547412006-01-03 22:01:10 +00007482 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
7483 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
Diego Novillo6de9cd92004-05-13 02:41:07 -04007484 &iter->start->where);
7485 if (iter->var->ts.kind != iter->start->ts.kind)
Francois-Xavier Coudert7298eef2011-11-09 09:51:49 +00007486 gfc_convert_type (iter->start, &iter->var->ts, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007487
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007488 if (gfc_resolve_expr (iter->end)
Steven G. Kargl1c547412006-01-03 22:01:10 +00007489 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
7490 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
Diego Novillo6de9cd92004-05-13 02:41:07 -04007491 &iter->end->where);
7492 if (iter->var->ts.kind != iter->end->ts.kind)
Francois-Xavier Coudert7298eef2011-11-09 09:51:49 +00007493 gfc_convert_type (iter->end, &iter->var->ts, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007494
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007495 if (gfc_resolve_expr (iter->stride))
Steven G. Kargl1c547412006-01-03 22:01:10 +00007496 {
7497 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
7498 gfc_error ("FORALL stride expression at %L must be a scalar %s",
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007499 &iter->stride->where, "INTEGER");
Steven G. Kargl1c547412006-01-03 22:01:10 +00007500
7501 if (iter->stride->expr_type == EXPR_CONSTANT
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007502 && mpz_cmp_ui (iter->stride->value.integer, 0) == 0)
Steven G. Kargl1c547412006-01-03 22:01:10 +00007503 gfc_error ("FORALL stride expression at %L cannot be zero",
7504 &iter->stride->where);
7505 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007506 if (iter->var->ts.kind != iter->stride->ts.kind)
Francois-Xavier Coudert7298eef2011-11-09 09:51:49 +00007507 gfc_convert_type (iter->stride, &iter->var->ts, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007508 }
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007509
7510 for (iter = it; iter; iter = iter->next)
7511 for (iter2 = iter; iter2; iter2 = iter2->next)
7512 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007513 if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0)
7514 || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0)
7515 || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0))
Tobias Burnusa4d9b222014-12-13 00:12:06 +01007516 gfc_error ("FORALL index %qs may not appear in triplet "
Tobias Schlüterac5ba372007-10-06 10:55:30 +02007517 "specification at %L", iter->var->symtree->name,
7518 &iter2->start->where);
7519 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007520}
7521
7522
Erik Edelmann84515842005-09-23 00:52:09 +03007523/* Given a pointer to a symbol that is a derived type, see if it's
7524 inaccessible, i.e. if it's defined in another module and the components are
7525 PRIVATE. The search is recursive if necessary. Returns zero if no
7526 inaccessible components are found, nonzero otherwise. */
7527
7528static int
7529derived_inaccessible (gfc_symbol *sym)
7530{
7531 gfc_component *c;
7532
Daniel Franke3dbf6532007-08-06 16:53:19 -04007533 if (sym->attr.use_assoc && sym->attr.private_comp)
Erik Edelmann84515842005-09-23 00:52:09 +03007534 return 1;
7535
7536 for (c = sym->components; c; c = c->next)
7537 {
Paul Thomase73d3ca2016-08-31 05:36:22 +00007538 /* Prevent an infinite loop through this function. */
7539 if (c->ts.type == BT_DERIVED && c->attr.pointer
7540 && sym == c->ts.u.derived)
7541 continue;
7542
Janus Weilbc21d312009-08-13 21:46:46 +02007543 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007544 return 1;
Erik Edelmann84515842005-09-23 00:52:09 +03007545 }
7546
7547 return 0;
7548}
7549
7550
Diego Novillo6de9cd92004-05-13 02:41:07 -04007551/* Resolve the argument of a deallocate expression. The expression must be
7552 a pointer or a full array. */
7553
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007554static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007555resolve_deallocate_expr (gfc_expr *e)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007556{
7557 symbol_attribute attr;
Daniel Kraft8c91ab32010-09-23 10:37:54 +02007558 int allocatable, pointer;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007559 gfc_ref *ref;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007560 gfc_symbol *sym;
7561 gfc_component *c;
Paul Thomas8b704312012-12-20 00:15:00 +00007562 bool unlimited;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007563
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007564 if (!gfc_resolve_expr (e))
7565 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007566
Diego Novillo6de9cd92004-05-13 02:41:07 -04007567 if (e->expr_type != EXPR_VARIABLE)
7568 goto bad;
7569
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007570 sym = e->symtree->n.sym;
Paul Thomas8b704312012-12-20 00:15:00 +00007571 unlimited = UNLIMITED_POLY(sym);
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007572
7573 if (sym->ts.type == BT_CLASS)
7574 {
Janus Weil7a08eda12010-05-30 23:56:11 +02007575 allocatable = CLASS_DATA (sym)->attr.allocatable;
Janus Weild40477b2010-07-11 09:55:11 +02007576 pointer = CLASS_DATA (sym)->attr.class_pointer;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007577 }
7578 else
7579 {
7580 allocatable = sym->attr.allocatable;
7581 pointer = sym->attr.pointer;
7582 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007583 for (ref = e->ref; ref; ref = ref->next)
Tobias Burnusf17faca2007-01-05 10:08:37 +01007584 {
Tobias Burnusf17faca2007-01-05 10:08:37 +01007585 switch (ref->type)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007586 {
7587 case REF_ARRAY:
Tobias Burnusbadd9e62011-07-16 19:31:13 +02007588 if (ref->u.ar.type != AR_FULL
7589 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
7590 && ref->u.ar.codimen && gfc_ref_this_image (ref)))
Tobias Burnusf17faca2007-01-05 10:08:37 +01007591 allocatable = 0;
7592 break;
7593
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007594 case REF_COMPONENT:
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007595 c = ref->u.c.component;
7596 if (c->ts.type == BT_CLASS)
7597 {
Janus Weil7a08eda12010-05-30 23:56:11 +02007598 allocatable = CLASS_DATA (c)->attr.allocatable;
Janus Weild40477b2010-07-11 09:55:11 +02007599 pointer = CLASS_DATA (c)->attr.class_pointer;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007600 }
7601 else
7602 {
7603 allocatable = c->attr.allocatable;
7604 pointer = c->attr.pointer;
7605 }
Tobias Burnusf17faca2007-01-05 10:08:37 +01007606 break;
7607
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007608 case REF_SUBSTRING:
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00007609 case REF_INQUIRY:
Diego Novillo6de9cd92004-05-13 02:41:07 -04007610 allocatable = 0;
Tobias Burnusf17faca2007-01-05 10:08:37 +01007611 break;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007612 }
Tobias Burnusf17faca2007-01-05 10:08:37 +01007613 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007614
Tobias Burnusf17faca2007-01-05 10:08:37 +01007615 attr = gfc_expr_attr (e);
Diego Novillo6de9cd92004-05-13 02:41:07 -04007616
Paul Thomas8b704312012-12-20 00:15:00 +00007617 if (allocatable == 0 && attr.pointer == 0 && !unlimited)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007618 {
7619 bad:
Steven G. Kargl37596342009-03-31 04:38:12 +00007620 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7621 &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007622 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007623 }
7624
Tobias Burnus5aacb112011-05-27 23:29:19 +02007625 /* F2008, C644. */
7626 if (gfc_is_coindexed (e))
7627 {
7628 gfc_error ("Coindexed allocatable object at %L", &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007629 return false;
Tobias Burnus5aacb112011-05-27 23:29:19 +02007630 }
7631
Daniel Kraft8c91ab32010-09-23 10:37:54 +02007632 if (pointer
Paul Thomas22c23882014-10-18 14:35:51 +00007633 && !gfc_check_vardef_context (e, true, true, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007634 _("DEALLOCATE object")))
7635 return false;
Paul Thomas22c23882014-10-18 14:35:51 +00007636 if (!gfc_check_vardef_context (e, false, true, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007637 _("DEALLOCATE object")))
7638 return false;
Erik Edelmannaa080382006-03-05 19:24:48 +00007639
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007640 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007641}
7642
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007643
Paul Thomas908a2232007-11-27 20:47:55 +00007644/* Returns true if the expression e contains a reference to the symbol sym. */
7645static bool
7646sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
7647{
7648 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
7649 return true;
7650
7651 return false;
7652}
7653
Jakub Jelineka68ab352008-06-06 15:01:54 +02007654bool
7655gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
Paul Thomas77726572006-10-03 21:40:24 +00007656{
Paul Thomas908a2232007-11-27 20:47:55 +00007657 return gfc_traverse_expr (e, sym, sym_in_expr, 0);
Paul Thomas77726572006-10-03 21:40:24 +00007658}
7659
Diego Novillo6de9cd92004-05-13 02:41:07 -04007660
Erik Edelmann68577e52005-10-20 01:18:07 +03007661/* Given the expression node e for an allocatable/pointer of derived type to be
7662 allocated, get the expression node to be initialized afterwards (needed for
Paul Thomas5046aff2006-10-08 16:21:55 +00007663 derived types with default initializers, and derived types with allocatable
7664 components that need nullification.) */
Erik Edelmann68577e52005-10-20 01:18:07 +03007665
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007666gfc_expr *
7667gfc_expr_to_initialize (gfc_expr *e)
Erik Edelmann68577e52005-10-20 01:18:07 +03007668{
7669 gfc_expr *result;
7670 gfc_ref *ref;
7671 int i;
7672
7673 result = gfc_copy_expr (e);
7674
7675 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7676 for (ref = result->ref; ref; ref = ref->next)
7677 if (ref->type == REF_ARRAY && ref->next == NULL)
7678 {
Paul Thomas56b070e2019-09-29 10:12:42 +00007679 if (ref->u.ar.dimen == 0
7680 && ref->u.ar.as && ref->u.ar.as->corank)
7681 return result;
7682
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007683 ref->u.ar.type = AR_FULL;
Erik Edelmann68577e52005-10-20 01:18:07 +03007684
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007685 for (i = 0; i < ref->u.ar.dimen; i++)
7686 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
Erik Edelmann68577e52005-10-20 01:18:07 +03007687
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007688 break;
Erik Edelmann68577e52005-10-20 01:18:07 +03007689 }
7690
Mikael Morin7d7212e2011-08-22 14:07:30 +00007691 gfc_free_shape (&result->shape, result->rank);
7692
7693 /* Recalculate rank, shape, etc. */
7694 gfc_resolve_expr (result);
Erik Edelmann68577e52005-10-20 01:18:07 +03007695 return result;
7696}
7697
7698
Daniel Kraft8c91ab32010-09-23 10:37:54 +02007699/* If the last ref of an expression is an array ref, return a copy of the
7700 expression with that one removed. Otherwise, a copy of the original
7701 expression. This is used for allocate-expressions and pointer assignment
7702 LHS, where there may be an array specification that needs to be stripped
7703 off when using gfc_check_vardef_context. */
7704
7705static gfc_expr*
7706remove_last_array_ref (gfc_expr* e)
7707{
7708 gfc_expr* e2;
7709 gfc_ref** r;
7710
7711 e2 = gfc_copy_expr (e);
7712 for (r = &e2->ref; *r; r = &(*r)->next)
7713 if ((*r)->type == REF_ARRAY && !(*r)->next)
7714 {
7715 gfc_free_ref_list (*r);
7716 *r = NULL;
7717 break;
7718 }
7719
7720 return e2;
7721}
7722
7723
Janus Weil8460475b42009-10-23 13:01:38 +02007724/* Used in resolve_allocate_expr to check that a allocation-object and
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00007725 a source-expr are conformable. This does not catch all possible
Janus Weil8460475b42009-10-23 13:01:38 +02007726 cases; in particular a runtime checking is needed. */
7727
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007728static bool
Janus Weil8460475b42009-10-23 13:01:38 +02007729conformable_arrays (gfc_expr *e1, gfc_expr *e2)
7730{
Janus Weil66051b62010-06-11 03:42:38 +02007731 gfc_ref *tail;
7732 for (tail = e2->ref; tail && tail->next; tail = tail->next);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00007733
Janus Weil8460475b42009-10-23 13:01:38 +02007734 /* First compare rank. */
Steven G. Kargle6e3aa02019-09-15 17:49:44 +00007735 if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
Janus Weil2ccd6f72013-12-11 15:02:44 +01007736 || (!tail && e1->rank != e2->rank))
Janus Weil8460475b42009-10-23 13:01:38 +02007737 {
7738 gfc_error ("Source-expr at %L must be scalar or have the "
7739 "same rank as the allocate-object at %L",
7740 &e1->where, &e2->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007741 return false;
Janus Weil8460475b42009-10-23 13:01:38 +02007742 }
7743
7744 if (e1->shape)
7745 {
7746 int i;
7747 mpz_t s;
7748
7749 mpz_init (s);
7750
7751 for (i = 0; i < e1->rank; i++)
7752 {
Tobias Burnusf0470cc2013-05-05 16:04:07 +02007753 if (tail->u.ar.start[i] == NULL)
7754 break;
7755
Janus Weil66051b62010-06-11 03:42:38 +02007756 if (tail->u.ar.end[i])
Janus Weil8460475b42009-10-23 13:01:38 +02007757 {
Janus Weil66051b62010-06-11 03:42:38 +02007758 mpz_set (s, tail->u.ar.end[i]->value.integer);
7759 mpz_sub (s, s, tail->u.ar.start[i]->value.integer);
Janus Weil8460475b42009-10-23 13:01:38 +02007760 mpz_add_ui (s, s, 1);
7761 }
7762 else
7763 {
Janus Weil66051b62010-06-11 03:42:38 +02007764 mpz_set (s, tail->u.ar.start[i]->value.integer);
Janus Weil8460475b42009-10-23 13:01:38 +02007765 }
7766
7767 if (mpz_cmp (e1->shape[i], s) != 0)
7768 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00007769 gfc_error ("Source-expr at %L and allocate-object at %L must "
Janus Weil8460475b42009-10-23 13:01:38 +02007770 "have the same shape", &e1->where, &e2->where);
7771 mpz_clear (s);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007772 return false;
Janus Weil8460475b42009-10-23 13:01:38 +02007773 }
7774 }
7775
7776 mpz_clear (s);
7777 }
7778
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007779 return true;
Janus Weil8460475b42009-10-23 13:01:38 +02007780}
7781
7782
Diego Novillo6de9cd92004-05-13 02:41:07 -04007783/* Resolve the expression in an ALLOCATE statement, doing the additional
7784 checks to see whether the expression is OK or not. The expression must
7785 have a trailing array reference that gives the size of the array. */
7786
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007787static bool
Andre Vehreschild17923492015-06-15 12:08:04 +02007788resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007789{
Daniel Kraft8c91ab32010-09-23 10:37:54 +02007790 int i, pointer, allocatable, dimension, is_abstract;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007791 int codimension;
Tobias Burnusc49eaa22011-04-23 12:26:38 +02007792 bool coindexed;
Paul Thomas8b704312012-12-20 00:15:00 +00007793 bool unlimited;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007794 symbol_attribute attr;
7795 gfc_ref *ref, *ref2;
Daniel Kraft8c91ab32010-09-23 10:37:54 +02007796 gfc_expr *e2;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007797 gfc_array_ref *ar;
Kai Tietz0d7d4952010-06-09 11:39:33 +00007798 gfc_symbol *sym = NULL;
Paul Thomas77726572006-10-03 21:40:24 +00007799 gfc_alloc *a;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007800 gfc_component *c;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007801 bool t;
Tobias Burnusf17faca2007-01-05 10:08:37 +01007802
Tobias Burnuseea58ad2012-05-30 08:26:09 +02007803 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007804 checking of coarrays. */
7805 for (ref = e->ref; ref; ref = ref->next)
7806 if (ref->next == NULL)
7807 break;
7808
7809 if (ref && ref->type == REF_ARRAY)
7810 ref->u.ar.in_allocate = true;
7811
Janne Blomqvist524af0d2013-04-11 00:36:58 +03007812 if (!gfc_resolve_expr (e))
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007813 goto failure;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007814
7815 /* Make sure the expression is allocatable or a pointer. If it is
7816 pointer, the next-to-last reference must be a pointer. */
7817
7818 ref2 = NULL;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007819 if (e->symtree)
7820 sym = e->symtree->n.sym;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007821
Tobias Burnusd0a98042009-10-09 22:34:35 +02007822 /* Check whether ultimate component is abstract and CLASS. */
7823 is_abstract = 0;
7824
Paul Thomas8b704312012-12-20 00:15:00 +00007825 /* Is the allocate-object unlimited polymorphic? */
7826 unlimited = UNLIMITED_POLY(e);
7827
Diego Novillo6de9cd92004-05-13 02:41:07 -04007828 if (e->expr_type != EXPR_VARIABLE)
7829 {
7830 allocatable = 0;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007831 attr = gfc_expr_attr (e);
7832 pointer = attr.pointer;
7833 dimension = attr.dimension;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007834 codimension = attr.codimension;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007835 }
7836 else
7837 {
Paul Thomasc49ea232011-12-11 20:42:23 +00007838 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007839 {
Janus Weil7a08eda12010-05-30 23:56:11 +02007840 allocatable = CLASS_DATA (sym)->attr.allocatable;
Janus Weild40477b2010-07-11 09:55:11 +02007841 pointer = CLASS_DATA (sym)->attr.class_pointer;
Janus Weil7a08eda12010-05-30 23:56:11 +02007842 dimension = CLASS_DATA (sym)->attr.dimension;
7843 codimension = CLASS_DATA (sym)->attr.codimension;
7844 is_abstract = CLASS_DATA (sym)->attr.abstract;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007845 }
7846 else
7847 {
7848 allocatable = sym->attr.allocatable;
7849 pointer = sym->attr.pointer;
7850 dimension = sym->attr.dimension;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007851 codimension = sym->attr.codimension;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007852 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007853
Tobias Burnusc49eaa22011-04-23 12:26:38 +02007854 coindexed = false;
7855
Diego Novillo6de9cd92004-05-13 02:41:07 -04007856 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007857 {
Tobias Burnusf17faca2007-01-05 10:08:37 +01007858 switch (ref->type)
7859 {
7860 case REF_ARRAY:
Tobias Burnusc49eaa22011-04-23 12:26:38 +02007861 if (ref->u.ar.codimen > 0)
7862 {
7863 int n;
7864 for (n = ref->u.ar.dimen;
7865 n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
7866 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
7867 {
7868 coindexed = true;
7869 break;
7870 }
7871 }
7872
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007873 if (ref->next != NULL)
7874 pointer = 0;
7875 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007876
Tobias Burnusf17faca2007-01-05 10:08:37 +01007877 case REF_COMPONENT:
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007878 /* F2008, C644. */
Tobias Burnusc49eaa22011-04-23 12:26:38 +02007879 if (coindexed)
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007880 {
7881 gfc_error ("Coindexed allocatable object at %L",
7882 &e->where);
7883 goto failure;
7884 }
7885
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007886 c = ref->u.c.component;
7887 if (c->ts.type == BT_CLASS)
7888 {
Janus Weil7a08eda12010-05-30 23:56:11 +02007889 allocatable = CLASS_DATA (c)->attr.allocatable;
Janus Weild40477b2010-07-11 09:55:11 +02007890 pointer = CLASS_DATA (c)->attr.class_pointer;
Janus Weil7a08eda12010-05-30 23:56:11 +02007891 dimension = CLASS_DATA (c)->attr.dimension;
7892 codimension = CLASS_DATA (c)->attr.codimension;
7893 is_abstract = CLASS_DATA (c)->attr.abstract;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007894 }
7895 else
7896 {
7897 allocatable = c->attr.allocatable;
7898 pointer = c->attr.pointer;
7899 dimension = c->attr.dimension;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007900 codimension = c->attr.codimension;
Tobias Burnusd0a98042009-10-09 22:34:35 +02007901 is_abstract = c->attr.abstract;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02007902 }
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007903 break;
Tobias Burnusf17faca2007-01-05 10:08:37 +01007904
7905 case REF_SUBSTRING:
Paul Thomasa5fbc2f2018-11-01 19:36:08 +00007906 case REF_INQUIRY:
Steven G. Kargledf1eac2007-01-20 22:01:41 +00007907 allocatable = 0;
7908 pointer = 0;
7909 break;
Tobias Burnusf17faca2007-01-05 10:08:37 +01007910 }
Daniel Kraft8e1f7522008-08-28 20:03:02 +02007911 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04007912 }
7913
Harald Anlauf9213ff12021-08-30 22:41:01 +02007914 /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data
7915 pointer or an allocatable variable. */
7916 if (allocatable == 0 && pointer == 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -04007917 {
Steven G. Kargl37596342009-03-31 04:38:12 +00007918 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7919 &e->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007920 goto failure;
Diego Novillo6de9cd92004-05-13 02:41:07 -04007921 }
7922
Janus Weil8460475b42009-10-23 13:01:38 +02007923 /* Some checks for the SOURCE tag. */
7924 if (code->expr3)
7925 {
7926 /* Check F03:C631. */
7927 if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
7928 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00007929 gfc_error ("Type of entity at %L is type incompatible with "
7930 "source-expr at %L", &e->where, &code->expr3->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007931 goto failure;
Janus Weil8460475b42009-10-23 13:01:38 +02007932 }
7933
7934 /* Check F03:C632 and restriction following Note 6.18. */
Janus Weil2ccd6f72013-12-11 15:02:44 +01007935 if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e))
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007936 goto failure;
Janus Weil8460475b42009-10-23 13:01:38 +02007937
7938 /* Check F03:C633. */
Paul Thomas8b704312012-12-20 00:15:00 +00007939 if (code->expr3->ts.kind != e->ts.kind && !unlimited)
Janus Weil8460475b42009-10-23 13:01:38 +02007940 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00007941 gfc_error ("The allocate-object at %L and the source-expr at %L "
7942 "shall have the same kind type parameter",
7943 &e->where, &code->expr3->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007944 goto failure;
Janus Weil8460475b42009-10-23 13:01:38 +02007945 }
Tobias Burnusfea54932011-06-20 23:12:39 +02007946
7947 /* Check F2008, C642. */
7948 if (code->expr3->ts.type == BT_DERIVED
Tobias Burnus3b6fa7a2011-08-18 17:10:25 +02007949 && ((codimension && gfc_expr_attr (code->expr3).lock_comp)
Tobias Burnusfea54932011-06-20 23:12:39 +02007950 || (code->expr3->ts.u.derived->from_intmod
7951 == INTMOD_ISO_FORTRAN_ENV
7952 && code->expr3->ts.u.derived->intmod_sym_id
7953 == ISOFORTRAN_LOCK_TYPE)))
7954 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00007955 gfc_error ("The source-expr at %L shall neither be of type "
Tobias Burnusfea54932011-06-20 23:12:39 +02007956 "LOCK_TYPE nor have a LOCK_TYPE component if "
7957 "allocate-object at %L is a coarray",
7958 &code->expr3->where, &e->where);
7959 goto failure;
7960 }
Tobias Burnus5df445a2015-12-02 22:59:05 +01007961
7962 /* Check TS18508, C702/C703. */
7963 if (code->expr3->ts.type == BT_DERIVED
7964 && ((codimension && gfc_expr_attr (code->expr3).event_comp)
7965 || (code->expr3->ts.u.derived->from_intmod
7966 == INTMOD_ISO_FORTRAN_ENV
7967 && code->expr3->ts.u.derived->intmod_sym_id
7968 == ISOFORTRAN_EVENT_TYPE)))
7969 {
7970 gfc_error ("The source-expr at %L shall neither be of type "
7971 "EVENT_TYPE nor have a EVENT_TYPE component if "
7972 "allocate-object at %L is a coarray",
7973 &code->expr3->where, &e->where);
7974 goto failure;
7975 }
Janus Weil8460475b42009-10-23 13:01:38 +02007976 }
Janus Weil94bff632010-06-15 20:33:58 +02007977
7978 /* Check F08:C629. */
7979 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN
7980 && !code->expr3)
Tobias Burnusd0a98042009-10-09 22:34:35 +02007981 {
7982 gcc_assert (e->ts.type == BT_CLASS);
7983 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
Janus Weil94bff632010-06-15 20:33:58 +02007984 "type-spec or source-expr", sym->name, &e->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02007985 goto failure;
Tobias Burnusd0a98042009-10-09 22:34:35 +02007986 }
7987
Andre Vehreschilde3a7c6c2015-02-06 12:22:54 +01007988 /* Check F08:C632. */
7989 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
7990 && !UNLIMITED_POLY (e))
Tobias Burnus2e0bffa2012-01-10 12:22:16 +01007991 {
Steven G. Karglbdd82c92018-01-10 23:26:15 +00007992 int cmp;
7993
7994 if (!e->ts.u.cl->length)
7995 goto failure;
7996
7997 cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
7998 code->ext.alloc.ts.u.cl->length);
Tobias Burnus2e0bffa2012-01-10 12:22:16 +01007999 if (cmp == 1 || cmp == -1 || cmp == -3)
8000 {
8001 gfc_error ("Allocating %s at %L with type-spec requires the same "
8002 "character-length parameter as in the declaration",
8003 sym->name, &e->where);
8004 goto failure;
8005 }
8006 }
8007
Daniel Kraft8c91ab32010-09-23 10:37:54 +02008008 /* In the variable definition context checks, gfc_expr_attr is used
8009 on the expression. This is fooled by the array specification
8010 present in e, thus we have to eliminate that one temporarily. */
8011 e2 = remove_last_array_ref (e);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008012 t = true;
8013 if (t && pointer)
Paul Thomas22c23882014-10-18 14:35:51 +00008014 t = gfc_check_vardef_context (e2, true, true, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008015 _("ALLOCATE object"));
8016 if (t)
Paul Thomas22c23882014-10-18 14:35:51 +00008017 t = gfc_check_vardef_context (e2, false, true, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008018 _("ALLOCATE object"));
Daniel Kraft8c91ab32010-09-23 10:37:54 +02008019 gfc_free_expr (e2);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008020 if (!t)
Daniel Kraft8c91ab32010-09-23 10:37:54 +02008021 goto failure;
Erik Edelmannaa080382006-03-05 19:24:48 +00008022
Paul Thomasc49ea232011-12-11 20:42:23 +00008023 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
8024 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
8025 {
8026 /* For class arrays, the initialization with SOURCE is done
8027 using _copy and trans_call. It is convenient to exploit that
8028 when the allocated type is different from the declared type but
8029 no SOURCE exists by setting expr3. */
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00008030 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
Paul Thomasc49ea232011-12-11 20:42:23 +00008031 }
Tobias Burnus5df445a2015-12-02 22:59:05 +01008032 else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
8033 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8034 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8035 {
8036 /* We have to zero initialize the integer variable. */
8037 code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
8038 }
Janus Weilb6ff8122010-09-04 11:29:11 +02008039
Paul Thomas8b704312012-12-20 00:15:00 +00008040 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
Janus Weile10f52d2010-08-04 21:49:19 +02008041 {
8042 /* Make sure the vtab symbol is present when
8043 the module variables are generated. */
8044 gfc_typespec ts = e->ts;
8045 if (code->expr3)
8046 ts = code->expr3->ts;
8047 else if (code->ext.alloc.ts.type == BT_DERIVED)
8048 ts = code->ext.alloc.ts;
Paul Thomas8b704312012-12-20 00:15:00 +00008049
Andre Vehreschildcc03bf72016-11-06 17:10:22 +01008050 /* Finding the vtab also publishes the type's symbol. Therefore this
8051 statement is necessary. */
Janus Weile10f52d2010-08-04 21:49:19 +02008052 gfc_find_derived_vtab (ts.u.derived);
Paul Thomas8b704312012-12-20 00:15:00 +00008053 }
8054 else if (unlimited && !UNLIMITED_POLY (code->expr3))
8055 {
8056 /* Again, make sure the vtab symbol is present when
8057 the module variables are generated. */
8058 gfc_typespec *ts = NULL;
8059 if (code->expr3)
8060 ts = &code->expr3->ts;
8061 else
8062 ts = &code->ext.alloc.ts;
8063
8064 gcc_assert (ts);
8065
Andre Vehreschildcc03bf72016-11-06 17:10:22 +01008066 /* Finding the vtab also publishes the type's symbol. Therefore this
8067 statement is necessary. */
Janus Weil7289d1c2013-12-18 23:00:53 +01008068 gfc_find_vtab (ts);
Janus Weile10f52d2010-08-04 21:49:19 +02008069 }
8070
Janus Weilb21a5442011-07-19 14:38:59 +02008071 if (dimension == 0 && codimension == 0)
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008072 goto success;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008073
Tobias Burnuseea58ad2012-05-30 08:26:09 +02008074 /* Make sure the last reference node is an array specification. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008075
Daniel Kraft8c91ab32010-09-23 10:37:54 +02008076 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008077 || (dimension && ref2->u.ar.dimen == 0))
Diego Novillo6de9cd92004-05-13 02:41:07 -04008078 {
Andre Vehreschild17923492015-06-15 12:08:04 +02008079 /* F08:C633. */
8080 if (code->expr3)
8081 {
8082 if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
8083 "in ALLOCATE statement at %L", &e->where))
8084 goto failure;
Andre Vehreschild7a85da82016-04-04 12:32:32 +02008085 if (code->expr3->rank != 0)
8086 *array_alloc_wo_spec = true;
8087 else
8088 {
8089 gfc_error ("Array specification or array-valued SOURCE= "
8090 "expression required in ALLOCATE statement at %L",
8091 &e->where);
8092 goto failure;
8093 }
Andre Vehreschild17923492015-06-15 12:08:04 +02008094 }
8095 else
8096 {
8097 gfc_error ("Array specification required in ALLOCATE statement "
8098 "at %L", &e->where);
8099 goto failure;
8100 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04008101 }
8102
Diego Novillo6de9cd92004-05-13 02:41:07 -04008103 /* Make sure that the array section reference makes sense in the
Andre Vehreschild17923492015-06-15 12:08:04 +02008104 context of an ALLOCATE specification. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008105
8106 ar = &ref2->u.ar;
8107
Tobias Burnusa3935ff2011-04-04 20:35:13 +02008108 if (codimension)
8109 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
Thomas Koenigb450b082019-03-03 13:16:40 +00008110 {
8111 switch (ar->dimen_type[i])
8112 {
8113 case DIMEN_THIS_IMAGE:
8114 gfc_error ("Coarray specification required in ALLOCATE statement "
8115 "at %L", &e->where);
8116 goto failure;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008117
Thomas Koenigb450b082019-03-03 13:16:40 +00008118 case DIMEN_RANGE:
Harald Anlauf54c5e062022-04-06 22:24:21 +02008119 /* F2018:R937:
8120 * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr
8121 */
8122 if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL)
Thomas Koenigb450b082019-03-03 13:16:40 +00008123 {
Harald Anlauf54c5e062022-04-06 22:24:21 +02008124 gfc_error ("Bad coarray specification in ALLOCATE statement "
8125 "at %L", &e->where);
Thomas Koenigb450b082019-03-03 13:16:40 +00008126 goto failure;
8127 }
8128 else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1)
8129 {
8130 gfc_error ("Upper cobound is less than lower cobound at %L",
8131 &ar->start[i]->where);
8132 goto failure;
8133 }
8134 break;
8135
8136 case DIMEN_ELEMENT:
8137 if (ar->start[i]->expr_type == EXPR_CONSTANT)
8138 {
8139 gcc_assert (ar->start[i]->ts.type == BT_INTEGER);
8140 if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0)
8141 {
8142 gfc_error ("Upper cobound is less than lower cobound "
Jakub Jelinek0d7bac62019-03-08 11:51:28 +01008143 "of 1 at %L", &ar->start[i]->where);
Thomas Koenigb450b082019-03-03 13:16:40 +00008144 goto failure;
8145 }
8146 }
8147 break;
8148
8149 case DIMEN_STAR:
8150 break;
8151
8152 default:
8153 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8154 &e->where);
8155 goto failure;
8156
8157 }
8158 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04008159 for (i = 0; i < ar->dimen; i++)
Paul Thomas77726572006-10-03 21:40:24 +00008160 {
Andre Vehreschild17923492015-06-15 12:08:04 +02008161 if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
Paul Thomas77726572006-10-03 21:40:24 +00008162 goto check_symbols;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008163
Paul Thomas77726572006-10-03 21:40:24 +00008164 switch (ar->dimen_type[i])
8165 {
8166 case DIMEN_ELEMENT:
Diego Novillo6de9cd92004-05-13 02:41:07 -04008167 break;
8168
Paul Thomas77726572006-10-03 21:40:24 +00008169 case DIMEN_RANGE:
8170 if (ar->start[i] != NULL
8171 && ar->end[i] != NULL
8172 && ar->stride[i] == NULL)
8173 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008174
Marek Polacek191816a2016-08-12 10:30:47 +00008175 /* Fall through. */
Paul Thomas77726572006-10-03 21:40:24 +00008176
8177 case DIMEN_UNKNOWN:
8178 case DIMEN_VECTOR:
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008179 case DIMEN_STAR:
Tobias Burnusa3935ff2011-04-04 20:35:13 +02008180 case DIMEN_THIS_IMAGE:
Paul Thomas77726572006-10-03 21:40:24 +00008181 gfc_error ("Bad array specification in ALLOCATE statement at %L",
8182 &e->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008183 goto failure;
Paul Thomas77726572006-10-03 21:40:24 +00008184 }
8185
8186check_symbols:
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008187 for (a = code->ext.alloc.list; a; a = a->next)
Paul Thomas77726572006-10-03 21:40:24 +00008188 {
8189 sym = a->expr->symtree->n.sym;
Paul Thomas25e8cb22006-10-04 16:54:19 +00008190
8191 /* TODO - check derived type components. */
Fritz Reesef6288c22016-05-07 23:16:23 +00008192 if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS)
Paul Thomas25e8cb22006-10-04 16:54:19 +00008193 continue;
8194
Jakub Jelineka68ab352008-06-06 15:01:54 +02008195 if ((ar->start[i] != NULL
8196 && gfc_find_sym_in_expr (sym, ar->start[i]))
8197 || (ar->end[i] != NULL
8198 && gfc_find_sym_in_expr (sym, ar->end[i])))
Paul Thomas77726572006-10-03 21:40:24 +00008199 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +01008200 gfc_error ("%qs must not appear in the array specification at "
Paul Thomas77726572006-10-03 21:40:24 +00008201 "%L in the same ALLOCATE statement where it is "
8202 "itself allocated", sym->name, &ar->where);
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008203 goto failure;
Paul Thomas77726572006-10-03 21:40:24 +00008204 }
8205 }
8206 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04008207
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008208 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
8209 {
8210 if (ar->dimen_type[i] == DIMEN_ELEMENT
8211 || ar->dimen_type[i] == DIMEN_RANGE)
8212 {
8213 if (i == (ar->dimen + ar->codimen - 1))
8214 {
8215 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
8216 "statement at %L", &e->where);
8217 goto failure;
8218 }
Tobias Burnusc6423ef2012-09-17 12:13:12 +02008219 continue;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008220 }
8221
8222 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
8223 && ar->stride[i] == NULL)
8224 break;
8225
8226 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
8227 &e->where);
8228 goto failure;
8229 }
8230
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008231success:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008232 return true;
Tobias Burnusd3a9eea2010-04-09 07:54:29 +02008233
8234failure:
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008235 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008236}
8237
Andre Vehreschild17923492015-06-15 12:08:04 +02008238
Paul Thomasb9332b02008-02-03 11:29:27 +00008239static void
8240resolve_allocate_deallocate (gfc_code *code, const char *fcn)
8241{
Steven G. Kargl37596342009-03-31 04:38:12 +00008242 gfc_expr *stat, *errmsg, *pe, *qe;
8243 gfc_alloc *a, *p, *q;
Paul Thomasb9332b02008-02-03 11:29:27 +00008244
Daniel Kraft8c91ab32010-09-23 10:37:54 +02008245 stat = code->expr1;
8246 errmsg = code->expr2;
Steven G. Kargl37596342009-03-31 04:38:12 +00008247
8248 /* Check the stat variable. */
8249 if (stat)
Paul Thomasb9332b02008-02-03 11:29:27 +00008250 {
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008251 if (!gfc_check_vardef_context (stat, false, false, false,
8252 _("STAT variable")))
8253 goto done_stat;
Steven G. Kargl37596342009-03-31 04:38:12 +00008254
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008255 if (stat->ts.type != BT_INTEGER
Thomas Koenig6c145252009-09-07 15:23:15 +00008256 || stat->rank > 0)
Steven G. Kargl37596342009-03-31 04:38:12 +00008257 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
8258 "variable", &stat->where);
8259
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008260 if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
8261 goto done_stat;
8262
8263 /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
8264 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8265 */
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008266 for (p = code->ext.alloc.list; p; p = p->next)
Steven G. Kargl37596342009-03-31 04:38:12 +00008267 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
Tobias Burnusddf58e42010-06-19 00:23:40 +02008268 {
8269 gfc_ref *ref1, *ref2;
8270 bool found = true;
8271
8272 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
8273 ref1 = ref1->next, ref2 = ref2->next)
8274 {
8275 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8276 continue;
8277 if (ref1->u.c.component->name != ref2->u.c.component->name)
8278 {
8279 found = false;
8280 break;
8281 }
8282 }
8283
8284 if (found)
8285 {
8286 gfc_error ("Stat-variable at %L shall not be %sd within "
8287 "the same %s statement", &stat->where, fcn, fcn);
8288 break;
8289 }
8290 }
Paul Thomasb9332b02008-02-03 11:29:27 +00008291 }
8292
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008293done_stat:
8294
Steven G. Kargl37596342009-03-31 04:38:12 +00008295 /* Check the errmsg variable. */
8296 if (errmsg)
8297 {
8298 if (!stat)
Joseph Myersdb30e212015-02-01 00:29:54 +00008299 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
Steven G. Kargl37596342009-03-31 04:38:12 +00008300 &errmsg->where);
8301
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008302 if (!gfc_check_vardef_context (errmsg, false, false, false,
8303 _("ERRMSG variable")))
8304 goto done_errmsg;
Steven G. Kargl37596342009-03-31 04:38:12 +00008305
Steven G. Kargl20ce6ad2018-06-04 15:54:48 +00008306 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable
8307 F18:R930 errmsg-variable is scalar-default-char-variable
8308 F18:R906 default-char-variable is variable
8309 F18:C906 default-char-variable shall be default character. */
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008310 if (errmsg->ts.type != BT_CHARACTER
Steven G. Kargl20ce6ad2018-06-04 15:54:48 +00008311 || errmsg->rank > 0
8312 || errmsg->ts.kind != gfc_default_character_kind)
8313 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
Steven G. Kargl37596342009-03-31 04:38:12 +00008314 "variable", &errmsg->where);
8315
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008316 if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
8317 goto done_errmsg;
8318
8319 /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
8320 * within the ALLOCATE or DEALLOCATE statement in which it appears ...
8321 */
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008322 for (p = code->ext.alloc.list; p; p = p->next)
Steven G. Kargl37596342009-03-31 04:38:12 +00008323 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
Tobias Burnusddf58e42010-06-19 00:23:40 +02008324 {
8325 gfc_ref *ref1, *ref2;
8326 bool found = true;
8327
8328 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
8329 ref1 = ref1->next, ref2 = ref2->next)
8330 {
8331 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
8332 continue;
8333 if (ref1->u.c.component->name != ref2->u.c.component->name)
8334 {
8335 found = false;
8336 break;
8337 }
8338 }
8339
8340 if (found)
8341 {
8342 gfc_error ("Errmsg-variable at %L shall not be %sd within "
8343 "the same %s statement", &errmsg->where, fcn, fcn);
8344 break;
8345 }
8346 }
Steven G. Kargl37596342009-03-31 04:38:12 +00008347 }
8348
Harald Anlauf7bf582e2021-07-28 19:11:27 +02008349done_errmsg:
8350
Thomas Koenigc2092de2012-07-16 20:58:04 +00008351 /* Check that an allocate-object appears only once in the statement. */
8352
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008353 for (p = code->ext.alloc.list; p; p = p->next)
Steven G. Kargl37596342009-03-31 04:38:12 +00008354 {
8355 pe = p->expr;
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008356 for (q = p->next; q; q = q->next)
Steven G. Kargl37596342009-03-31 04:38:12 +00008357 {
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008358 qe = q->expr;
8359 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
Steven G. Kargl37596342009-03-31 04:38:12 +00008360 {
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008361 /* This is a potential collision. */
8362 gfc_ref *pr = pe->ref;
8363 gfc_ref *qr = qe->ref;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00008364
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008365 /* Follow the references until
8366 a) They start to differ, in which case there is no error;
8367 you can deallocate a%b and a%c in a single statement
8368 b) Both of them stop, which is an error
8369 c) One of them stops, which is also an error. */
8370 while (1)
8371 {
8372 if (pr == NULL && qr == NULL)
8373 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00008374 gfc_error ("Allocate-object at %L also appears at %L",
8375 &pe->where, &qe->where);
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008376 break;
8377 }
8378 else if (pr != NULL && qr == NULL)
8379 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00008380 gfc_error ("Allocate-object at %L is subobject of"
8381 " object at %L", &pe->where, &qe->where);
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008382 break;
8383 }
8384 else if (pr == NULL && qr != NULL)
8385 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00008386 gfc_error ("Allocate-object at %L is subobject of"
8387 " object at %L", &qe->where, &pe->where);
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008388 break;
8389 }
8390 /* Here, pr != NULL && qr != NULL */
8391 gcc_assert(pr->type == qr->type);
8392 if (pr->type == REF_ARRAY)
8393 {
8394 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
8395 which are legal. */
8396 gcc_assert (qr->type == REF_ARRAY);
8397
8398 if (pr->next && qr->next)
8399 {
Paul Thomas474d4862012-12-02 15:23:30 +00008400 int i;
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008401 gfc_array_ref *par = &(pr->u.ar);
8402 gfc_array_ref *qar = &(qr->u.ar);
Paul Thomas474d4862012-12-02 15:23:30 +00008403
8404 for (i=0; i<par->dimen; i++)
8405 {
8406 if ((par->start[i] != NULL
8407 || qar->start[i] != NULL)
8408 && gfc_dep_compare_expr (par->start[i],
8409 qar->start[i]) != 0)
8410 goto break_label;
8411 }
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008412 }
8413 }
8414 else
8415 {
8416 if (pr->u.c.component->name != qr->u.c.component->name)
8417 break;
8418 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00008419
Thomas Koenig75fee9f2011-01-05 10:03:15 +00008420 pr = pr->next;
8421 qr = qr->next;
8422 }
Paul Thomas474d4862012-12-02 15:23:30 +00008423 break_label:
8424 ;
Steven G. Kargl37596342009-03-31 04:38:12 +00008425 }
8426 }
8427 }
Paul Thomasb9332b02008-02-03 11:29:27 +00008428
8429 if (strcmp (fcn, "ALLOCATE") == 0)
8430 {
Andre Vehreschild17923492015-06-15 12:08:04 +02008431 bool arr_alloc_wo_spec = false;
Andre Vehreschildcc03bf72016-11-06 17:10:22 +01008432
8433 /* Resolving the expr3 in the loop over all objects to allocate would
8434 execute loop invariant code for each loop item. Therefore do it just
8435 once here. */
8436 if (code->expr3 && code->expr3->mold
8437 && code->expr3->ts.type == BT_DERIVED)
8438 {
8439 /* Default initialization via MOLD (non-polymorphic). */
8440 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
8441 if (rhs != NULL)
8442 {
8443 gfc_resolve_expr (rhs);
8444 gfc_free_expr (code->expr3);
8445 code->expr3 = rhs;
8446 }
8447 }
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008448 for (a = code->ext.alloc.list; a; a = a->next)
Andre Vehreschild17923492015-06-15 12:08:04 +02008449 resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
8450
8451 if (arr_alloc_wo_spec && code->expr3)
8452 {
8453 /* Mark the allocate to have to take the array specification
8454 from the expr3. */
8455 code->ext.alloc.arr_spec_from_expr3 = 1;
8456 }
Paul Thomasb9332b02008-02-03 11:29:27 +00008457 }
8458 else
8459 {
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02008460 for (a = code->ext.alloc.list; a; a = a->next)
Paul Thomasb9332b02008-02-03 11:29:27 +00008461 resolve_deallocate_expr (a->expr);
8462 }
8463}
Diego Novillo6de9cd92004-05-13 02:41:07 -04008464
Steven G. Kargl37596342009-03-31 04:38:12 +00008465
Diego Novillo6de9cd92004-05-13 02:41:07 -04008466/************ SELECT CASE resolution subroutines ************/
8467
8468/* Callback function for our mergesort variant. Determines interval
8469 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00008470 op1 > op2. Assumes we're not dealing with the default case.
Steven G. Karglc2245502005-01-14 11:55:12 +00008471 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
8472 There are nine situations to check. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008473
8474static int
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008475compare_cases (const gfc_case *op1, const gfc_case *op2)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008476{
Steven G. Karglc2245502005-01-14 11:55:12 +00008477 int retval;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008478
Steven G. Karglc2245502005-01-14 11:55:12 +00008479 if (op1->low == NULL) /* op1 = (:L) */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008480 {
Steven G. Karglc2245502005-01-14 11:55:12 +00008481 /* op2 = (:N), so overlap. */
8482 retval = 0;
8483 /* op2 = (M:) or (M:N), L < M */
8484 if (op2->low != NULL
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008485 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
Steven G. Karglc2245502005-01-14 11:55:12 +00008486 retval = -1;
8487 }
8488 else if (op1->high == NULL) /* op1 = (K:) */
8489 {
8490 /* op2 = (M:), so overlap. */
8491 retval = 0;
8492 /* op2 = (:N) or (M:N), K > N */
8493 if (op2->high != NULL
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008494 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
Steven G. Karglc2245502005-01-14 11:55:12 +00008495 retval = 1;
8496 }
8497 else /* op1 = (K:L) */
8498 {
8499 if (op2->low == NULL) /* op2 = (:N), K > N */
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008500 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
8501 ? 1 : 0;
Steven G. Karglc2245502005-01-14 11:55:12 +00008502 else if (op2->high == NULL) /* op2 = (M:), L < M */
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008503 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
8504 ? -1 : 0;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008505 else /* op2 = (M:N) */
8506 {
Steven G. Karglc2245502005-01-14 11:55:12 +00008507 retval = 0;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008508 /* L < M */
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008509 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
Steven G. Karglc2245502005-01-14 11:55:12 +00008510 retval = -1;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008511 /* K > N */
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008512 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
Steven G. Karglc2245502005-01-14 11:55:12 +00008513 retval = 1;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008514 }
8515 }
8516
Steven G. Karglc2245502005-01-14 11:55:12 +00008517 return retval;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008518}
8519
8520
8521/* Merge-sort a double linked case list, detecting overlap in the
8522 process. LIST is the head of the double linked case list before it
8523 is sorted. Returns the head of the sorted list if we don't see any
8524 overlap, or NULL otherwise. */
8525
8526static gfc_case *
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008527check_case_overlap (gfc_case *list)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008528{
8529 gfc_case *p, *q, *e, *tail;
8530 int insize, nmerges, psize, qsize, cmp, overlap_seen;
8531
8532 /* If the passed list was empty, return immediately. */
8533 if (!list)
8534 return NULL;
8535
8536 overlap_seen = 0;
8537 insize = 1;
8538
8539 /* Loop unconditionally. The only exit from this loop is a return
8540 statement, when we've finished sorting the case list. */
8541 for (;;)
8542 {
8543 p = list;
8544 list = NULL;
8545 tail = NULL;
8546
8547 /* Count the number of merges we do in this pass. */
8548 nmerges = 0;
8549
8550 /* Loop while there exists a merge to be done. */
8551 while (p)
8552 {
8553 int i;
8554
8555 /* Count this merge. */
8556 nmerges++;
8557
Steven G. Kargl5352b892005-01-16 12:51:04 +00008558 /* Cut the list in two pieces by stepping INSIZE places
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008559 forward in the list, starting from P. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008560 psize = 0;
8561 q = p;
8562 for (i = 0; i < insize; i++)
8563 {
8564 psize++;
8565 q = q->right;
8566 if (!q)
8567 break;
8568 }
8569 qsize = insize;
8570
8571 /* Now we have two lists. Merge them! */
8572 while (psize > 0 || (qsize > 0 && q != NULL))
8573 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04008574 /* See from which the next case to merge comes from. */
8575 if (psize == 0)
8576 {
8577 /* P is empty so the next case must come from Q. */
8578 e = q;
8579 q = q->right;
8580 qsize--;
8581 }
8582 else if (qsize == 0 || q == NULL)
8583 {
8584 /* Q is empty. */
8585 e = p;
8586 p = p->right;
8587 psize--;
8588 }
8589 else
8590 {
8591 cmp = compare_cases (p, q);
8592 if (cmp < 0)
8593 {
8594 /* The whole case range for P is less than the
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008595 one for Q. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008596 e = p;
8597 p = p->right;
8598 psize--;
8599 }
8600 else if (cmp > 0)
8601 {
8602 /* The whole case range for Q is greater than
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008603 the case range for P. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008604 e = q;
8605 q = q->right;
8606 qsize--;
8607 }
8608 else
8609 {
8610 /* The cases overlap, or they are the same
8611 element in the list. Either way, we must
8612 issue an error and get the next case from P. */
8613 /* FIXME: Sort P and Q by line number. */
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00008614 gfc_error ("CASE label at %L overlaps with CASE "
Diego Novillo6de9cd92004-05-13 02:41:07 -04008615 "label at %L", &p->where, &q->where);
8616 overlap_seen = 1;
8617 e = p;
8618 p = p->right;
8619 psize--;
8620 }
8621 }
8622
8623 /* Add the next element to the merged list. */
8624 if (tail)
8625 tail->right = e;
8626 else
8627 list = e;
8628 e->left = tail;
8629 tail = e;
8630 }
8631
8632 /* P has now stepped INSIZE places along, and so has Q. So
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008633 they're the same. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008634 p = q;
8635 }
8636 tail->right = NULL;
8637
8638 /* If we have done only one merge or none at all, we've
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008639 finished sorting the cases. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008640 if (nmerges <= 1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008641 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04008642 if (!overlap_seen)
8643 return list;
8644 else
8645 return NULL;
8646 }
8647
8648 /* Otherwise repeat, merging lists twice the size. */
8649 insize *= 2;
8650 }
8651}
8652
8653
Steven G. Kargl5352b892005-01-16 12:51:04 +00008654/* Check to see if an expression is suitable for use in a CASE statement.
8655 Makes sure that all case expressions are scalar constants of the same
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008656 type. Return false if anything is wrong. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008657
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008658static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008659validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008660{
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008661 if (e == NULL) return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008662
Steven G. Kargl5352b892005-01-16 12:51:04 +00008663 if (e->ts.type != case_expr->ts.type)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008664 {
8665 gfc_error ("Expression in CASE statement at %L must be of type %s",
Steven G. Kargl5352b892005-01-16 12:51:04 +00008666 &e->where, gfc_basic_typename (case_expr->ts.type));
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008667 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008668 }
8669
Steven G. Kargl5352b892005-01-16 12:51:04 +00008670 /* C805 (R808) For a given case-construct, each case-value shall be of
8671 the same type as case-expr. For character type, length differences
8672 are allowed, but the kind type parameters shall be the same. */
8673
8674 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008675 {
Francois-Xavier Coudertd393bbd2008-05-18 22:45:05 +00008676 gfc_error ("Expression in CASE statement at %L must be of kind %d",
8677 &e->where, case_expr->ts.kind);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008678 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008679 }
8680
Daniel Frankead1614a2010-05-11 11:43:16 -04008681 /* Convert the case value kind to that of case expression kind,
8682 if needed */
8683
Steven G. Kargl5352b892005-01-16 12:51:04 +00008684 if (e->ts.kind != case_expr->ts.kind)
8685 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
8686
Diego Novillo6de9cd92004-05-13 02:41:07 -04008687 if (e->rank != 0)
8688 {
8689 gfc_error ("Expression in CASE statement at %L must be scalar",
8690 &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008691 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008692 }
8693
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008694 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008695}
8696
8697
8698/* Given a completely parsed select statement, we:
8699
8700 - Validate all expressions and code within the SELECT.
8701 - Make sure that the selection expression is not of the wrong type.
8702 - Make sure that no case ranges overlap.
8703 - Eliminate unreachable cases and unreachable code resulting from
8704 removing case labels.
8705
8706 The standard does allow unreachable cases, e.g. CASE (5:3). But
8707 they are a hassle for code generation, and to prevent that, we just
8708 cut them out here. This is not necessary for overlapping cases
8709 because they are illegal and we never even try to generate code.
8710
8711 We have the additional caveat that a SELECT construct could have
Kazu Hirata1f2959f2004-09-16 16:00:45 +00008712 been a computed GOTO in the source code. Fortunately we can fairly
Diego Novillo6de9cd92004-05-13 02:41:07 -04008713 easily work around that here: The case_expr for a "real" SELECT CASE
8714 is in code->expr1, but for a computed GOTO it is in code->expr2. All
8715 we have to do is make sure that the case_expr is a scalar integer
8716 expression. */
8717
8718static void
Janus Weilad3e2ad2013-01-23 22:38:40 +01008719resolve_select (gfc_code *code, bool select_type)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008720{
8721 gfc_code *body;
8722 gfc_expr *case_expr;
8723 gfc_case *cp, *default_case, *tail, *head;
8724 int seen_unreachable;
Paul Thomasd68bd5a2006-06-25 15:11:02 +00008725 int seen_logical;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008726 int ncases;
8727 bt type;
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008728 bool t;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008729
Steven G. Kargla5139272009-05-13 20:49:13 +00008730 if (code->expr1 == NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008731 {
8732 /* This was actually a computed GOTO statement. */
8733 case_expr = code->expr2;
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008734 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008735 gfc_error ("Selection expression in computed GOTO statement "
8736 "at %L must be a scalar integer expression",
8737 &case_expr->where);
8738
8739 /* Further checking is not necessary because this SELECT was built
8740 by the compiler, so it should always be OK. Just move the
8741 case_expr from expr2 to expr so that we can handle computed
8742 GOTOs as normal SELECTs from here on. */
Steven G. Kargla5139272009-05-13 20:49:13 +00008743 code->expr1 = code->expr2;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008744 code->expr2 = NULL;
8745 return;
8746 }
8747
Steven G. Kargla5139272009-05-13 20:49:13 +00008748 case_expr = code->expr1;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008749 type = case_expr->ts.type;
Janus Weilad3e2ad2013-01-23 22:38:40 +01008750
8751 /* F08:C830. */
Diego Novillo6de9cd92004-05-13 02:41:07 -04008752 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
8753 {
8754 gfc_error ("Argument of SELECT statement at %L cannot be %s",
Mark Egglestonf61e54e2019-10-03 09:40:23 +00008755 &case_expr->where, gfc_typename (case_expr));
Diego Novillo6de9cd92004-05-13 02:41:07 -04008756
8757 /* Punt. Going on here just produce more garbage error messages. */
8758 return;
8759 }
8760
Janus Weilad3e2ad2013-01-23 22:38:40 +01008761 /* F08:R842. */
8762 if (!select_type && case_expr->rank != 0)
8763 {
8764 gfc_error ("Argument of SELECT statement at %L must be a scalar "
8765 "expression", &case_expr->where);
8766
8767 /* Punt. */
8768 return;
8769 }
8770
Daniel Frankead1614a2010-05-11 11:43:16 -04008771 /* Raise a warning if an INTEGER case value exceeds the range of
8772 the case-expr. Later, all expressions will be promoted to the
8773 largest kind of all case-labels. */
8774
8775 if (type == BT_INTEGER)
8776 for (body = code->block; body; body = body->block)
Tobias Burnus29a63d62011-01-13 17:32:33 +01008777 for (cp = body->ext.block.case_list; cp; cp = cp->next)
Daniel Frankead1614a2010-05-11 11:43:16 -04008778 {
8779 if (cp->low
8780 && gfc_check_integer_range (cp->low->value.integer,
8781 case_expr->ts.kind) != ARITH_OK)
Joseph Myersdb30e212015-02-01 00:29:54 +00008782 gfc_warning (0, "Expression in CASE statement at %L is "
Daniel Frankead1614a2010-05-11 11:43:16 -04008783 "not in the range of %s", &cp->low->where,
Mark Egglestonf61e54e2019-10-03 09:40:23 +00008784 gfc_typename (case_expr));
Daniel Frankead1614a2010-05-11 11:43:16 -04008785
8786 if (cp->high
8787 && cp->low != cp->high
8788 && gfc_check_integer_range (cp->high->value.integer,
8789 case_expr->ts.kind) != ARITH_OK)
Joseph Myersdb30e212015-02-01 00:29:54 +00008790 gfc_warning (0, "Expression in CASE statement at %L is "
Daniel Frankead1614a2010-05-11 11:43:16 -04008791 "not in the range of %s", &cp->high->where,
Mark Egglestonf61e54e2019-10-03 09:40:23 +00008792 gfc_typename (case_expr));
Daniel Frankead1614a2010-05-11 11:43:16 -04008793 }
8794
Steven G. Kargl5352b892005-01-16 12:51:04 +00008795 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8796 of the SELECT CASE expression and its CASE values. Walk the lists
8797 of case values, and if we find a mismatch, promote case_expr to
8798 the appropriate kind. */
8799
8800 if (type == BT_LOGICAL || type == BT_INTEGER)
8801 {
8802 for (body = code->block; body; body = body->block)
8803 {
8804 /* Walk the case label list. */
Tobias Burnus29a63d62011-01-13 17:32:33 +01008805 for (cp = body->ext.block.case_list; cp; cp = cp->next)
Steven G. Kargl5352b892005-01-16 12:51:04 +00008806 {
8807 /* Intercept the DEFAULT case. It does not have a kind. */
8808 if (cp->low == NULL && cp->high == NULL)
8809 continue;
8810
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +02008811 /* Unreachable case ranges are discarded, so ignore. */
Steven G. Kargl5352b892005-01-16 12:51:04 +00008812 if (cp->low != NULL && cp->high != NULL
8813 && cp->low != cp->high
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008814 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
Steven G. Kargl5352b892005-01-16 12:51:04 +00008815 continue;
8816
Steven G. Kargl5352b892005-01-16 12:51:04 +00008817 if (cp->low != NULL
8818 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
Steve Kargld18e4cc2021-10-30 18:22:19 +02008819 gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0);
Steven G. Kargl5352b892005-01-16 12:51:04 +00008820
8821 if (cp->high != NULL
8822 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
Steve Kargld18e4cc2021-10-30 18:22:19 +02008823 gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0);
Steven G. Kargl5352b892005-01-16 12:51:04 +00008824 }
8825 }
8826 }
8827
Diego Novillo6de9cd92004-05-13 02:41:07 -04008828 /* Assume there is no DEFAULT case. */
8829 default_case = NULL;
8830 head = tail = NULL;
8831 ncases = 0;
Paul Thomasd68bd5a2006-06-25 15:11:02 +00008832 seen_logical = 0;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008833
8834 for (body = code->block; body; body = body->block)
8835 {
8836 /* Assume the CASE list is OK, and all CASE labels can be matched. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008837 t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008838 seen_unreachable = 0;
8839
8840 /* Walk the case label list, making sure that all case labels
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008841 are legal. */
Tobias Burnus29a63d62011-01-13 17:32:33 +01008842 for (cp = body->ext.block.case_list; cp; cp = cp->next)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008843 {
8844 /* Count the number of cases in the whole construct. */
8845 ncases++;
8846
8847 /* Intercept the DEFAULT case. */
8848 if (cp->low == NULL && cp->high == NULL)
8849 {
8850 if (default_case != NULL)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008851 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00008852 gfc_error ("The DEFAULT CASE at %L cannot be followed "
Diego Novillo6de9cd92004-05-13 02:41:07 -04008853 "by a second DEFAULT CASE at %L",
8854 &default_case->where, &cp->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008855 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008856 break;
8857 }
8858 else
8859 {
8860 default_case = cp;
8861 continue;
8862 }
8863 }
8864
8865 /* Deal with single value cases and case ranges. Errors are
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008866 issued from the validation function. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008867 if (!validate_case_label_expr (cp->low, case_expr)
8868 || !validate_case_label_expr (cp->high, case_expr))
Diego Novillo6de9cd92004-05-13 02:41:07 -04008869 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008870 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008871 break;
8872 }
8873
8874 if (type == BT_LOGICAL
8875 && ((cp->low == NULL || cp->high == NULL)
8876 || cp->low != cp->high))
8877 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008878 gfc_error ("Logical range in CASE statement at %L is not "
Harald Anlauf3b3c9932021-11-16 21:06:06 +01008879 "allowed",
8880 cp->low ? &cp->low->where : &cp->high->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008881 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008882 break;
8883 }
8884
Paul Thomasd68bd5a2006-06-25 15:11:02 +00008885 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
8886 {
8887 int value;
8888 value = cp->low->value.logical == 0 ? 2 : 1;
8889 if (value & seen_logical)
8890 {
Daniel Frankead1614a2010-05-11 11:43:16 -04008891 gfc_error ("Constant logical value in CASE statement "
Paul Thomasd68bd5a2006-06-25 15:11:02 +00008892 "is repeated at %L",
8893 &cp->low->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008894 t = false;
Paul Thomasd68bd5a2006-06-25 15:11:02 +00008895 break;
8896 }
8897 seen_logical |= value;
8898 }
8899
Diego Novillo6de9cd92004-05-13 02:41:07 -04008900 if (cp->low != NULL && cp->high != NULL
8901 && cp->low != cp->high
Tobias Burnus7b4c5f82007-12-05 14:42:32 +01008902 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008903 {
Tobias Burnus73e42ee2014-11-30 09:33:25 +01008904 if (warn_surprising)
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +00008905 gfc_warning (OPT_Wsurprising,
8906 "Range specification at %L can never be matched",
8907 &cp->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -04008908
8909 cp->unreachable = 1;
8910 seen_unreachable = 1;
8911 }
8912 else
8913 {
8914 /* If the case range can be matched, it can also overlap with
8915 other cases. To make sure it does not, we put it in a
8916 double linked list here. We sort that with a merge sort
8917 later on to detect any overlapping cases. */
8918 if (!head)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008919 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04008920 head = tail = cp;
8921 head->right = head->left = NULL;
8922 }
8923 else
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008924 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04008925 tail->right = cp;
8926 tail->right->left = tail;
8927 tail = tail->right;
8928 tail->right = NULL;
8929 }
8930 }
8931 }
8932
8933 /* It there was a failure in the previous case label, give up
8934 for this case label list. Continue with the next block. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +03008935 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008936 continue;
8937
8938 /* See if any case labels that are unreachable have been seen.
8939 If so, we eliminate them. This is a bit of a kludge because
8940 the case lists for a single case statement (label) is a
8941 single forward linked lists. */
8942 if (seen_unreachable)
8943 {
8944 /* Advance until the first case in the list is reachable. */
Tobias Burnus29a63d62011-01-13 17:32:33 +01008945 while (body->ext.block.case_list != NULL
8946 && body->ext.block.case_list->unreachable)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008947 {
Tobias Burnus29a63d62011-01-13 17:32:33 +01008948 gfc_case *n = body->ext.block.case_list;
8949 body->ext.block.case_list = body->ext.block.case_list->next;
Diego Novillo6de9cd92004-05-13 02:41:07 -04008950 n->next = NULL;
8951 gfc_free_case_list (n);
8952 }
8953
8954 /* Strip all other unreachable cases. */
Tobias Burnus29a63d62011-01-13 17:32:33 +01008955 if (body->ext.block.case_list)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008956 {
Steven Bosscherf1723012014-08-22 18:43:50 +00008957 for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next)
Diego Novillo6de9cd92004-05-13 02:41:07 -04008958 {
8959 if (cp->next->unreachable)
8960 {
8961 gfc_case *n = cp->next;
8962 cp->next = cp->next->next;
8963 n->next = NULL;
8964 gfc_free_case_list (n);
8965 }
8966 }
8967 }
8968 }
8969 }
8970
8971 /* See if there were overlapping cases. If the check returns NULL,
8972 there was overlap. In that case we don't do anything. If head
8973 is non-NULL, we prepend the DEFAULT case. The sorted list can
8974 then used during code generation for SELECT CASE constructs with
8975 a case expression of a CHARACTER type. */
8976 if (head)
8977 {
8978 head = check_case_overlap (head);
8979
8980 /* Prepend the default_case if it is there. */
8981 if (head != NULL && default_case)
8982 {
8983 default_case->left = NULL;
8984 default_case->right = head;
8985 head->left = default_case;
8986 }
8987 }
8988
8989 /* Eliminate dead blocks that may be the result if we've seen
8990 unreachable case labels for a block. */
8991 for (body = code; body && body->block; body = body->block)
8992 {
Tobias Burnus29a63d62011-01-13 17:32:33 +01008993 if (body->block->ext.block.case_list == NULL)
Steven G. Kargledf1eac2007-01-20 22:01:41 +00008994 {
Diego Novillo6de9cd92004-05-13 02:41:07 -04008995 /* Cut the unreachable block from the code chain. */
8996 gfc_code *c = body->block;
8997 body->block = c->block;
8998
8999 /* Kill the dead block, but not the blocks below it. */
9000 c->block = NULL;
9001 gfc_free_statements (c);
Steven G. Kargledf1eac2007-01-20 22:01:41 +00009002 }
Diego Novillo6de9cd92004-05-13 02:41:07 -04009003 }
9004
9005 /* More than two cases is legal but insane for logical selects.
9006 Issue a warning for it. */
Tobias Burnus73e42ee2014-11-30 09:33:25 +01009007 if (warn_surprising && type == BT_LOGICAL && ncases > 2)
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +00009008 gfc_warning (OPT_Wsurprising,
9009 "Logical SELECT CASE block at %L has more that two cases",
Diego Novillo6de9cd92004-05-13 02:41:07 -04009010 &code->loc);
9011}
9012
9013
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009014/* Check if a derived type is extensible. */
9015
9016bool
9017gfc_type_is_extensible (gfc_symbol *sym)
9018{
Paul Thomas8b704312012-12-20 00:15:00 +00009019 return !(sym->attr.is_bind_c || sym->attr.sequence
9020 || (sym->attr.is_class
9021 && sym->components->ts.u.derived->attr.unlimited_polymorphic));
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009022}
9023
9024
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009025static void
9026resolve_types (gfc_namespace *ns);
9027
Paul Thomas8f75db92012-05-05 08:49:43 +00009028/* Resolve an associate-name: Resolve target and ensure the type-spec is
Daniel Kraft3e782382010-08-26 21:48:43 +02009029 correct as well as possibly the array-spec. */
9030
9031static void
9032resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
9033{
9034 gfc_expr* target;
Daniel Kraft3e782382010-08-26 21:48:43 +02009035
9036 gcc_assert (sym->assoc);
9037 gcc_assert (sym->attr.flavor == FL_VARIABLE);
9038
9039 /* If this is for SELECT TYPE, the target may not yet be set. In that
9040 case, return. Resolution will be called later manually again when
9041 this is done. */
9042 target = sym->assoc->target;
9043 if (!target)
9044 return;
9045 gcc_assert (!sym->assoc->dangling);
9046
Janne Blomqvist524af0d2013-04-11 00:36:58 +03009047 if (resolve_target && !gfc_resolve_expr (target))
Daniel Kraft3e782382010-08-26 21:48:43 +02009048 return;
9049
9050 /* For variable targets, we get some attributes from the target. */
9051 if (target->expr_type == EXPR_VARIABLE)
9052 {
Tobias Burnusa76ff302020-03-27 10:56:25 +01009053 gfc_symbol *tsym, *dsym;
Daniel Kraft3e782382010-08-26 21:48:43 +02009054
9055 gcc_assert (target->symtree);
9056 tsym = target->symtree->n.sym;
Tobias Burnus4d124372020-01-03 08:08:30 +00009057
Tobias Burnus4d124372020-01-03 08:08:30 +00009058 if (gfc_expr_attr (target).proc_pointer)
9059 {
9060 gfc_error ("Associating entity %qs at %L is a procedure pointer",
Thomas Koenigc2123162019-12-08 13:42:42 +00009061 tsym->name, &target->where);
9062 return;
9063 }
Daniel Kraft3e782382010-08-26 21:48:43 +02009064
Tobias Burnusa76ff302020-03-27 10:56:25 +01009065 if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
9066 && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
9067 && dsym->attr.flavor == FL_DERIVED)
9068 {
9069 gfc_error ("Derived type %qs cannot be used as a variable at %L",
9070 tsym->name, &target->where);
9071 return;
9072 }
9073
9074 if (tsym->attr.flavor == FL_PROCEDURE)
9075 {
9076 bool is_error = true;
9077 if (tsym->attr.function && tsym->result == tsym)
9078 for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
9079 if (tsym == ns->proc_name)
9080 {
9081 is_error = false;
9082 break;
9083 }
9084 if (is_error)
9085 {
9086 gfc_error ("Associating entity %qs at %L is a procedure name",
9087 tsym->name, &target->where);
9088 return;
9089 }
9090 }
9091
Daniel Kraft3e782382010-08-26 21:48:43 +02009092 sym->attr.asynchronous = tsym->attr.asynchronous;
9093 sym->attr.volatile_ = tsym->attr.volatile_;
9094
Tobias Burnus102344e2012-01-27 14:08:52 +01009095 sym->attr.target = tsym->attr.target
9096 || gfc_expr_attr (target).pointer;
Paul Thomas68b1c5e2014-02-09 20:50:21 +00009097 if (is_subref_array (target))
9098 sym->attr.subref_array_pointer = 1;
Daniel Kraft3e782382010-08-26 21:48:43 +02009099 }
Tobias Burnus4d124372020-01-03 08:08:30 +00009100 else if (target->ts.type == BT_PROCEDURE)
9101 {
9102 gfc_error ("Associating selector-expression at %L yields a procedure",
9103 &target->where);
9104 return;
9105 }
Daniel Kraft3e782382010-08-26 21:48:43 +02009106
Paul Thomasb89a63b2017-09-21 18:40:21 +00009107 if (target->expr_type == EXPR_NULL)
9108 {
9109 gfc_error ("Selector at %L cannot be NULL()", &target->where);
9110 return;
9111 }
9112 else if (target->ts.type == BT_UNKNOWN)
9113 {
9114 gfc_error ("Selector at %L has no type", &target->where);
9115 return;
9116 }
9117
Daniel Kraft414e8be2010-09-26 21:25:52 +02009118 /* Get type if this was not already set. Note that it can be
9119 some other type than the target in case this is a SELECT TYPE
9120 selector! So we must not update when the type is already there. */
9121 if (sym->ts.type == BT_UNKNOWN)
9122 sym->ts = target->ts;
Paul Thomasb89a63b2017-09-21 18:40:21 +00009123
Daniel Kraft3e782382010-08-26 21:48:43 +02009124 gcc_assert (sym->ts.type != BT_UNKNOWN);
9125
9126 /* See if this is a valid association-to-variable. */
Daniel Kraft8c91ab32010-09-23 10:37:54 +02009127 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
9128 && !gfc_has_vector_subscript (target));
Daniel Kraft3e782382010-08-26 21:48:43 +02009129
9130 /* Finally resolve if this is an array or not. */
Tobias Burnus102344e2012-01-27 14:08:52 +01009131 if (sym->attr.dimension && target->rank == 0)
Daniel Kraft3e782382010-08-26 21:48:43 +02009132 {
Martin Liskae53b6e52022-01-14 16:57:02 +01009133 /* primary.cc makes the assumption that a reference to an associate
Paul Thomase207c522015-01-18 12:21:38 +00009134 name followed by a left parenthesis is an array reference. */
9135 if (sym->ts.type != BT_CHARACTER)
9136 gfc_error ("Associate-name %qs at %L is used as array",
9137 sym->name, &sym->declared_at);
Daniel Kraft3e782382010-08-26 21:48:43 +02009138 sym->attr.dimension = 0;
9139 return;
9140 }
Paul Thomas8f75db92012-05-05 08:49:43 +00009141
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009142
Paul Thomas8f75db92012-05-05 08:49:43 +00009143 /* We cannot deal with class selectors that need temporaries. */
9144 if (target->ts.type == BT_CLASS
9145 && gfc_ref_needs_temporary_p (target->ref))
9146 {
9147 gfc_error ("CLASS selector at %L needs a temporary which is not "
9148 "yet implemented", &target->where);
9149 return;
9150 }
9151
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009152 if (target->ts.type == BT_CLASS)
Paul Thomas8f75db92012-05-05 08:49:43 +00009153 gfc_fix_class_refs (target);
9154
Paul Thomas70570ec2019-09-01 12:53:02 +00009155 if (target->rank != 0 && !sym->attr.select_rank_temporary)
Daniel Kraft3e782382010-08-26 21:48:43 +02009156 {
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009157 gfc_array_spec *as;
Andre Vehreschild76fe9322016-02-11 17:48:45 +01009158 /* The rank may be incorrectly guessed at parsing, therefore make sure
9159 it is corrected now. */
9160 if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed))
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009161 {
Andre Vehreschild76fe9322016-02-11 17:48:45 +01009162 if (!sym->as)
9163 sym->as = gfc_get_array_spec ();
9164 as = sym->as;
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009165 as->rank = target->rank;
9166 as->type = AS_DEFERRED;
9167 as->corank = gfc_get_corank (target);
9168 sym->attr.dimension = 1;
9169 if (as->corank != 0)
9170 sym->attr.codimension = 1;
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009171 }
Harald Anlauf8a0b69f2020-07-10 21:00:13 +02009172 else if (sym->ts.type == BT_CLASS
9173 && CLASS_DATA (sym)
9174 && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
Paul Thomase60f68e2018-10-15 16:31:15 +00009175 {
9176 if (!CLASS_DATA (sym)->as)
9177 CLASS_DATA (sym)->as = gfc_get_array_spec ();
9178 as = CLASS_DATA (sym)->as;
9179 as->rank = target->rank;
9180 as->type = AS_DEFERRED;
9181 as->corank = gfc_get_corank (target);
9182 CLASS_DATA (sym)->attr.dimension = 1;
9183 if (as->corank != 0)
9184 CLASS_DATA (sym)->attr.codimension = 1;
9185 }
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009186 }
Paul Thomas70570ec2019-09-01 12:53:02 +00009187 else if (!sym->attr.select_rank_temporary)
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009188 {
9189 /* target's rank is 0, but the type of the sym is still array valued,
9190 which has to be corrected. */
Harald Anlauf70c884a2020-07-10 21:35:35 +02009191 if (sym->ts.type == BT_CLASS && sym->ts.u.derived
Steven G. Kargl4874b4d2018-12-08 18:09:05 +00009192 && CLASS_DATA (sym) && CLASS_DATA (sym)->as)
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009193 {
9194 gfc_array_spec *as;
9195 symbol_attribute attr;
9196 /* The associated variable's type is still the array type
9197 correct this now. */
9198 gfc_typespec *ts = &target->ts;
9199 gfc_ref *ref;
9200 gfc_component *c;
9201 for (ref = target->ref; ref != NULL; ref = ref->next)
9202 {
9203 switch (ref->type)
9204 {
9205 case REF_COMPONENT:
9206 ts = &ref->u.c.component->ts;
9207 break;
9208 case REF_ARRAY:
9209 if (ts->type == BT_CLASS)
9210 ts = &ts->u.derived->components->ts;
9211 break;
9212 default:
9213 break;
9214 }
9215 }
9216 /* Create a scalar instance of the current class type. Because the
9217 rank of a class array goes into its name, the type has to be
9218 rebuild. The alternative of (re-)setting just the attributes
9219 and as in the current type, destroys the type also in other
9220 places. */
9221 as = NULL;
9222 sym->ts = *ts;
9223 sym->ts.type = BT_CLASS;
Harald Anlauf267f84c2020-06-30 23:36:56 +02009224 attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009225 attr.class_ok = 0;
9226 attr.associate_var = 1;
9227 attr.dimension = attr.codimension = 0;
9228 attr.class_pointer = 1;
9229 if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
9230 gcc_unreachable ();
9231 /* Make sure the _vptr is set. */
Fritz Reesef6288c22016-05-07 23:16:23 +00009232 c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
Andre Vehreschild76540ac2015-06-23 11:07:22 +02009233 if (c->ts.u.derived == NULL)
9234 c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
9235 CLASS_DATA (sym)->attr.pointer = 1;
9236 CLASS_DATA (sym)->attr.class_pointer = 1;
9237 gfc_set_sym_referenced (sym->ts.u.derived);
9238 gfc_commit_symbol (sym->ts.u.derived);
9239 /* _vptr now has the _vtab in it, change it to the _vtype. */
9240 if (c->ts.u.derived->attr.vtab)
9241 c->ts.u.derived = c->ts.u.derived->ts.u.derived;
9242 c->ts.u.derived->ns->types_resolved = 0;
9243 resolve_types (c->ts.u.derived->ns);
9244 }
Daniel Kraft3e782382010-08-26 21:48:43 +02009245 }
Paul Thomasaa271862013-01-27 07:09:06 +00009246
9247 /* Mark this as an associate variable. */
9248 sym->attr.associate_var = 1;
9249
Steven G. Kargl50b01e12016-10-05 21:14:14 +00009250 /* Fix up the type-spec for CHARACTER types. */
9251 if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
9252 {
9253 if (!sym->ts.u.cl)
Paul Thomas5c60dbc2018-02-19 22:09:13 +00009254 sym->ts.u.cl = target->ts.u.cl;
Paul Thomasa8399af2018-02-17 11:07:32 +00009255
Mikael Morin907811d2022-03-13 22:22:55 +01009256 if (sym->ts.deferred
Paul Thomasca32d612018-09-17 07:18:17 +00009257 && sym->ts.u.cl == target->ts.u.cl)
9258 {
9259 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9260 sym->ts.deferred = 1;
9261 }
9262
Paul Thomas5c60dbc2018-02-19 22:09:13 +00009263 if (!sym->ts.u.cl->length
9264 && !sym->ts.deferred
9265 && target->expr_type == EXPR_CONSTANT)
9266 {
9267 sym->ts.u.cl->length =
9268 gfc_get_int_expr (gfc_charlen_int_kind, NULL,
9269 target->value.character.length);
Paul Thomasa8399af2018-02-17 11:07:32 +00009270 }
Paul Thomas5c60dbc2018-02-19 22:09:13 +00009271 else if ((!sym->ts.u.cl->length
9272 || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9273 && target->expr_type != EXPR_VARIABLE)
Janne Blomqvistae976c32018-02-01 21:47:15 +02009274 {
Mikael Morin907811d2022-03-13 22:22:55 +01009275 if (!sym->ts.deferred)
9276 {
9277 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
9278 sym->ts.deferred = 1;
9279 }
Paul Thomas5c60dbc2018-02-19 22:09:13 +00009280
Martin Liskae53b6e52022-01-14 16:57:02 +01009281 /* This is reset in trans-stmt.cc after the assignment
Paul Thomas5c60dbc2018-02-19 22:09:13 +00009282 of the target expression to the associate name. */
9283 sym->attr.allocatable = 1;
Janne Blomqvistae976c32018-02-01 21:47:15 +02009284 }
Steven G. Kargl50b01e12016-10-05 21:14:14 +00009285 }
9286
Paul Thomasaa271862013-01-27 07:09:06 +00009287 /* If the target is a good class object, so is the associate variable. */
9288 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
9289 sym->attr.class_ok = 1;
Daniel Kraft3e782382010-08-26 21:48:43 +02009290}
9291
9292
Paul Thomasde514d42016-10-21 12:50:56 +00009293/* Ensure that SELECT TYPE expressions have the correct rank and a full
9294 array reference, where necessary. The symbols are artificial and so
9295 the dimension attribute and arrayspec can also be set. In addition,
9296 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
9297 This is corrected here as well.*/
9298
9299static void
9300fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
9301 int rank, gfc_ref *ref)
9302{
9303 gfc_ref *nref = (*expr1)->ref;
9304 gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
9305 gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL;
9306 (*expr1)->rank = rank;
9307 if (sym1->ts.type == BT_CLASS)
9308 {
9309 if ((*expr1)->ts.type != BT_CLASS)
9310 (*expr1)->ts = sym1->ts;
9311
9312 CLASS_DATA (sym1)->attr.dimension = 1;
9313 if (CLASS_DATA (sym1)->as == NULL && sym2)
9314 CLASS_DATA (sym1)->as
9315 = gfc_copy_array_spec (CLASS_DATA (sym2)->as);
9316 }
9317 else
9318 {
9319 sym1->attr.dimension = 1;
9320 if (sym1->as == NULL && sym2)
9321 sym1->as = gfc_copy_array_spec (sym2->as);
9322 }
9323
9324 for (; nref; nref = nref->next)
9325 if (nref->next == NULL)
9326 break;
9327
9328 if (ref && nref && nref->type != REF_ARRAY)
9329 nref->next = gfc_copy_ref (ref);
9330 else if (ref && !nref)
9331 (*expr1)->ref = gfc_copy_ref (ref);
9332}
9333
9334
Paul Thomasdfd62312016-10-23 18:09:14 +00009335static gfc_expr *
9336build_loc_call (gfc_expr *sym_expr)
9337{
9338 gfc_expr *loc_call;
9339 loc_call = gfc_get_expr ();
9340 loc_call->expr_type = EXPR_FUNCTION;
Paul Thomasc8bd3262018-03-03 13:34:10 +00009341 gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
Paul Thomasdfd62312016-10-23 18:09:14 +00009342 loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
9343 loc_call->symtree->n.sym->attr.intrinsic = 1;
9344 loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
9345 gfc_commit_symbol (loc_call->symtree->n.sym);
9346 loc_call->ts.type = BT_INTEGER;
9347 loc_call->ts.kind = gfc_index_integer_kind;
9348 loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC);
9349 loc_call->value.function.actual = gfc_get_actual_arglist ();
9350 loc_call->value.function.actual->expr = sym_expr;
Thomas Koenigeb950bf2016-11-06 21:27:32 +00009351 loc_call->where = sym_expr->where;
Paul Thomasdfd62312016-10-23 18:09:14 +00009352 return loc_call;
9353}
9354
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009355/* Resolve a SELECT TYPE statement. */
9356
9357static void
Daniel Kraft8c91ab32010-09-23 10:37:54 +02009358resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009359{
9360 gfc_symbol *selector_type;
Janus Weil7c1dab02009-11-30 21:43:06 +01009361 gfc_code *body, *new_st, *if_st, *tail;
9362 gfc_code *class_is = NULL, *default_case = NULL;
9363 gfc_case *c;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009364 gfc_symtree *st;
Tobias Burnus0e792ee2021-03-22 09:49:48 +01009365 char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
Janus Weil93d76682009-10-07 12:54:35 +02009366 gfc_namespace *ns;
Janus Weil7c1dab02009-11-30 21:43:06 +01009367 int error = 0;
Paul Thomasde514d42016-10-21 12:50:56 +00009368 int rank = 0;
9369 gfc_ref* ref = NULL;
Paul Thomasdfd62312016-10-23 18:09:14 +00009370 gfc_expr *selector_expr = NULL;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009371
Daniel Kraft03af1e42010-06-10 16:47:49 +02009372 ns = code->ext.block.ns;
Janus Weil93d76682009-10-07 12:54:35 +02009373 gfc_resolve (ns);
9374
Janus Weilf5dbb572010-05-10 14:54:25 +02009375 /* Check for F03:C813. */
9376 if (code->expr1->ts.type != BT_CLASS
9377 && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
9378 {
9379 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
9380 "at %L", &code->loc);
9381 return;
9382 }
9383
Tobias Burnuscd99c232011-12-19 16:30:23 +01009384 if (!code->expr1->symtree->n.sym->attr.class_ok)
9385 return;
9386
Janus Weil93d76682009-10-07 12:54:35 +02009387 if (code->expr2)
Janus Weilf5dbb572010-05-10 14:54:25 +02009388 {
Paul Thomase60f68e2018-10-15 16:31:15 +00009389 gfc_ref *ref2 = NULL;
9390 for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
9391 if (ref->type == REF_COMPONENT
9392 && ref->u.c.component->ts.type == BT_CLASS)
9393 ref2 = ref;
9394
9395 if (ref2)
9396 {
9397 if (code->expr1->symtree->n.sym->attr.untyped)
Tobias Burnus91f9b2e2018-10-17 21:58:58 +02009398 code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts;
Paul Thomase60f68e2018-10-15 16:31:15 +00009399 selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
9400 }
9401 else
9402 {
9403 if (code->expr1->symtree->n.sym->attr.untyped)
9404 code->expr1->symtree->n.sym->ts = code->expr2->ts;
Harald Anlauff2151222020-07-06 18:58:23 +02009405 selector_type = CLASS_DATA (code->expr2)
9406 ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
Paul Thomase60f68e2018-10-15 16:31:15 +00009407 }
Paul Thomase4821cd2013-01-04 20:50:15 +00009408
Mark Eggleston3d137b72020-06-01 08:15:31 +01009409 if (code->expr2->rank
9410 && code->expr1->ts.type == BT_CLASS
9411 && CLASS_DATA (code->expr1)->as)
Paul Thomasa6b22ee2017-11-19 19:50:50 +00009412 CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
9413
Paul Thomase4821cd2013-01-04 20:50:15 +00009414 /* F2008: C803 The selector expression must not be coindexed. */
9415 if (gfc_is_coindexed (code->expr2))
9416 {
9417 gfc_error ("Selector at %L must not be coindexed",
9418 &code->expr2->where);
9419 return;
9420 }
9421
Janus Weilf5dbb572010-05-10 14:54:25 +02009422 }
Janus Weil93d76682009-10-07 12:54:35 +02009423 else
Paul Thomase4821cd2013-01-04 20:50:15 +00009424 {
9425 selector_type = CLASS_DATA (code->expr1)->ts.u.derived;
9426
9427 if (gfc_is_coindexed (code->expr1))
9428 {
9429 gfc_error ("Selector at %L must not be coindexed",
9430 &code->expr1->where);
9431 return;
9432 }
9433 }
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009434
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009435 /* Loop over TYPE IS / CLASS IS cases. */
9436 for (body = code->block; body; body = body->block)
9437 {
Tobias Burnus29a63d62011-01-13 17:32:33 +01009438 c = body->ext.block.case_list;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009439
Paul Thomasdfd62312016-10-23 18:09:14 +00009440 if (!error)
9441 {
9442 /* Check for repeated cases. */
9443 for (tail = code->block; tail; tail = tail->block)
9444 {
9445 gfc_case *d = tail->ext.block.case_list;
9446 if (tail == body)
9447 break;
9448
9449 if (c->ts.type == d->ts.type
9450 && ((c->ts.type == BT_DERIVED
9451 && c->ts.u.derived && d->ts.u.derived
9452 && !strcmp (c->ts.u.derived->name,
9453 d->ts.u.derived->name))
9454 || c->ts.type == BT_UNKNOWN
9455 || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9456 && c->ts.kind == d->ts.kind)))
9457 {
9458 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L",
9459 &c->where, &d->where);
9460 return;
9461 }
9462 }
9463 }
9464
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009465 /* Check F03:C815. */
9466 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
Harald Anlaufd8f6c482021-12-27 23:06:18 +01009467 && selector_type
Paul Thomas8b704312012-12-20 00:15:00 +00009468 && !selector_type->attr.unlimited_polymorphic
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009469 && !gfc_type_is_extensible (c->ts.u.derived))
9470 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +01009471 gfc_error ("Derived type %qs at %L must be extensible",
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009472 c->ts.u.derived->name, &c->where);
Janus Weil7c1dab02009-11-30 21:43:06 +01009473 error++;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009474 continue;
9475 }
9476
9477 /* Check F03:C816. */
Harald Anlaufd8f6c482021-12-27 23:06:18 +01009478 if (c->ts.type != BT_UNKNOWN
9479 && selector_type && !selector_type->attr.unlimited_polymorphic
Tobias Burnus55d86312013-01-07 09:36:16 +01009480 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
9481 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009482 {
Tobias Burnus55d86312013-01-07 09:36:16 +01009483 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
Tobias Burnusa4d9b222014-12-13 00:12:06 +01009484 gfc_error ("Derived type %qs at %L must be an extension of %qs",
Tobias Burnus55d86312013-01-07 09:36:16 +01009485 c->ts.u.derived->name, &c->where, selector_type->name);
9486 else
Tobias Burnusa4d9b222014-12-13 00:12:06 +01009487 gfc_error ("Unexpected intrinsic type %qs at %L",
Tobias Burnus55d86312013-01-07 09:36:16 +01009488 gfc_basic_typename (c->ts.type), &c->where);
Janus Weil7c1dab02009-11-30 21:43:06 +01009489 error++;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009490 continue;
9491 }
9492
Paul Thomas8b704312012-12-20 00:15:00 +00009493 /* Check F03:C814. */
Paul Thomasdfd62312016-10-23 18:09:14 +00009494 if (c->ts.type == BT_CHARACTER
9495 && (c->ts.u.cl->length != NULL || c->ts.deferred))
Paul Thomas8b704312012-12-20 00:15:00 +00009496 {
9497 gfc_error ("The type-spec at %L shall specify that each length "
9498 "type parameter is assumed", &c->where);
9499 error++;
9500 continue;
9501 }
9502
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009503 /* Intercept the DEFAULT case. */
9504 if (c->ts.type == BT_UNKNOWN)
9505 {
9506 /* Check F03:C818. */
Janus Weil7c1dab02009-11-30 21:43:06 +01009507 if (default_case)
9508 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +00009509 gfc_error ("The DEFAULT CASE at %L cannot be followed "
Janus Weil7c1dab02009-11-30 21:43:06 +01009510 "by a second DEFAULT CASE at %L",
Tobias Burnus29a63d62011-01-13 17:32:33 +01009511 &default_case->ext.block.case_list->where, &c->where);
Janus Weil7c1dab02009-11-30 21:43:06 +01009512 error++;
9513 continue;
9514 }
Daniel Kraft414e8be2010-09-26 21:25:52 +02009515
9516 default_case = body;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009517 }
9518 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009519
Daniel Kraft3e782382010-08-26 21:48:43 +02009520 if (error > 0)
Janus Weil7c1dab02009-11-30 21:43:06 +01009521 return;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009522
Daniel Kraft3e782382010-08-26 21:48:43 +02009523 /* Transform SELECT TYPE statement to BLOCK and associate selector to
Daniel Krafte5ca9692010-09-03 10:01:51 +02009524 target if present. If there are any EXIT statements referring to the
9525 SELECT TYPE construct, this is no problem because the gfc_code
9526 reference stays the same and EXIT is equally possible from the BLOCK
9527 it is changed to. */
Daniel Kraft3e782382010-08-26 21:48:43 +02009528 code->op = EXEC_BLOCK;
Janus Weil93d76682009-10-07 12:54:35 +02009529 if (code->expr2)
9530 {
Daniel Kraft3e782382010-08-26 21:48:43 +02009531 gfc_association_list* assoc;
Janus Weil93d76682009-10-07 12:54:35 +02009532
Daniel Kraft3e782382010-08-26 21:48:43 +02009533 assoc = gfc_get_association_list ();
9534 assoc->st = code->expr1->symtree;
9535 assoc->target = gfc_copy_expr (code->expr2);
Paul Thomasc49ea232011-12-11 20:42:23 +00009536 assoc->target->where = code->expr2->where;
Daniel Kraft3e782382010-08-26 21:48:43 +02009537 /* assoc->variable will be set by resolve_assoc_var. */
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009538
Daniel Kraft3e782382010-08-26 21:48:43 +02009539 code->ext.block.assoc = assoc;
9540 code->expr1->symtree->n.sym->assoc = assoc;
9541
9542 resolve_assoc_var (code->expr1->symtree->n.sym, false);
9543 }
9544 else
9545 code->ext.block.assoc = NULL;
9546
Paul Thomasde514d42016-10-21 12:50:56 +00009547 /* Ensure that the selector rank and arrayspec are available to
9548 correct expressions in which they might be missing. */
9549 if (code->expr2 && code->expr2->rank)
9550 {
9551 rank = code->expr2->rank;
9552 for (ref = code->expr2->ref; ref; ref = ref->next)
9553 if (ref->next == NULL)
9554 break;
9555 if (ref && ref->type == REF_ARRAY)
9556 ref = gfc_copy_ref (ref);
9557
9558 /* Fixup expr1 if necessary. */
9559 if (rank)
9560 fixup_array_ref (&code->expr1, code->expr2, rank, ref);
9561 }
9562 else if (code->expr1->rank)
9563 {
9564 rank = code->expr1->rank;
9565 for (ref = code->expr1->ref; ref; ref = ref->next)
9566 if (ref->next == NULL)
9567 break;
9568 if (ref && ref->type == REF_ARRAY)
9569 ref = gfc_copy_ref (ref);
9570 }
9571
Daniel Kraft3e782382010-08-26 21:48:43 +02009572 /* Add EXEC_SELECT to switch on type. */
Janus Weil11e52742013-08-09 21:26:07 +02009573 new_st = gfc_get_code (code->op);
Janus Weil93d76682009-10-07 12:54:35 +02009574 new_st->expr1 = code->expr1;
9575 new_st->expr2 = code->expr2;
9576 new_st->block = code->block;
Daniel Kraft3e782382010-08-26 21:48:43 +02009577 code->expr1 = code->expr2 = NULL;
9578 code->block = NULL;
Janus Weil93d76682009-10-07 12:54:35 +02009579 if (!ns->code)
9580 ns->code = new_st;
9581 else
9582 ns->code->next = new_st;
Janus Weil93d76682009-10-07 12:54:35 +02009583 code = new_st;
Paul Thomasdfd62312016-10-23 18:09:14 +00009584 code->op = EXEC_SELECT_TYPE;
Paul Thomas8b704312012-12-20 00:15:00 +00009585
Paul Thomasdfd62312016-10-23 18:09:14 +00009586 /* Use the intrinsic LOC function to generate an integer expression
9587 for the vtable of the selector. Note that the rank of the selector
9588 expression has to be set to zero. */
Janus Weilb04533a2010-11-09 11:39:46 +01009589 gfc_add_vptr_component (code->expr1);
Paul Thomasdfd62312016-10-23 18:09:14 +00009590 code->expr1->rank = 0;
9591 code->expr1 = build_loc_call (code->expr1);
9592 selector_expr = code->expr1->value.function.actual->expr;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009593
9594 /* Loop over TYPE IS / CLASS IS cases. */
9595 for (body = code->block; body; body = body->block)
9596 {
Paul Thomasdfd62312016-10-23 18:09:14 +00009597 gfc_symbol *vtab;
9598 gfc_expr *e;
Tobias Burnus29a63d62011-01-13 17:32:33 +01009599 c = body->ext.block.case_list;
Jerry DeLisleb7e75772010-04-13 01:59:35 +00009600
Paul Thomasdfd62312016-10-23 18:09:14 +00009601 /* Generate an index integer expression for address of the
9602 TYPE/CLASS vtable and store it in c->low. The hash expression
9603 is stored in c->high and is used to resolve intrinsic cases. */
9604 if (c->ts.type != BT_UNKNOWN)
Paul Thomas8b704312012-12-20 00:15:00 +00009605 {
Paul Thomasdfd62312016-10-23 18:09:14 +00009606 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
9607 {
9608 vtab = gfc_find_derived_vtab (c->ts.u.derived);
9609 gcc_assert (vtab);
Thomas Koenig6ef13662018-02-25 09:02:32 +00009610 c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL,
Paul Thomasdfd62312016-10-23 18:09:14 +00009611 c->ts.u.derived->hash_value);
9612 }
9613 else
9614 {
9615 vtab = gfc_find_vtab (&c->ts);
9616 gcc_assert (vtab && CLASS_DATA (vtab)->initializer);
9617 e = CLASS_DATA (vtab)->initializer;
9618 c->high = gfc_copy_expr (e);
Thomas Koenig6ef13662018-02-25 09:02:32 +00009619 if (c->high->ts.kind != gfc_integer_4_kind)
9620 {
9621 gfc_typespec ts;
9622 ts.kind = gfc_integer_4_kind;
9623 ts.type = BT_INTEGER;
9624 gfc_convert_type_warn (c->high, &ts, 2, 0);
9625 }
Paul Thomasdfd62312016-10-23 18:09:14 +00009626 }
Paul Thomas8b704312012-12-20 00:15:00 +00009627
Paul Thomasdfd62312016-10-23 18:09:14 +00009628 e = gfc_lval_expr_from_sym (vtab);
9629 c->low = build_loc_call (e);
Paul Thomas8b704312012-12-20 00:15:00 +00009630 }
Paul Thomasdfd62312016-10-23 18:09:14 +00009631 else
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009632 continue;
Jerry DeLisleb7e75772010-04-13 01:59:35 +00009633
Daniel Kraft3e782382010-08-26 21:48:43 +02009634 /* Associate temporary to selector. This should only be done
9635 when this case is actually true, so build a new ASSOCIATE
9636 that does precisely this here (instead of using the
9637 'global' one). */
9638
Janus Weil7c1dab02009-11-30 21:43:06 +01009639 if (c->ts.type == BT_CLASS)
Janus Weilb04533a2010-11-09 11:39:46 +01009640 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
Paul Thomas8b704312012-12-20 00:15:00 +00009641 else if (c->ts.type == BT_DERIVED)
Janus Weilb04533a2010-11-09 11:39:46 +01009642 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
Paul Thomas8b704312012-12-20 00:15:00 +00009643 else if (c->ts.type == BT_CHARACTER)
9644 {
Janne Blomqvistf6222212018-01-05 21:01:12 +02009645 HOST_WIDE_INT charlen = 0;
Paul Thomas8b704312012-12-20 00:15:00 +00009646 if (c->ts.u.cl && c->ts.u.cl->length
9647 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
Janne Blomqvistf6222212018-01-05 21:01:12 +02009648 charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
9649 snprintf (name, sizeof (name),
9650 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
9651 gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
Paul Thomas8b704312012-12-20 00:15:00 +00009652 }
9653 else
9654 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
9655 c->ts.kind);
9656
Janus Weil93d76682009-10-07 12:54:35 +02009657 st = gfc_find_symtree (ns->sym_root, name);
Daniel Kraft3e782382010-08-26 21:48:43 +02009658 gcc_assert (st->n.sym->assoc);
Paul Thomasdfd62312016-10-23 18:09:14 +00009659 st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
9660 st->n.sym->assoc->target->where = selector_expr->where;
Paul Thomas8b704312012-12-20 00:15:00 +00009661 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
Paul Thomasde514d42016-10-21 12:50:56 +00009662 {
9663 gfc_add_data_component (st->n.sym->assoc->target);
9664 /* Fixup the target expression if necessary. */
9665 if (rank)
9666 fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
9667 }
Daniel Kraft3e782382010-08-26 21:48:43 +02009668
Janus Weil11e52742013-08-09 21:26:07 +02009669 new_st = gfc_get_code (EXEC_BLOCK);
Daniel Kraft3e782382010-08-26 21:48:43 +02009670 new_st->ext.block.ns = gfc_build_block_ns (ns);
9671 new_st->ext.block.ns->code = body->next;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009672 body->next = new_st;
Daniel Kraft3e782382010-08-26 21:48:43 +02009673
9674 /* Chain in the new list only if it is marked as dangling. Otherwise
9675 there is a CASE label overlap and this is already used. Just ignore,
Tobias Burnuseea58ad2012-05-30 08:26:09 +02009676 the error is diagnosed elsewhere. */
Daniel Kraft3e782382010-08-26 21:48:43 +02009677 if (st->n.sym->assoc->dangling)
9678 {
9679 new_st->ext.block.assoc = st->n.sym->assoc;
9680 st->n.sym->assoc->dangling = 0;
9681 }
9682
9683 resolve_assoc_var (st->n.sym, false);
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009684 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009685
Janus Weil7c1dab02009-11-30 21:43:06 +01009686 /* Take out CLASS IS cases for separate treatment. */
9687 body = code;
9688 while (body && body->block)
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009689 {
Tobias Burnus29a63d62011-01-13 17:32:33 +01009690 if (body->block->ext.block.case_list->ts.type == BT_CLASS)
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009691 {
Janus Weil7c1dab02009-11-30 21:43:06 +01009692 /* Add to class_is list. */
9693 if (class_is == NULL)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009694 {
Janus Weil7c1dab02009-11-30 21:43:06 +01009695 class_is = body->block;
9696 tail = class_is;
9697 }
9698 else
9699 {
9700 for (tail = class_is; tail->block; tail = tail->block) ;
9701 tail->block = body->block;
9702 tail = tail->block;
9703 }
9704 /* Remove from EXEC_SELECT list. */
9705 body->block = body->block->block;
9706 tail->block = NULL;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009707 }
Janus Weil7c1dab02009-11-30 21:43:06 +01009708 else
9709 body = body->block;
9710 }
9711
9712 if (class_is)
9713 {
9714 gfc_symbol *vtab;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009715
Janus Weil7c1dab02009-11-30 21:43:06 +01009716 if (!default_case)
9717 {
9718 /* Add a default case to hold the CLASS IS cases. */
9719 for (tail = code; tail->block; tail = tail->block) ;
Janus Weil11e52742013-08-09 21:26:07 +02009720 tail->block = gfc_get_code (EXEC_SELECT_TYPE);
Janus Weil7c1dab02009-11-30 21:43:06 +01009721 tail = tail->block;
Tobias Burnus29a63d62011-01-13 17:32:33 +01009722 tail->ext.block.case_list = gfc_get_case ();
9723 tail->ext.block.case_list->ts.type = BT_UNKNOWN;
Janus Weil7c1dab02009-11-30 21:43:06 +01009724 tail->next = NULL;
9725 default_case = tail;
9726 }
Paul Thomaseece1eb2010-04-29 19:10:48 +00009727
Janus Weil7c1dab02009-11-30 21:43:06 +01009728 /* More than one CLASS IS block? */
9729 if (class_is->block)
9730 {
9731 gfc_code **c1,*c2;
9732 bool swapped;
9733 /* Sort CLASS IS blocks by extension level. */
9734 do
9735 {
9736 swapped = false;
9737 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
9738 {
9739 c2 = (*c1)->block;
9740 /* F03:C817 (check for doubles). */
Tobias Burnus29a63d62011-01-13 17:32:33 +01009741 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
9742 == c2->ext.block.case_list->ts.u.derived->hash_value)
Janus Weil7c1dab02009-11-30 21:43:06 +01009743 {
9744 gfc_error ("Double CLASS IS block in SELECT TYPE "
Tobias Burnus29a63d62011-01-13 17:32:33 +01009745 "statement at %L",
9746 &c2->ext.block.case_list->where);
Janus Weil7c1dab02009-11-30 21:43:06 +01009747 return;
9748 }
Tobias Burnus29a63d62011-01-13 17:32:33 +01009749 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
9750 < c2->ext.block.case_list->ts.u.derived->attr.extension)
Janus Weil7c1dab02009-11-30 21:43:06 +01009751 {
9752 /* Swap. */
9753 (*c1)->block = c2->block;
9754 c2->block = *c1;
9755 *c1 = c2;
9756 swapped = true;
9757 }
9758 }
9759 }
9760 while (swapped);
9761 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009762
Janus Weil7c1dab02009-11-30 21:43:06 +01009763 /* Generate IF chain. */
Janus Weil11e52742013-08-09 21:26:07 +02009764 if_st = gfc_get_code (EXEC_IF);
Janus Weil7c1dab02009-11-30 21:43:06 +01009765 new_st = if_st;
9766 for (body = class_is; body; body = body->block)
9767 {
Janus Weil11e52742013-08-09 21:26:07 +02009768 new_st->block = gfc_get_code (EXEC_IF);
Janus Weil7c1dab02009-11-30 21:43:06 +01009769 new_st = new_st->block;
Janus Weil7c1dab02009-11-30 21:43:06 +01009770 /* Set up IF condition: Call _gfortran_is_extension_of. */
9771 new_st->expr1 = gfc_get_expr ();
9772 new_st->expr1->expr_type = EXPR_FUNCTION;
9773 new_st->expr1->ts.type = BT_LOGICAL;
9774 new_st->expr1->ts.kind = 4;
9775 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
9776 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
9777 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
9778 /* Set up arguments. */
9779 new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
Paul Thomasdfd62312016-10-23 18:09:14 +00009780 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree);
Janus Weil2c3d0cd2010-12-12 22:14:13 +01009781 new_st->expr1->value.function.actual->expr->where = code->loc;
Thomas Koenigce386152016-11-07 15:25:21 +00009782 new_st->expr1->where = code->loc;
Janus Weilb04533a2010-11-09 11:39:46 +01009783 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
Tobias Burnus29a63d62011-01-13 17:32:33 +01009784 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
Janus Weil7c1dab02009-11-30 21:43:06 +01009785 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
9786 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
9787 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
Thomas Koenig39b4b342016-11-07 19:33:27 +00009788 new_st->expr1->value.function.actual->next->expr->where = code->loc;
Francois-Xavier Couderta502683d2020-09-07 09:36:29 +02009789 /* Set up types in formal arg list. */
9790 new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg);
9791 new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts;
9792 new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg);
9793 new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts;
9794
Janus Weil7c1dab02009-11-30 21:43:06 +01009795 new_st->next = body->next;
9796 }
9797 if (default_case->next)
9798 {
Janus Weil11e52742013-08-09 21:26:07 +02009799 new_st->block = gfc_get_code (EXEC_IF);
Janus Weil7c1dab02009-11-30 21:43:06 +01009800 new_st = new_st->block;
Janus Weil7c1dab02009-11-30 21:43:06 +01009801 new_st->next = default_case->next;
9802 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009803
Janus Weil7c1dab02009-11-30 21:43:06 +01009804 /* Replace CLASS DEFAULT code by the IF chain. */
9805 default_case->next = if_st;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009806 }
9807
Sandra Loosemore67914692019-01-09 16:37:45 -05009808 /* Resolve the internal code. This cannot be done earlier because
Daniel Kraft8c91ab32010-09-23 10:37:54 +02009809 it requires that the sym->assoc of selectors is set already. */
9810 gfc_current_ns = ns;
9811 gfc_resolve_blocks (code->block, gfc_current_ns);
9812 gfc_current_ns = old_ns;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009813
Paul Thomasde514d42016-10-21 12:50:56 +00009814 if (ref)
9815 free (ref);
Tobias Burnuscf2b3c22009-09-30 21:55:45 +02009816}
9817
9818
Paul Thomas70570ec2019-09-01 12:53:02 +00009819/* Resolve a SELECT RANK statement. */
9820
9821static void
9822resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
9823{
9824 gfc_namespace *ns;
9825 gfc_code *body, *new_st, *tail;
9826 gfc_case *c;
Harald Anlauf77d455e2020-06-25 20:34:48 +02009827 char tname[GFC_MAX_SYMBOL_LEN + 7];
Paul Thomas70570ec2019-09-01 12:53:02 +00009828 char name[2 * GFC_MAX_SYMBOL_LEN];
9829 gfc_symtree *st;
9830 gfc_expr *selector_expr = NULL;
9831 int case_value;
9832 HOST_WIDE_INT charlen = 0;
9833
9834 ns = code->ext.block.ns;
9835 gfc_resolve (ns);
9836
9837 code->op = EXEC_BLOCK;
9838 if (code->expr2)
9839 {
9840 gfc_association_list* assoc;
9841
9842 assoc = gfc_get_association_list ();
9843 assoc->st = code->expr1->symtree;
9844 assoc->target = gfc_copy_expr (code->expr2);
9845 assoc->target->where = code->expr2->where;
9846 /* assoc->variable will be set by resolve_assoc_var. */
9847
9848 code->ext.block.assoc = assoc;
9849 code->expr1->symtree->n.sym->assoc = assoc;
9850
9851 resolve_assoc_var (code->expr1->symtree->n.sym, false);
9852 }
9853 else
9854 code->ext.block.assoc = NULL;
9855
9856 /* Loop over RANK cases. Note that returning on the errors causes a
9857 cascade of further errors because the case blocks do not compile
9858 correctly. */
9859 for (body = code->block; body; body = body->block)
9860 {
9861 c = body->ext.block.case_list;
9862 if (c->low)
9863 case_value = (int) mpz_get_si (c->low->value.integer);
9864 else
9865 case_value = -2;
9866
9867 /* Check for repeated cases. */
9868 for (tail = code->block; tail; tail = tail->block)
9869 {
9870 gfc_case *d = tail->ext.block.case_list;
9871 int case_value2;
9872
9873 if (tail == body)
9874 break;
9875
9876 /* Check F2018: C1153. */
9877 if (!c->low && !d->low)
9878 gfc_error ("RANK DEFAULT at %L is repeated at %L",
9879 &c->where, &d->where);
9880
9881 if (!c->low || !d->low)
9882 continue;
9883
9884 /* Check F2018: C1153. */
9885 case_value2 = (int) mpz_get_si (d->low->value.integer);
9886 if ((case_value == case_value2) && case_value == -1)
9887 gfc_error ("RANK (*) at %L is repeated at %L",
9888 &c->where, &d->where);
9889 else if (case_value == case_value2)
9890 gfc_error ("RANK (%i) at %L is repeated at %L",
9891 case_value, &c->where, &d->where);
9892 }
9893
9894 if (!c->low)
9895 continue;
9896
9897 /* Check F2018: C1155. */
9898 if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
9899 || gfc_expr_attr (code->expr1).pointer))
9900 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9901 "allocatable selector at %L", &c->where, &code->expr1->where);
9902
9903 if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
9904 || gfc_expr_attr (code->expr1).pointer))
9905 gfc_error ("RANK (*) at %L cannot be used with the pointer or "
9906 "allocatable selector at %L", &c->where, &code->expr1->where);
9907 }
9908
9909 /* Add EXEC_SELECT to switch on rank. */
9910 new_st = gfc_get_code (code->op);
9911 new_st->expr1 = code->expr1;
9912 new_st->expr2 = code->expr2;
9913 new_st->block = code->block;
9914 code->expr1 = code->expr2 = NULL;
9915 code->block = NULL;
9916 if (!ns->code)
9917 ns->code = new_st;
9918 else
9919 ns->code->next = new_st;
9920 code = new_st;
9921 code->op = EXEC_SELECT_RANK;
9922
9923 selector_expr = code->expr1;
9924
9925 /* Loop over SELECT RANK cases. */
9926 for (body = code->block; body; body = body->block)
9927 {
9928 c = body->ext.block.case_list;
9929 int case_value;
9930
9931 /* Pass on the default case. */
9932 if (c->low == NULL)
9933 continue;
9934
9935 /* Associate temporary to selector. This should only be done
9936 when this case is actually true, so build a new ASSOCIATE
9937 that does precisely this here (instead of using the
9938 'global' one). */
9939 if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
9940 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
9941 charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
9942
9943 if (c->ts.type == BT_CLASS)
9944 sprintf (tname, "class_%s", c->ts.u.derived->name);
9945 else if (c->ts.type == BT_DERIVED)
9946 sprintf (tname, "type_%s", c->ts.u.derived->name);
9947 else if (c->ts.type != BT_CHARACTER)
9948 sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
9949 else
9950 sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
9951 gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
9952
9953 case_value = (int) mpz_get_si (c->low->value.integer);
9954 if (case_value >= 0)
9955 sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
9956 else
9957 sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
9958
9959 st = gfc_find_symtree (ns->sym_root, name);
9960 gcc_assert (st->n.sym->assoc);
9961
9962 st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
9963 st->n.sym->assoc->target->where = selector_expr->where;
9964
9965 new_st = gfc_get_code (EXEC_BLOCK);
9966 new_st->ext.block.ns = gfc_build_block_ns (ns);
9967 new_st->ext.block.ns->code = body->next;
9968 body->next = new_st;
9969
9970 /* Chain in the new list only if it is marked as dangling. Otherwise
9971 there is a CASE label overlap and this is already used. Just ignore,
9972 the error is diagnosed elsewhere. */
9973 if (st->n.sym->assoc->dangling)
9974 {
9975 new_st->ext.block.assoc = st->n.sym->assoc;
9976 st->n.sym->assoc->dangling = 0;
9977 }
9978
9979 resolve_assoc_var (st->n.sym, false);
9980 }
9981
9982 gfc_current_ns = ns;
9983 gfc_resolve_blocks (code->block, gfc_current_ns);
9984 gfc_current_ns = old_ns;
9985}
9986
9987
Tobias Schlüter0e6928d2004-09-01 23:07:39 +02009988/* Resolve a transfer statement. This is making sure that:
9989 -- a derived type being transferred has only non-pointer components
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +00009990 -- a derived type being transferred doesn't have private components, unless
Erik Edelmann84515842005-09-23 00:52:09 +03009991 it's being transferred from the module where the type was defined
Tobias Schlüter0e6928d2004-09-01 23:07:39 +02009992 -- we're not trying to transfer a whole assumed size array. */
9993
9994static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +00009995resolve_transfer (gfc_code *code)
Tobias Schlüter0e6928d2004-09-01 23:07:39 +02009996{
Paul Thomase73d3ca2016-08-31 05:36:22 +00009997 gfc_symbol *sym, *derived;
Tobias Schlüter0e6928d2004-09-01 23:07:39 +02009998 gfc_ref *ref;
9999 gfc_expr *exp;
Paul Thomase73d3ca2016-08-31 05:36:22 +000010000 bool write = false;
10001 bool formatted = false;
10002 gfc_dt *dt = code->ext.dt;
10003 gfc_symbol *dtio_sub = NULL;
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010004
Steven G. Kargla5139272009-05-13 20:49:13 +000010005 exp = code->expr1;
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010006
Jerry DeLisle771c5722010-08-19 02:35:45 +000010007 while (exp != NULL && exp->expr_type == EXPR_OP
10008 && exp->value.op.op == INTRINSIC_PARENTHESES)
10009 exp = exp->value.op.op1;
10010
Paul Thomas49560f02013-12-01 11:37:09 +000010011 if (exp && exp->expr_type == EXPR_NULL
10012 && code->ext.dt)
Tobias Burnusea8ad3e2011-09-14 08:26:07 +020010013 {
Paul Thomas49560f02013-12-01 11:37:09 +000010014 gfc_error ("Invalid context for NULL () intrinsic at %L",
10015 &exp->where);
Tobias Burnusea8ad3e2011-09-14 08:26:07 +020010016 return;
10017 }
10018
Jerry DeLisle771c5722010-08-19 02:35:45 +000010019 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE
Tobias Burnus2f72ca12015-02-05 22:58:38 +010010020 && exp->expr_type != EXPR_FUNCTION
Harald Anlauf89f20c92022-10-09 20:43:32 +020010021 && exp->expr_type != EXPR_ARRAY
Tobias Burnus2f72ca12015-02-05 22:58:38 +010010022 && exp->expr_type != EXPR_STRUCTURE))
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010023 return;
10024
Daniel Kraft8e8dc062010-09-25 16:27:20 +020010025 /* If we are reading, the variable will be changed. Note that
10026 code->ext.dt may be NULL if the TRANSFER is related to
10027 an INQUIRE statement -- but in this case, we are not reading, either. */
Paul Thomase73d3ca2016-08-31 05:36:22 +000010028 if (dt && dt->dt_io_kind->value.iokind == M_READ
Paul Thomas22c23882014-10-18 14:35:51 +000010029 && !gfc_check_vardef_context (exp, false, false, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010030 _("item in READ")))
Daniel Kraft8e8dc062010-09-25 16:27:20 +020010031 return;
10032
Janus Weil3d6fc622018-08-25 17:41:34 +020010033 const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
10034 || exp->expr_type == EXPR_FUNCTION
Harald Anlauf89f20c92022-10-09 20:43:32 +020010035 || exp->expr_type == EXPR_ARRAY
Janus Weil3d6fc622018-08-25 17:41:34 +020010036 ? &exp->ts : &exp->symtree->n.sym->ts;
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010037
10038 /* Go to actual component transferred. */
Jerry DeLisle6cf860a2010-10-06 22:38:30 +000010039 for (ref = exp->ref; ref; ref = ref->next)
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010040 if (ref->type == REF_COMPONENT)
10041 ts = &ref->u.c.component->ts;
10042
Paul Thomase73d3ca2016-08-31 05:36:22 +000010043 if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
10044 && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
Tobias Burnusd5656542010-11-12 00:07:23 +010010045 {
Steven G. Karglfb2974d2018-12-17 02:19:58 +000010046 derived = ts->u.derived;
Paul Thomase73d3ca2016-08-31 05:36:22 +000010047
Jerry DeLislef208c5c2018-01-13 20:41:00 +000010048 /* Determine when to use the formatted DTIO procedure. */
10049 if (dt && (dt->format_expr || dt->format_label))
10050 formatted = true;
Paul Thomase73d3ca2016-08-31 05:36:22 +000010051
10052 write = dt->dt_io_kind->value.iokind == M_WRITE
10053 || dt->dt_io_kind->value.iokind == M_PRINT;
10054 dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
10055
10056 if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
10057 {
Jerry DeLisle4a8d4422016-09-23 20:36:21 +000010058 dt->udtio = exp;
Paul Thomase73d3ca2016-08-31 05:36:22 +000010059 sym = exp->symtree->n.sym->ns->proc_name;
10060 /* Check to see if this is a nested DTIO call, with the
10061 dummy as the io-list object. */
10062 if (sym && sym == dtio_sub && sym->formal
10063 && sym->formal->sym == exp->symtree->n.sym
10064 && exp->ref == NULL)
10065 {
10066 if (!sym->attr.recursive)
10067 {
10068 gfc_error ("DTIO %s procedure at %L must be recursive",
10069 sym->name, &sym->declared_at);
10070 return;
10071 }
10072 }
10073 }
10074 }
10075
10076 if (ts->type == BT_CLASS && dtio_sub == NULL)
10077 {
Tobias Burnusd5656542010-11-12 00:07:23 +010010078 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
10079 "it is processed by a defined input/output procedure",
10080 &code->loc);
10081 return;
10082 }
10083
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010084 if (ts->type == BT_DERIVED)
10085 {
10086 /* Check that transferred derived type doesn't contain POINTER
Paul Thomase73d3ca2016-08-31 05:36:22 +000010087 components unless it is processed by a defined input/output
10088 procedure". */
10089 if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010090 {
Tobias Burnusd8155bf2011-07-18 08:48:19 +020010091 gfc_error ("Data transfer element at %L cannot have POINTER "
10092 "components unless it is processed by a defined "
10093 "input/output procedure", &code->loc);
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010094 return;
10095 }
10096
Janus Weil357f98e2011-02-18 13:23:56 +010010097 /* F08:C935. */
10098 if (ts->u.derived->attr.proc_pointer_comp)
10099 {
10100 gfc_error ("Data transfer element at %L cannot have "
10101 "procedure pointer components", &code->loc);
10102 return;
10103 }
10104
Paul Thomase73d3ca2016-08-31 05:36:22 +000010105 if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
Paul Thomas5046aff2006-10-08 16:21:55 +000010106 {
Tobias Burnusd8155bf2011-07-18 08:48:19 +020010107 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
10108 "components unless it is processed by a defined "
10109 "input/output procedure", &code->loc);
Paul Thomas5046aff2006-10-08 16:21:55 +000010110 return;
10111 }
10112
Sandra Loosemore67914692019-01-09 16:37:45 -050010113 /* C_PTR and C_FUNPTR have private components which means they cannot
Tobias Burnuscadddfd2013-03-25 16:40:26 +010010114 be printed. However, if -std=gnu and not -pedantic, allow
10115 the component to be printed to help debugging. */
10116 if (ts->u.derived->ts.f90_type == BT_VOID)
10117 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010118 if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L "
10119 "cannot have PRIVATE components", &code->loc))
Tobias Burnuscadddfd2013-03-25 16:40:26 +010010120 return;
10121 }
Paul Thomase73d3ca2016-08-31 05:36:22 +000010122 else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010123 {
10124 gfc_error ("Data transfer element at %L cannot have "
Paul Thomase73d3ca2016-08-31 05:36:22 +000010125 "PRIVATE components unless it is processed by "
10126 "a defined input/output procedure", &code->loc);
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010127 return;
10128 }
10129 }
Paul Thomas4f283c42015-09-26 17:52:24 +000010130
Tobias Burnus2f72ca12015-02-05 22:58:38 +010010131 if (exp->expr_type == EXPR_STRUCTURE)
10132 return;
10133
Harald Anlauf89f20c92022-10-09 20:43:32 +020010134 if (exp->expr_type == EXPR_ARRAY)
10135 return;
10136
Tobias Burnus2f72ca12015-02-05 22:58:38 +010010137 sym = exp->symtree->n.sym;
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010138
Janus Weilf2ce74d2011-09-15 19:48:27 +020010139 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020010140 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
10141 {
10142 gfc_error ("Data transfer element at %L cannot be a full reference to "
10143 "an assumed-size array", &code->loc);
10144 return;
10145 }
10146}
10147
10148
Diego Novillo6de9cd92004-05-13 02:41:07 -040010149/*********** Toplevel code resolution subroutines ***********/
10150
Tobias Schlüter0615f922007-04-13 15:48:08 +020010151/* Find the set of labels that are reachable from this block. We also
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010152 record the last statement in each block. */
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010153
Tobias Schlüter0615f922007-04-13 15:48:08 +020010154static void
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010155find_reachable_labels (gfc_code *block)
Tobias Schlüter0615f922007-04-13 15:48:08 +020010156{
10157 gfc_code *c;
10158
10159 if (!block)
10160 return;
10161
Trevor Saunders3fe793d2017-07-29 01:39:31 +000010162 cs_base->reachable_labels = bitmap_alloc (&labels_obstack);
Tobias Schlüter0615f922007-04-13 15:48:08 +020010163
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010164 /* Collect labels in this block. We don't keep those corresponding
10165 to END {IF|SELECT}, these are checked in resolve_branch by going
10166 up through the code_stack. */
Tobias Schlüter0615f922007-04-13 15:48:08 +020010167 for (c = block; c; c = c->next)
10168 {
Mikael Morindf1a69f2011-08-19 00:42:38 +020010169 if (c->here && c->op != EXEC_END_NESTED_BLOCK)
Tobias Schlüter0615f922007-04-13 15:48:08 +020010170 bitmap_set_bit (cs_base->reachable_labels, c->here->value);
Tobias Schlüter0615f922007-04-13 15:48:08 +020010171 }
10172
10173 /* Merge with labels from parent block. */
10174 if (cs_base->prev)
10175 {
10176 gcc_assert (cs_base->prev->reachable_labels);
10177 bitmap_ior_into (cs_base->reachable_labels,
10178 cs_base->prev->reachable_labels);
10179 }
10180}
10181
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010182
10183static void
Tobias Burnus5df445a2015-12-02 22:59:05 +010010184resolve_lock_unlock_event (gfc_code *code)
Tobias Burnus5493aa12011-06-08 08:28:41 +020010185{
Tobias Burnusb5116262014-06-17 22:54:14 +020010186 if (code->expr1->expr_type == EXPR_FUNCTION
10187 && code->expr1->value.function.isym
10188 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
10189 remove_caf_get_intrinsic (code->expr1);
10190
Tobias Burnus5df445a2015-12-02 22:59:05 +010010191 if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
10192 && (code->expr1->ts.type != BT_DERIVED
10193 || code->expr1->expr_type != EXPR_VARIABLE
10194 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
10195 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
10196 || code->expr1->rank != 0
10197 || (!gfc_is_coarray (code->expr1) &&
10198 !gfc_is_coindexed (code->expr1))))
Tobias Burnus3b6fa7a2011-08-18 17:10:25 +020010199 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
10200 &code->expr1->where);
Steven G. Kargl6b2e46b2015-12-04 16:37:54 +000010201 else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
Tobias Burnus5df445a2015-12-02 22:59:05 +010010202 && (code->expr1->ts.type != BT_DERIVED
10203 || code->expr1->expr_type != EXPR_VARIABLE
10204 || code->expr1->ts.u.derived->from_intmod
10205 != INTMOD_ISO_FORTRAN_ENV
10206 || code->expr1->ts.u.derived->intmod_sym_id
10207 != ISOFORTRAN_EVENT_TYPE
10208 || code->expr1->rank != 0))
10209 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
10210 &code->expr1->where);
10211 else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
10212 && !gfc_is_coindexed (code->expr1))
10213 gfc_error ("Event variable argument at %L must be a coarray or coindexed",
10214 &code->expr1->where);
10215 else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
10216 gfc_error ("Event variable argument at %L must be a coarray but not "
10217 "coindexed", &code->expr1->where);
Tobias Burnus5493aa12011-06-08 08:28:41 +020010218
10219 /* Check STAT. */
10220 if (code->expr2
10221 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
10222 || code->expr2->expr_type != EXPR_VARIABLE))
10223 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10224 &code->expr2->where);
10225
Tobias Burnusfea54932011-06-20 23:12:39 +020010226 if (code->expr2
Paul Thomas22c23882014-10-18 14:35:51 +000010227 && !gfc_check_vardef_context (code->expr2, false, false, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010228 _("STAT variable")))
Tobias Burnusfea54932011-06-20 23:12:39 +020010229 return;
10230
Tobias Burnus5493aa12011-06-08 08:28:41 +020010231 /* Check ERRMSG. */
10232 if (code->expr3
10233 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
10234 || code->expr3->expr_type != EXPR_VARIABLE))
10235 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10236 &code->expr3->where);
10237
Tobias Burnusfea54932011-06-20 23:12:39 +020010238 if (code->expr3
Paul Thomas22c23882014-10-18 14:35:51 +000010239 && !gfc_check_vardef_context (code->expr3, false, false, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010240 _("ERRMSG variable")))
Tobias Burnusfea54932011-06-20 23:12:39 +020010241 return;
10242
Tobias Burnus5df445a2015-12-02 22:59:05 +010010243 /* Check for LOCK the ACQUIRED_LOCK. */
10244 if (code->op != EXEC_EVENT_WAIT && code->expr4
Tobias Burnus5493aa12011-06-08 08:28:41 +020010245 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
10246 || code->expr4->expr_type != EXPR_VARIABLE))
10247 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
10248 "variable", &code->expr4->where);
Tobias Burnusfea54932011-06-20 23:12:39 +020010249
Tobias Burnus5df445a2015-12-02 22:59:05 +010010250 if (code->op != EXEC_EVENT_WAIT && code->expr4
Paul Thomas22c23882014-10-18 14:35:51 +000010251 && !gfc_check_vardef_context (code->expr4, false, false, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010252 _("ACQUIRED_LOCK variable")))
Tobias Burnusfea54932011-06-20 23:12:39 +020010253 return;
Tobias Burnus5df445a2015-12-02 22:59:05 +010010254
10255 /* Check for EVENT WAIT the UNTIL_COUNT. */
Andre Vehreschildeaed3222017-01-13 11:39:52 +010010256 if (code->op == EXEC_EVENT_WAIT && code->expr4)
10257 {
10258 if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER
10259 || code->expr4->rank != 0)
10260 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
10261 "expression", &code->expr4->where);
10262 }
Tobias Burnus5493aa12011-06-08 08:28:41 +020010263}
10264
10265
10266static void
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010267resolve_critical (gfc_code *code)
10268{
10269 gfc_symtree *symtree;
10270 gfc_symbol *lock_type;
10271 char name[GFC_MAX_SYMBOL_LEN];
10272 static int serial = 0;
10273
Tobias Burnusf19626c2014-12-17 07:29:30 +010010274 if (flag_coarray != GFC_FCOARRAY_LIB)
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010275 return;
10276
Tobias Burnus9de8e7a2014-08-15 18:33:08 +020010277 symtree = gfc_find_symtree (gfc_current_ns->sym_root,
10278 GFC_PREFIX ("lock_type"));
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010279 if (symtree)
10280 lock_type = symtree->n.sym;
10281 else
10282 {
Tobias Burnus9de8e7a2014-08-15 18:33:08 +020010283 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
10284 false) != 0)
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010285 gcc_unreachable ();
10286 lock_type = symtree->n.sym;
10287 lock_type->attr.flavor = FL_DERIVED;
10288 lock_type->attr.zero_comp = 1;
10289 lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV;
10290 lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
10291 }
10292
Tobias Burnus9de8e7a2014-08-15 18:33:08 +020010293 sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010294 if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
10295 gcc_unreachable ();
10296
10297 code->resolved_sym = symtree->n.sym;
10298 symtree->n.sym->attr.flavor = FL_VARIABLE;
10299 symtree->n.sym->attr.referenced = 1;
10300 symtree->n.sym->attr.artificial = 1;
10301 symtree->n.sym->attr.codimension = 1;
10302 symtree->n.sym->ts.type = BT_DERIVED;
10303 symtree->n.sym->ts.u.derived = lock_type;
10304 symtree->n.sym->as = gfc_get_array_spec ();
10305 symtree->n.sym->as->corank = 1;
10306 symtree->n.sym->as->type = AS_EXPLICIT;
10307 symtree->n.sym->as->cotype = AS_EXPLICIT;
10308 symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
10309 NULL, 1);
Alessandro Fanfarillo1fceb212015-12-15 06:19:21 -070010310 gfc_commit_symbols();
Tobias Burnusbc0229f2014-08-14 20:39:15 +020010311}
10312
10313
10314static void
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010315resolve_sync (gfc_code *code)
10316{
10317 /* Check imageset. The * case matches expr1 == NULL. */
10318 if (code->expr1)
10319 {
10320 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
10321 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
10322 "INTEGER expression", &code->expr1->where);
10323 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
10324 && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
10325 gfc_error ("Imageset argument at %L must between 1 and num_images()",
10326 &code->expr1->where);
10327 else if (code->expr1->expr_type == EXPR_ARRAY
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010328 && gfc_simplify_expr (code->expr1, 0))
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010329 {
10330 gfc_constructor *cons;
Jerry DeLisleb7e75772010-04-13 01:59:35 +000010331 cons = gfc_constructor_first (code->expr1->value.constructor);
10332 for (; cons; cons = gfc_constructor_next (cons))
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010333 if (cons->expr->expr_type == EXPR_CONSTANT
10334 && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
10335 gfc_error ("Imageset argument at %L must between 1 and "
10336 "num_images()", &cons->expr->where);
10337 }
10338 }
10339
10340 /* Check STAT. */
Steven G. Kargl8909fee2018-05-24 22:28:33 +000010341 gfc_resolve_expr (code->expr2);
Harald Anlaufbbf19f92021-08-15 20:13:11 +020010342 if (code->expr2)
10343 {
10344 if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0)
10345 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
10346 &code->expr2->where);
10347 else
10348 gfc_check_vardef_context (code->expr2, false, false, false,
10349 _("STAT variable"));
10350 }
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010351
10352 /* Check ERRMSG. */
Steven G. Kargl8909fee2018-05-24 22:28:33 +000010353 gfc_resolve_expr (code->expr3);
Harald Anlaufbbf19f92021-08-15 20:13:11 +020010354 if (code->expr3)
10355 {
10356 if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0)
10357 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
10358 &code->expr3->where);
10359 else
10360 gfc_check_vardef_context (code->expr3, false, false, false,
10361 _("ERRMSG variable"));
10362 }
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010363}
10364
10365
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010366/* Given a branch to a label, see if the branch is conforming.
Tobias Schlüter0615f922007-04-13 15:48:08 +020010367 The code node describes where the branch is located. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010368
10369static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010370resolve_branch (gfc_st_label *label, gfc_code *code)
Diego Novillo6de9cd92004-05-13 02:41:07 -040010371{
Diego Novillo6de9cd92004-05-13 02:41:07 -040010372 code_stack *stack;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010373
10374 if (label == NULL)
10375 return;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010376
10377 /* Step one: is this a valid branching target? */
10378
Tobias Schlüter0615f922007-04-13 15:48:08 +020010379 if (label->defined == ST_LABEL_UNKNOWN)
Diego Novillo6de9cd92004-05-13 02:41:07 -040010380 {
Tobias Schlüter0615f922007-04-13 15:48:08 +020010381 gfc_error ("Label %d referenced at %L is never defined", label->value,
Steven G. Kargl712dff32016-07-30 18:18:49 +000010382 &code->loc);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010383 return;
10384 }
10385
Tobias Burnusf3e7b9d2012-08-14 12:26:11 +020010386 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
Diego Novillo6de9cd92004-05-13 02:41:07 -040010387 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000010388 gfc_error ("Statement at %L is not a valid branch target statement "
Tobias Schlüter0615f922007-04-13 15:48:08 +020010389 "for the branch statement at %L", &label->where, &code->loc);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010390 return;
10391 }
10392
10393 /* Step two: make sure this branch is not a branch to itself ;-) */
10394
10395 if (code->here == label)
10396 {
Joseph Myersdb30e212015-02-01 00:29:54 +000010397 gfc_warning (0,
10398 "Branch at %L may result in an infinite loop", &code->loc);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010399 return;
10400 }
10401
Tobias Schlüter0615f922007-04-13 15:48:08 +020010402 /* Step three: See if the label is in the same block as the
10403 branching statement. The hard work has been done by setting up
10404 the bitmap reachable_labels. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010405
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010406 if (bitmap_bit_p (cs_base->reachable_labels, label->value))
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010407 {
10408 /* Check now whether there is a CRITICAL construct; if so, check
10409 whether the label is still visible outside of the CRITICAL block,
10410 which is invalid. */
10411 for (stack = cs_base; stack; stack = stack->prev)
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010412 {
10413 if (stack->current->op == EXEC_CRITICAL
10414 && bitmap_bit_p (stack->reachable_labels, label->value))
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000010415 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010416 "label at %L", &code->loc, &label->where);
10417 else if (stack->current->op == EXEC_DO_CONCURRENT
10418 && bitmap_bit_p (stack->reachable_labels, label->value))
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000010419 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010420 "for label at %L", &code->loc, &label->where);
10421 }
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010422
10423 return;
10424 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010425
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010426 /* Step four: If we haven't found the label in the bitmap, it may
10427 still be the label of the END of the enclosing block, in which
10428 case we find it by going up the code_stack. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010429
Tobias Schlüter0615f922007-04-13 15:48:08 +020010430 for (stack = cs_base; stack; stack = stack->prev)
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010431 {
10432 if (stack->current->next && stack->current->next->here == label)
10433 break;
10434 if (stack->current->op == EXEC_CRITICAL)
10435 {
10436 /* Note: A label at END CRITICAL does not leave the CRITICAL
10437 construct as END CRITICAL is still part of it. */
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000010438 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010439 " at %L", &code->loc, &label->where);
10440 return;
10441 }
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010442 else if (stack->current->op == EXEC_DO_CONCURRENT)
10443 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000010444 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010445 "label at %L", &code->loc, &label->where);
10446 return;
10447 }
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010448 }
Tobias Schlüter0615f922007-04-13 15:48:08 +020010449
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010450 if (stack)
Diego Novillo6de9cd92004-05-13 02:41:07 -040010451 {
Mikael Morindf1a69f2011-08-19 00:42:38 +020010452 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK);
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010453 return;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010454 }
Tobias Schlüter0615f922007-04-13 15:48:08 +020010455
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010456 /* The label is not in an enclosing block, so illegal. This was
10457 allowed in Fortran 66, so we allow it as extension. No
10458 further checks are necessary in this case. */
Manuel López-Ibáñez2a2703a2015-05-16 12:31:00 +000010459 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
Tobias Schlüterd80c6952009-03-29 19:15:48 +020010460 "as the GOTO statement at %L", &label->where,
10461 &code->loc);
10462 return;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010463}
10464
10465
10466/* Check whether EXPR1 has the same shape as EXPR2. */
10467
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010468static bool
Diego Novillo6de9cd92004-05-13 02:41:07 -040010469resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
10470{
10471 mpz_t shape[GFC_MAX_DIMENSIONS];
10472 mpz_t shape2[GFC_MAX_DIMENSIONS];
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010473 bool result = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010474 int i;
10475
10476 /* Compare the rank. */
10477 if (expr1->rank != expr2->rank)
10478 return result;
10479
10480 /* Compare the size of each dimension. */
10481 for (i=0; i<expr1->rank; i++)
10482 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010483 if (!gfc_array_dimen_size (expr1, i, &shape[i]))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010484 goto ignore;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010485
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010486 if (!gfc_array_dimen_size (expr2, i, &shape2[i]))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010487 goto ignore;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010488
10489 if (mpz_cmp (shape[i], shape2[i]))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010490 goto over;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010491 }
10492
10493 /* When either of the two expression is an assumed size array, we
10494 ignore the comparison of dimension sizes. */
10495ignore:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010496 result = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010497
10498over:
Mikael Morin7d7212e2011-08-22 14:07:30 +000010499 gfc_clear_shape (shape, i);
10500 gfc_clear_shape (shape2, i);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010501 return result;
10502}
10503
10504
10505/* Check whether a WHERE assignment target or a WHERE mask expression
10506 has the same shape as the outmost WHERE mask expression. */
10507
10508static void
10509resolve_where (gfc_code *code, gfc_expr *mask)
10510{
10511 gfc_code *cblock;
10512 gfc_code *cnext;
10513 gfc_expr *e = NULL;
10514
10515 cblock = code->block;
10516
10517 /* Store the first WHERE mask-expr of the WHERE statement or construct.
10518 In case of nested WHERE, only the outmost one is stored. */
10519 if (mask == NULL) /* outmost WHERE */
Steven G. Kargla5139272009-05-13 20:49:13 +000010520 e = cblock->expr1;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010521 else /* inner WHERE */
10522 e = mask;
10523
10524 while (cblock)
10525 {
Steven G. Kargla5139272009-05-13 20:49:13 +000010526 if (cblock->expr1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010527 {
10528 /* Check if the mask-expr has a consistent shape with the
10529 outmost WHERE mask-expr. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010530 if (!resolve_where_shape (cblock->expr1, e))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010531 gfc_error ("WHERE mask at %L has inconsistent shape",
Steven G. Kargla5139272009-05-13 20:49:13 +000010532 &cblock->expr1->where);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010533 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010534
10535 /* the assignment statement of a WHERE statement, or the first
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010536 statement in where-body-construct of a WHERE construct */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010537 cnext = cblock->next;
10538 while (cnext)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010539 {
10540 switch (cnext->op)
10541 {
10542 /* WHERE assignment statement */
10543 case EXEC_ASSIGN:
Diego Novillo6de9cd92004-05-13 02:41:07 -040010544
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010545 /* Check shape consistent for WHERE assignment target. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010546 if (e && !resolve_where_shape (cnext->expr1, e))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010547 gfc_error ("WHERE assignment target at %L has "
Steven G. Kargla5139272009-05-13 20:49:13 +000010548 "inconsistent shape", &cnext->expr1->where);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010549 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010550
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010551
Paul Thomasa00b8d12007-01-27 18:23:14 +000010552 case EXEC_ASSIGN_CALL:
10553 resolve_call (cnext);
Daniel Franke42cd23c2008-01-25 16:55:47 -050010554 if (!cnext->resolved_sym->attr.elemental)
Daniel Frankeba6e57b2008-02-04 17:29:35 -050010555 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
Daniel Franke42cd23c2008-01-25 16:55:47 -050010556 &cnext->ext.actual->expr->where);
Paul Thomasa00b8d12007-01-27 18:23:14 +000010557 break;
10558
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010559 /* WHERE or WHERE construct is part of a where-body-construct */
10560 case EXEC_WHERE:
10561 resolve_where (cnext, e);
10562 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010563
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010564 default:
10565 gfc_error ("Unsupported statement inside WHERE at %L",
10566 &cnext->loc);
10567 }
10568 /* the next statement within the same where-body-construct */
10569 cnext = cnext->next;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010570 }
10571 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10572 cblock = cblock->block;
10573 }
10574}
10575
10576
Diego Novillo6de9cd92004-05-13 02:41:07 -040010577/* Resolve assignment in FORALL construct.
10578 NVAR is the number of FORALL index variables, and VAR_EXPR records the
10579 FORALL index variables. */
10580
10581static void
10582gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
10583{
10584 int n;
10585
10586 for (n = 0; n < nvar; n++)
10587 {
10588 gfc_symbol *forall_index;
10589
10590 forall_index = var_expr[n]->symtree->n.sym;
10591
10592 /* Check whether the assignment target is one of the FORALL index
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010593 variable. */
Steven G. Kargla5139272009-05-13 20:49:13 +000010594 if ((code->expr1->expr_type == EXPR_VARIABLE)
10595 && (code->expr1->symtree->n.sym == forall_index))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010596 gfc_error ("Assignment to a FORALL index variable at %L",
Steven G. Kargla5139272009-05-13 20:49:13 +000010597 &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010598 else
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010599 {
10600 /* If one of the FORALL index variables doesn't appear in the
Paul Thomas67cec812008-11-03 06:44:47 +000010601 assignment variable, then there could be a many-to-one
10602 assignment. Emit a warning rather than an error because the
10603 mask could be resolving this problem. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010604 if (!find_forall_index (code->expr1, forall_index, 0))
Joseph Myersdb30e212015-02-01 00:29:54 +000010605 gfc_warning (0, "The FORALL with index %qs is not used on the "
Paul Thomas67cec812008-11-03 06:44:47 +000010606 "left side of the assignment at %L and so might "
10607 "cause multiple assignment to this object",
Steven G. Kargla5139272009-05-13 20:49:13 +000010608 var_expr[n]->symtree->name, &code->expr1->where);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010609 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010610 }
10611}
10612
10613
10614/* Resolve WHERE statement in FORALL construct. */
10615
10616static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010617gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
10618 gfc_expr **var_expr)
10619{
Diego Novillo6de9cd92004-05-13 02:41:07 -040010620 gfc_code *cblock;
10621 gfc_code *cnext;
10622
10623 cblock = code->block;
10624 while (cblock)
10625 {
10626 /* the assignment statement of a WHERE statement, or the first
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010627 statement in where-body-construct of a WHERE construct */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010628 cnext = cblock->next;
10629 while (cnext)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010630 {
10631 switch (cnext->op)
10632 {
10633 /* WHERE assignment statement */
10634 case EXEC_ASSIGN:
10635 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
10636 break;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010637
Paul Thomasa00b8d12007-01-27 18:23:14 +000010638 /* WHERE operator assignment statement */
10639 case EXEC_ASSIGN_CALL:
10640 resolve_call (cnext);
Daniel Franke42cd23c2008-01-25 16:55:47 -050010641 if (!cnext->resolved_sym->attr.elemental)
Daniel Frankeba6e57b2008-02-04 17:29:35 -050010642 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
Daniel Franke42cd23c2008-01-25 16:55:47 -050010643 &cnext->ext.actual->expr->where);
Paul Thomasa00b8d12007-01-27 18:23:14 +000010644 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010645
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010646 /* WHERE or WHERE construct is part of a where-body-construct */
10647 case EXEC_WHERE:
10648 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
10649 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010650
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010651 default:
10652 gfc_error ("Unsupported statement inside WHERE at %L",
10653 &cnext->loc);
10654 }
10655 /* the next statement within the same where-body-construct */
10656 cnext = cnext->next;
10657 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010658 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
10659 cblock = cblock->block;
10660 }
10661}
10662
10663
10664/* Traverse the FORALL body to check whether the following errors exist:
10665 1. For assignment, check if a many-to-one assignment happens.
10666 2. For WHERE statement, check the WHERE body to see if there is any
10667 many-to-one assignment. */
10668
10669static void
10670gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
10671{
10672 gfc_code *c;
10673
10674 c = code->block->next;
10675 while (c)
10676 {
10677 switch (c->op)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010678 {
10679 case EXEC_ASSIGN:
10680 case EXEC_POINTER_ASSIGN:
10681 gfc_resolve_assign_in_forall (c, nvar, var_expr);
10682 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010683
Paul Thomasa00b8d12007-01-27 18:23:14 +000010684 case EXEC_ASSIGN_CALL:
10685 resolve_call (c);
10686 break;
10687
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010688 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
10689 there is no need to handle it here. */
10690 case EXEC_FORALL:
10691 break;
10692 case EXEC_WHERE:
10693 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
10694 break;
10695 default:
10696 break;
10697 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010698 /* The next statement in the FORALL body. */
10699 c = c->next;
10700 }
10701}
10702
10703
Mikael Morin0e6834a2008-10-31 16:37:17 +010010704/* Counts the number of iterators needed inside a forall construct, including
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010705 nested forall constructs. This is used to allocate the needed memory
Mikael Morin0e6834a2008-10-31 16:37:17 +010010706 in gfc_resolve_forall. */
10707
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010708static int
Mikael Morin0e6834a2008-10-31 16:37:17 +010010709gfc_count_forall_iterators (gfc_code *code)
10710{
10711 int max_iters, sub_iters, current_iters;
10712 gfc_forall_iterator *fa;
10713
10714 gcc_assert(code->op == EXEC_FORALL);
10715 max_iters = 0;
10716 current_iters = 0;
10717
10718 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10719 current_iters ++;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010720
Mikael Morin0e6834a2008-10-31 16:37:17 +010010721 code = code->block->next;
10722
10723 while (code)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000010724 {
Mikael Morin0e6834a2008-10-31 16:37:17 +010010725 if (code->op == EXEC_FORALL)
10726 {
10727 sub_iters = gfc_count_forall_iterators (code);
10728 if (sub_iters > max_iters)
10729 max_iters = sub_iters;
10730 }
10731 code = code->next;
10732 }
10733
10734 return current_iters + max_iters;
10735}
10736
10737
Diego Novillo6de9cd92004-05-13 02:41:07 -040010738/* Given a FORALL construct, first resolve the FORALL iterator, then call
10739 gfc_resolve_forall_body to resolve the FORALL body. */
10740
Diego Novillo6de9cd92004-05-13 02:41:07 -040010741static void
10742gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
10743{
10744 static gfc_expr **var_expr;
10745 static int total_var = 0;
10746 static int nvar = 0;
Harald Anlauf8dc998f2016-11-20 18:43:16 +000010747 int i, old_nvar, tmp;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010748 gfc_forall_iterator *fa;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010749
Mikael Morin0e6834a2008-10-31 16:37:17 +010010750 old_nvar = nvar;
10751
Janus Weil9143aa52018-05-25 08:09:10 +020010752 if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc))
10753 return;
10754
Diego Novillo6de9cd92004-05-13 02:41:07 -040010755 /* Start to resolve a FORALL construct */
10756 if (forall_save == 0)
10757 {
Harald Anlauf8dc998f2016-11-20 18:43:16 +000010758 /* Count the total number of FORALL indices in the nested FORALL
Mikael Morin0e6834a2008-10-31 16:37:17 +010010759 construct in order to allocate the VAR_EXPR with proper size. */
10760 total_var = gfc_count_forall_iterators (code);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010761
Kazu Hirataf7b529f2004-11-08 14:56:41 +000010762 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
Janne Blomqvist93acb622011-04-19 20:42:51 +030010763 var_expr = XCNEWVEC (gfc_expr *, total_var);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010764 }
10765
Harald Anlauf8dc998f2016-11-20 18:43:16 +000010766 /* The information about FORALL iterator, including FORALL indices start, end
10767 and stride. An outer FORALL indice cannot appear in start, end or stride. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010768 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
10769 {
Harald Anlauf8dc998f2016-11-20 18:43:16 +000010770 /* Fortran 20008: C738 (R753). */
10771 if (fa->var->ref && fa->var->ref->type == REF_ARRAY)
10772 {
10773 gfc_error ("FORALL index-name at %L must be a scalar variable "
10774 "of type integer", &fa->var->where);
10775 continue;
10776 }
10777
Diego Novillo6de9cd92004-05-13 02:41:07 -040010778 /* Check if any outer FORALL index name is the same as the current
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010779 one. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040010780 for (i = 0; i < nvar; i++)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010781 {
10782 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
Harald Anlauf8dc998f2016-11-20 18:43:16 +000010783 gfc_error ("An outer FORALL construct already has an index "
10784 "with this name %L", &fa->var->where);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010785 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010786
10787 /* Record the current FORALL index. */
10788 var_expr[nvar] = gfc_copy_expr (fa->var);
10789
Diego Novillo6de9cd92004-05-13 02:41:07 -040010790 nvar++;
Mikael Morin0e6834a2008-10-31 16:37:17 +010010791
10792 /* No memory leak. */
10793 gcc_assert (nvar <= total_var);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010794 }
10795
10796 /* Resolve the FORALL body. */
10797 gfc_resolve_forall_body (code, nvar, var_expr);
10798
10799 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010800 gfc_resolve_blocks (code->block, ns);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010801
Mikael Morin0e6834a2008-10-31 16:37:17 +010010802 tmp = nvar;
10803 nvar = old_nvar;
10804 /* Free only the VAR_EXPRs allocated in this frame. */
10805 for (i = nvar; i < tmp; i++)
10806 gfc_free_expr (var_expr[i]);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010807
Mikael Morin0e6834a2008-10-31 16:37:17 +010010808 if (nvar == 0)
10809 {
10810 /* We are in the outermost FORALL construct. */
10811 gcc_assert (forall_save == 0);
10812
10813 /* VAR_EXPR is not needed any more. */
Jim Meyeringcede9502011-04-18 19:20:53 +000010814 free (var_expr);
Mikael Morin0e6834a2008-10-31 16:37:17 +010010815 total_var = 0;
10816 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040010817}
10818
10819
Daniel Kraft9abe5e52009-09-29 09:42:42 +020010820/* Resolve a BLOCK construct statement. */
10821
10822static void
10823resolve_block_construct (gfc_code* code)
10824{
Daniel Kraft03af1e42010-06-10 16:47:49 +020010825 /* Resolve the BLOCK's namespace. */
10826 gfc_resolve (code->ext.block.ns);
Daniel Kraft52bf62f2010-08-15 21:46:21 +020010827
10828 /* For an ASSOCIATE block, the associations (and their targets) are already
Daniel Kraft3e782382010-08-26 21:48:43 +020010829 resolved during resolve_symbol. */
Daniel Kraft9abe5e52009-09-29 09:42:42 +020010830}
10831
10832
10833/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
Diego Novillo6de9cd92004-05-13 02:41:07 -040010834 DO code nodes. */
10835
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010836void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010837gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
Diego Novillo6de9cd92004-05-13 02:41:07 -040010838{
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010839 bool t;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010840
10841 for (; b; b = b->block)
10842 {
Steven G. Kargla5139272009-05-13 20:49:13 +000010843 t = gfc_resolve_expr (b->expr1);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010844 if (!gfc_resolve_expr (b->expr2))
10845 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010846
10847 switch (b->op)
10848 {
10849 case EXEC_IF:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010850 if (t && b->expr1 != NULL
Steven G. Kargla5139272009-05-13 20:49:13 +000010851 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010852 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
Steven G. Kargla5139272009-05-13 20:49:13 +000010853 &b->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010854 break;
10855
10856 case EXEC_WHERE:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010857 if (t
Steven G. Kargla5139272009-05-13 20:49:13 +000010858 && b->expr1 != NULL
10859 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010860 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
Steven G. Kargla5139272009-05-13 20:49:13 +000010861 &b->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010862 break;
10863
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010864 case EXEC_GOTO:
Steven G. Kargl79bd1942009-05-13 16:17:59 +000010865 resolve_branch (b->label1, b);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000010866 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040010867
Daniel Kraft9abe5e52009-09-29 09:42:42 +020010868 case EXEC_BLOCK:
10869 resolve_block_construct (b);
10870 break;
10871
Diego Novillo6de9cd92004-05-13 02:41:07 -040010872 case EXEC_SELECT:
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020010873 case EXEC_SELECT_TYPE:
Paul Thomas70570ec2019-09-01 12:53:02 +000010874 case EXEC_SELECT_RANK:
Diego Novillo6de9cd92004-05-13 02:41:07 -040010875 case EXEC_FORALL:
10876 case EXEC_DO:
10877 case EXEC_DO_WHILE:
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020010878 case EXEC_DO_CONCURRENT:
Tobias Burnusd0a4a612010-04-06 18:26:02 +020010879 case EXEC_CRITICAL:
Jakub Jelinek5e805e42005-11-21 23:03:56 +010010880 case EXEC_READ:
10881 case EXEC_WRITE:
10882 case EXEC_IOLENGTH:
Jerry DeLisle6f0f0b22008-04-05 22:23:27 +000010883 case EXEC_WAIT:
Diego Novillo6de9cd92004-05-13 02:41:07 -040010884 break;
10885
Jakub Jelinekf25f40b2016-08-31 20:42:08 +020010886 case EXEC_OMP_ATOMIC:
10887 case EXEC_OACC_ATOMIC:
10888 {
Jakub Jelinekf25f40b2016-08-31 20:42:08 +020010889 /* Verify this before calling gfc_resolve_code, which might
10890 change it. */
Tobias Burnus689407e2021-12-04 19:39:43 +010010891 gcc_assert (b->op == EXEC_OMP_ATOMIC
10892 || (b->next && b->next->op == EXEC_ASSIGN));
Jakub Jelinekf25f40b2016-08-31 20:42:08 +020010893 }
10894 break;
10895
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010010896 case EXEC_OACC_PARALLEL_LOOP:
10897 case EXEC_OACC_PARALLEL:
10898 case EXEC_OACC_KERNELS_LOOP:
10899 case EXEC_OACC_KERNELS:
Maciej W. Rozycki62aee282019-11-12 08:45:35 +000010900 case EXEC_OACC_SERIAL_LOOP:
10901 case EXEC_OACC_SERIAL:
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010010902 case EXEC_OACC_DATA:
10903 case EXEC_OACC_HOST_DATA:
10904 case EXEC_OACC_LOOP:
10905 case EXEC_OACC_UPDATE:
10906 case EXEC_OACC_WAIT:
10907 case EXEC_OACC_CACHE:
10908 case EXEC_OACC_ENTER_DATA:
10909 case EXEC_OACC_EXIT_DATA:
Cesar Philippidisdb941d72015-11-30 11:09:33 -080010910 case EXEC_OACC_ROUTINE:
Tobias Burnuse2a22842022-10-05 19:25:27 +020010911 case EXEC_OMP_ASSUME:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010912 case EXEC_OMP_CRITICAL:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010913 case EXEC_OMP_DISTRIBUTE:
10914 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10915 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10916 case EXEC_OMP_DISTRIBUTE_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010917 case EXEC_OMP_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020010918 case EXEC_OMP_DO_SIMD:
Tobias Burnus77167192021-08-20 12:12:51 +020010919 case EXEC_OMP_ERROR:
Tobias Burnus178191e2021-06-04 12:06:59 +020010920 case EXEC_OMP_LOOP:
Tobias Burnus53d5b592021-08-16 09:26:26 +020010921 case EXEC_OMP_MASKED:
10922 case EXEC_OMP_MASKED_TASKLOOP:
10923 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010924 case EXEC_OMP_MASTER:
Tobias Burnusf6bf4362021-06-01 12:46:37 +020010925 case EXEC_OMP_MASTER_TASKLOOP:
10926 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010927 case EXEC_OMP_ORDERED:
10928 case EXEC_OMP_PARALLEL:
10929 case EXEC_OMP_PARALLEL_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020010930 case EXEC_OMP_PARALLEL_DO_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020010931 case EXEC_OMP_PARALLEL_LOOP:
Tobias Burnus53d5b592021-08-16 09:26:26 +020010932 case EXEC_OMP_PARALLEL_MASKED:
10933 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10934 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
Tobias Burnus0e3702f2021-05-14 19:21:47 +020010935 case EXEC_OMP_PARALLEL_MASTER:
Tobias Burnusf6bf4362021-06-01 12:46:37 +020010936 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10937 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010938 case EXEC_OMP_PARALLEL_SECTIONS:
10939 case EXEC_OMP_PARALLEL_WORKSHARE:
10940 case EXEC_OMP_SECTIONS:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020010941 case EXEC_OMP_SIMD:
Tobias Burnusf8d535f2021-08-17 15:50:11 +020010942 case EXEC_OMP_SCOPE:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010943 case EXEC_OMP_SINGLE:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010944 case EXEC_OMP_TARGET:
10945 case EXEC_OMP_TARGET_DATA:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010010946 case EXEC_OMP_TARGET_ENTER_DATA:
10947 case EXEC_OMP_TARGET_EXIT_DATA:
10948 case EXEC_OMP_TARGET_PARALLEL:
10949 case EXEC_OMP_TARGET_PARALLEL_DO:
10950 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020010951 case EXEC_OMP_TARGET_PARALLEL_LOOP:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010010952 case EXEC_OMP_TARGET_SIMD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010953 case EXEC_OMP_TARGET_TEAMS:
10954 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10955 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10956 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10957 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020010958 case EXEC_OMP_TARGET_TEAMS_LOOP:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010959 case EXEC_OMP_TARGET_UPDATE:
Jakub Jelineka68ab352008-06-06 15:01:54 +020010960 case EXEC_OMP_TASK:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020010961 case EXEC_OMP_TASKGROUP:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010010962 case EXEC_OMP_TASKLOOP:
10963 case EXEC_OMP_TASKLOOP_SIMD:
Jakub Jelineka68ab352008-06-06 15:01:54 +020010964 case EXEC_OMP_TASKWAIT:
Jakub Jelinek20906c62011-08-02 18:13:29 +020010965 case EXEC_OMP_TASKYIELD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010966 case EXEC_OMP_TEAMS:
10967 case EXEC_OMP_TEAMS_DISTRIBUTE:
10968 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10969 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020010970 case EXEC_OMP_TEAMS_LOOP:
Jakub Jelinekf014c652014-06-18 09:16:12 +020010971 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010010972 case EXEC_OMP_WORKSHARE:
10973 break;
10974
Diego Novillo6de9cd92004-05-13 02:41:07 -040010975 default:
Daniel Kraft9abe5e52009-09-29 09:42:42 +020010976 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
Diego Novillo6de9cd92004-05-13 02:41:07 -040010977 }
10978
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020010979 gfc_resolve_code (b->next, ns);
Diego Novillo6de9cd92004-05-13 02:41:07 -040010980 }
10981}
10982
10983
Paul Thomasc5422462007-10-21 18:10:00 +000010984/* Does everything to resolve an ordinary assignment. Returns true
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +000010985 if this is an interface assignment. */
Paul Thomasc5422462007-10-21 18:10:00 +000010986static bool
10987resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
10988{
10989 bool rval = false;
10990 gfc_expr *lhs;
10991 gfc_expr *rhs;
Paul Thomasc5422462007-10-21 18:10:00 +000010992 int n;
10993 gfc_ref *ref;
Tobias Burnus83ba23b2013-09-18 20:14:57 +020010994 symbol_attribute attr;
Paul Thomasc5422462007-10-21 18:10:00 +000010995
Janne Blomqvist524af0d2013-04-11 00:36:58 +030010996 if (gfc_extend_assign (code, ns))
Paul Thomasc5422462007-10-21 18:10:00 +000010997 {
Daniel Kraft4a44a722009-08-27 13:42:56 +020010998 gfc_expr** rhsptr;
10999
11000 if (code->op == EXEC_ASSIGN_CALL)
Paul Thomasc5422462007-10-21 18:10:00 +000011001 {
Daniel Kraft4a44a722009-08-27 13:42:56 +020011002 lhs = code->ext.actual->expr;
11003 rhsptr = &code->ext.actual->next->expr;
Daniel Kraft4a44a722009-08-27 13:42:56 +020011004 }
11005 else
11006 {
11007 gfc_actual_arglist* args;
11008 gfc_typebound_proc* tbp;
11009
11010 gcc_assert (code->op == EXEC_COMPCALL);
11011
11012 args = code->expr1->value.compcall.actual;
11013 lhs = args->expr;
11014 rhsptr = &args->next->expr;
11015
11016 tbp = code->expr1->value.compcall.tbp;
11017 gcc_assert (!tbp->is_generic);
Paul Thomasc5422462007-10-21 18:10:00 +000011018 }
11019
11020 /* Make a temporary rhs when there is a default initializer
11021 and rhs is the same symbol as the lhs. */
Daniel Kraft4a44a722009-08-27 13:42:56 +020011022 if ((*rhsptr)->expr_type == EXPR_VARIABLE
11023 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
Daniel Franke16e520b2010-05-19 09:07:25 -040011024 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
Daniel Kraft4a44a722009-08-27 13:42:56 +020011025 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
11026 *rhsptr = gfc_get_parentheses (*rhsptr);
Paul Thomasc5422462007-10-21 18:10:00 +000011027
11028 return true;
11029 }
11030
Steven G. Kargla5139272009-05-13 20:49:13 +000011031 lhs = code->expr1;
Paul Thomasc5422462007-10-21 18:10:00 +000011032 rhs = code->expr2;
11033
Mark Eggleston2afeb1c2019-11-08 14:28:57 +000011034 if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
11035 && rhs->ts.type == BT_CHARACTER
Mark Eggleston32bef8f2019-11-25 10:36:25 +000011036 && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
Mark Eggleston2afeb1c2019-11-08 14:28:57 +000011037 {
11038 /* Use of -fdec-char-conversions allows assignment of character data
11039 to non-character variables. This not permited for nonconstant
11040 strings. */
11041 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
11042 gfc_typename (lhs), &rhs->where);
11043 return false;
11044 }
11045
Tobias Burnus00a46182007-12-08 22:46:56 +010011046 /* Handle the case of a BOZ literal on the RHS. */
Steven G. Kargl8dc63162019-07-23 21:43:21 +000011047 if (rhs->ts.type == BT_BOZ)
Tobias Burnus00a46182007-12-08 22:46:56 +010011048 {
Steven G. Kargl8dc63162019-07-23 21:43:21 +000011049 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA "
11050 "statement value nor an actual argument of "
11051 "INT/REAL/DBLE/CMPLX intrinsic subprogram",
11052 &rhs->where))
Tobias Burnusc7abc452007-12-20 09:13:09 +010011053 return false;
Steven G. Kargl8dc63162019-07-23 21:43:21 +000011054
11055 switch (lhs->ts.type)
Tobias Burnus4956b1f2007-12-14 16:11:17 +010011056 {
Steven G. Kargl8dc63162019-07-23 21:43:21 +000011057 case BT_INTEGER:
11058 if (!gfc_boz2int (rhs, lhs->ts.kind))
11059 return false;
11060 break;
11061 case BT_REAL:
11062 if (!gfc_boz2real (rhs, lhs->ts.kind))
11063 return false;
11064 break;
11065 default:
11066 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where);
Tobias Burnus4956b1f2007-12-14 16:11:17 +010011067 return false;
11068 }
Tobias Burnus00a46182007-12-08 22:46:56 +010011069 }
11070
Steven G. Kargl8dc63162019-07-23 21:43:21 +000011071 if (lhs->ts.type == BT_CHARACTER && warn_character_truncation)
Paul Thomasc5422462007-10-21 18:10:00 +000011072 {
Janne Blomqvist6b271a22018-01-22 15:31:08 +020011073 HOST_WIDE_INT llen = 0, rlen = 0;
Janus Weilbc21d312009-08-13 21:46:46 +020011074 if (lhs->ts.u.cl != NULL
11075 && lhs->ts.u.cl->length != NULL
11076 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
Janne Blomqvist6b271a22018-01-22 15:31:08 +020011077 llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
Paul Thomasc5422462007-10-21 18:10:00 +000011078
11079 if (rhs->expr_type == EXPR_CONSTANT)
11080 rlen = rhs->value.character.length;
11081
Janus Weilbc21d312009-08-13 21:46:46 +020011082 else if (rhs->ts.u.cl != NULL
Daniel Kraft4a44a722009-08-27 13:42:56 +020011083 && rhs->ts.u.cl->length != NULL
Janus Weilbc21d312009-08-13 21:46:46 +020011084 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
Janne Blomqvist6b271a22018-01-22 15:31:08 +020011085 rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer);
Paul Thomasc5422462007-10-21 18:10:00 +000011086
11087 if (rlen && llen && rlen > llen)
Tobias Burnus4daa1492014-11-25 23:33:32 +010011088 gfc_warning_now (OPT_Wcharacter_truncation,
11089 "CHARACTER expression will be truncated "
Janne Blomqvist6b271a22018-01-22 15:31:08 +020011090 "in assignment (%ld/%ld) at %L",
11091 (long) llen, (long) rlen, &code->loc);
Paul Thomasc5422462007-10-21 18:10:00 +000011092 }
11093
11094 /* Ensure that a vector index expression for the lvalue is evaluated
Paul Thomas908a2232007-11-27 20:47:55 +000011095 to a temporary if the lvalue symbol is referenced in it. */
Paul Thomasc5422462007-10-21 18:10:00 +000011096 if (lhs->rank)
11097 {
11098 for (ref = lhs->ref; ref; ref= ref->next)
11099 if (ref->type == REF_ARRAY)
11100 {
11101 for (n = 0; n < ref->u.ar.dimen; n++)
Paul Thomas908a2232007-11-27 20:47:55 +000011102 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
Jakub Jelineka68ab352008-06-06 15:01:54 +020011103 && gfc_find_sym_in_expr (lhs->symtree->n.sym,
11104 ref->u.ar.start[n]))
Paul Thomasc5422462007-10-21 18:10:00 +000011105 ref->u.ar.start[n]
11106 = gfc_get_parentheses (ref->u.ar.start[n]);
11107 }
11108 }
11109
11110 if (gfc_pure (NULL))
11111 {
Paul Thomasc5422462007-10-21 18:10:00 +000011112 if (lhs->ts.type == BT_DERIVED
11113 && lhs->expr_type == EXPR_VARIABLE
Janus Weilbc21d312009-08-13 21:46:46 +020011114 && lhs->ts.u.derived->attr.pointer_comp
Tobias Burnus4eceddd2010-03-14 14:18:28 +010011115 && rhs->expr_type == EXPR_VARIABLE
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011116 && (gfc_impure_variable (rhs->symtree->n.sym)
11117 || gfc_is_coindexed (rhs)))
Paul Thomasc5422462007-10-21 18:10:00 +000011118 {
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011119 /* F2008, C1283. */
11120 if (gfc_is_coindexed (rhs))
11121 gfc_error ("Coindexed expression at %L is assigned to "
11122 "a derived type variable with a POINTER "
11123 "component in a PURE procedure",
11124 &rhs->where);
11125 else
Damian Rouson51a6a402019-10-13 17:16:40 +000011126 /* F2008, C1283 (4). */
11127 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument "
11128 "shall not be used as the expr at %L of an intrinsic "
11129 "assignment statement in which the variable is of a "
11130 "derived type if the derived type has a pointer "
11131 "component at any level of component selection.",
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011132 &rhs->where);
11133 return rval;
11134 }
11135
11136 /* Fortran 2008, C1283. */
11137 if (gfc_is_coindexed (lhs))
11138 {
11139 gfc_error ("Assignment to coindexed variable at %L in a PURE "
11140 "procedure", &rhs->where);
Paul Thomasc5422462007-10-21 18:10:00 +000011141 return rval;
11142 }
11143 }
11144
Paul Thomasf1f39032011-01-08 19:17:03 +000011145 if (gfc_implicit_pure (NULL))
11146 {
11147 if (lhs->expr_type == EXPR_VARIABLE
11148 && lhs->symtree->n.sym != gfc_current_ns->proc_name
11149 && lhs->symtree->n.sym->ns != gfc_current_ns)
Tobias Burnus9964e832014-03-20 07:53:01 +010011150 gfc_unset_implicit_pure (NULL);
Paul Thomasf1f39032011-01-08 19:17:03 +000011151
11152 if (lhs->ts.type == BT_DERIVED
11153 && lhs->expr_type == EXPR_VARIABLE
11154 && lhs->ts.u.derived->attr.pointer_comp
11155 && rhs->expr_type == EXPR_VARIABLE
11156 && (gfc_impure_variable (rhs->symtree->n.sym)
11157 || gfc_is_coindexed (rhs)))
Tobias Burnus9964e832014-03-20 07:53:01 +010011158 gfc_unset_implicit_pure (NULL);
Paul Thomasf1f39032011-01-08 19:17:03 +000011159
11160 /* Fortran 2008, C1283. */
11161 if (gfc_is_coindexed (lhs))
Tobias Burnus9964e832014-03-20 07:53:01 +010011162 gfc_unset_implicit_pure (NULL);
Paul Thomasf1f39032011-01-08 19:17:03 +000011163 }
11164
Tobias Burnus83ba23b2013-09-18 20:14:57 +020011165 /* F2008, 7.2.1.2. */
11166 attr = gfc_expr_attr (lhs);
11167 if (lhs->ts.type == BT_CLASS && attr.allocatable)
Janus Weil0ae278e2009-10-16 23:10:43 +020011168 {
Tobias Burnus83ba23b2013-09-18 20:14:57 +020011169 if (attr.codimension)
11170 {
11171 gfc_error ("Assignment to polymorphic coarray at %L is not "
11172 "permitted", &lhs->where);
11173 return false;
11174 }
11175 if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable "
11176 "polymorphic variable at %L", &lhs->where))
11177 return false;
Tobias Burnus203c7eb2014-12-16 20:24:50 +010011178 if (!flag_realloc_lhs)
Tobias Burnus83ba23b2013-09-18 20:14:57 +020011179 {
11180 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010011181 "requires %<-frealloc-lhs%>", &lhs->where);
Tobias Burnus83ba23b2013-09-18 20:14:57 +020011182 return false;
11183 }
Tobias Burnus83ba23b2013-09-18 20:14:57 +020011184 }
11185 else if (lhs->ts.type == BT_CLASS)
11186 {
11187 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
11188 "assignment at %L - check that there is a matching specific "
11189 "subroutine for '=' operator", &lhs->where);
Janus Weil0ae278e2009-10-16 23:10:43 +020011190 return false;
11191 }
11192
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020011193 bool lhs_coindexed = gfc_is_coindexed (lhs);
11194
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011195 /* F2008, Section 7.2.1.2. */
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020011196 if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011197 {
Benno Schulenberg6726b902014-02-07 17:52:59 +000011198 gfc_error ("Coindexed variable must not have an allocatable ultimate "
Tobias Burnusd3a9eea2010-04-09 07:54:29 +020011199 "component in assignment at %L", &lhs->where);
11200 return false;
11201 }
11202
Paul Thomas22c23882014-10-18 14:35:51 +000011203 /* Assign the 'data' of a class object to a derived type. */
11204 if (lhs->ts.type == BT_DERIVED
Paul Thomas5233d452017-11-05 14:32:05 +000011205 && rhs->ts.type == BT_CLASS
11206 && rhs->expr_type != EXPR_ARRAY)
Paul Thomas22c23882014-10-18 14:35:51 +000011207 gfc_add_data_component (rhs);
11208
Paul Thomas75382a92018-06-21 17:34:31 +000011209 /* Make sure there is a vtable and, in particular, a _copy for the
11210 rhs type. */
Paul Thomasce8dcc92020-12-18 14:00:11 +000011211 if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
Paul Thomas75382a92018-06-21 17:34:31 +000011212 gfc_find_vtab (&rhs->ts);
11213
Andre Vehreschild3c9f5092016-09-19 15:45:40 +020011214 bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
11215 && (lhs_coindexed
11216 || (code->expr2->expr_type == EXPR_FUNCTION
11217 && code->expr2->value.function.isym
11218 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
11219 && (code->expr1->rank == 0 || code->expr2->rank != 0)
11220 && !gfc_expr_attr (rhs).allocatable
11221 && !gfc_has_vector_subscript (rhs)));
11222
11223 gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
11224
Tobias Burnusb5116262014-06-17 22:54:14 +020011225 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
11226 Additionally, insert this code when the RHS is a CAF as we then use the
11227 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
Tobias Burnus5c750882014-06-25 22:31:32 +020011228 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
11229 noncoindexed array and the RHS is a coindexed scalar, use the normal code
11230 path. */
Andre Vehreschild3c9f5092016-09-19 15:45:40 +020011231 if (caf_convert_to_send)
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020011232 {
Tobias Burnusb5116262014-06-17 22:54:14 +020011233 if (code->expr2->expr_type == EXPR_FUNCTION
11234 && code->expr2->value.function.isym
11235 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
11236 remove_caf_get_intrinsic (code->expr2);
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020011237 code->op = EXEC_CALL;
11238 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
11239 code->resolved_sym = code->symtree->n.sym;
11240 code->resolved_sym->attr.flavor = FL_PROCEDURE;
11241 code->resolved_sym->attr.intrinsic = 1;
11242 code->resolved_sym->attr.subroutine = 1;
11243 code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11244 gfc_commit_symbol (code->resolved_sym);
11245 code->ext.actual = gfc_get_actual_arglist ();
11246 code->ext.actual->expr = lhs;
11247 code->ext.actual->next = gfc_get_actual_arglist ();
11248 code->ext.actual->next->expr = rhs;
11249 code->expr1 = NULL;
11250 code->expr2 = NULL;
11251 }
11252
Paul Thomasc5422462007-10-21 18:10:00 +000011253 return false;
11254}
11255
Daniel Kraft9abe5e52009-09-29 09:42:42 +020011256
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011257/* Add a component reference onto an expression. */
11258
11259static void
11260add_comp_ref (gfc_expr *e, gfc_component *c)
11261{
11262 gfc_ref **ref;
11263 ref = &(e->ref);
11264 while (*ref)
11265 ref = &((*ref)->next);
11266 *ref = gfc_get_ref ();
11267 (*ref)->type = REF_COMPONENT;
11268 (*ref)->u.c.sym = e->ts.u.derived;
11269 (*ref)->u.c.component = c;
11270 e->ts = c->ts;
11271
11272 /* Add a full array ref, as necessary. */
11273 if (c->as)
11274 {
11275 gfc_add_full_array_ref (e, c->as);
11276 e->rank = c->as->rank;
11277 }
11278}
11279
11280
11281/* Build an assignment. Keep the argument 'op' for future use, so that
11282 pointer assignments can be made. */
11283
11284static gfc_code *
11285build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
11286 gfc_component *comp1, gfc_component *comp2, locus loc)
11287{
11288 gfc_code *this_code;
11289
Janus Weil11e52742013-08-09 21:26:07 +020011290 this_code = gfc_get_code (op);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011291 this_code->next = NULL;
11292 this_code->expr1 = gfc_copy_expr (expr1);
11293 this_code->expr2 = gfc_copy_expr (expr2);
11294 this_code->loc = loc;
11295 if (comp1 && comp2)
11296 {
11297 add_comp_ref (this_code->expr1, comp1);
11298 add_comp_ref (this_code->expr2, comp2);
11299 }
11300
11301 return this_code;
11302}
11303
11304
11305/* Makes a temporary variable expression based on the characteristics of
11306 a given variable expression. */
11307
11308static gfc_expr*
11309get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
11310{
11311 static int serial = 0;
11312 char name[GFC_MAX_SYMBOL_LEN];
11313 gfc_symtree *tmp;
11314 gfc_array_spec *as;
11315 gfc_array_ref *aref;
11316 gfc_ref *ref;
11317
Tobias Burnusbbf38bc2013-05-22 21:24:29 +020011318 sprintf (name, GFC_PREFIX("DA%d"), serial++);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011319 gfc_get_sym_tree (name, ns, &tmp, false);
11320 gfc_add_type (tmp->n.sym, &e->ts, NULL);
11321
Paul Thomas18246c42018-12-23 17:35:13 +000011322 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
11323 tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
11324 NULL,
11325 e->value.character.length);
11326
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011327 as = NULL;
11328 ref = NULL;
11329 aref = NULL;
11330
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011331 /* Obtain the arrayspec for the temporary. */
Paul Thomas79124112015-09-28 21:18:38 +000011332 if (e->rank && e->expr_type != EXPR_ARRAY
11333 && e->expr_type != EXPR_FUNCTION
11334 && e->expr_type != EXPR_OP)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011335 {
11336 aref = gfc_find_array_ref (e);
11337 if (e->expr_type == EXPR_VARIABLE
11338 && e->symtree->n.sym->as == aref->as)
11339 as = aref->as;
11340 else
11341 {
11342 for (ref = e->ref; ref; ref = ref->next)
11343 if (ref->type == REF_COMPONENT
11344 && ref->u.c.component->as == aref->as)
11345 {
11346 as = aref->as;
11347 break;
11348 }
11349 }
11350 }
11351
11352 /* Add the attributes and the arrayspec to the temporary. */
11353 tmp->n.sym->attr = gfc_expr_attr (e);
Tobias Burnus9d827442013-06-14 13:24:27 +020011354 tmp->n.sym->attr.function = 0;
Tobias Burnus2b0df0a2020-09-07 12:29:05 +020011355 tmp->n.sym->attr.proc_pointer = 0;
Tobias Burnus9d827442013-06-14 13:24:27 +020011356 tmp->n.sym->attr.result = 0;
11357 tmp->n.sym->attr.flavor = FL_VARIABLE;
Paul Thomas9caa7e02018-05-10 10:48:50 +000011358 tmp->n.sym->attr.dummy = 0;
Tobias Burnus2b0df0a2020-09-07 12:29:05 +020011359 tmp->n.sym->attr.use_assoc = 0;
Paul Thomas9caa7e02018-05-10 10:48:50 +000011360 tmp->n.sym->attr.intent = INTENT_UNKNOWN;
Tobias Burnus9d827442013-06-14 13:24:27 +020011361
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011362 if (as)
11363 {
11364 tmp->n.sym->as = gfc_copy_array_spec (as);
11365 if (!ref)
11366 ref = e->ref;
11367 if (as->type == AS_DEFERRED)
11368 tmp->n.sym->attr.allocatable = 1;
11369 }
Paul Thomas79124112015-09-28 21:18:38 +000011370 else if (e->rank && (e->expr_type == EXPR_ARRAY
11371 || e->expr_type == EXPR_FUNCTION
11372 || e->expr_type == EXPR_OP))
11373 {
11374 tmp->n.sym->as = gfc_get_array_spec ();
11375 tmp->n.sym->as->type = AS_DEFERRED;
11376 tmp->n.sym->as->rank = e->rank;
11377 tmp->n.sym->attr.allocatable = 1;
11378 tmp->n.sym->attr.dimension = 1;
11379 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011380 else
11381 tmp->n.sym->attr.dimension = 0;
11382
11383 gfc_set_sym_referenced (tmp->n.sym);
Tobias Burnus28a595f2013-05-22 14:43:55 +020011384 gfc_commit_symbol (tmp->n.sym);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011385 e = gfc_lval_expr_from_sym (tmp->n.sym);
11386
11387 /* Should the lhs be a section, use its array ref for the
11388 temporary expression. */
11389 if (aref && aref->type != AR_FULL)
11390 {
11391 gfc_free_ref_list (e->ref);
11392 e->ref = gfc_copy_ref (ref);
11393 }
11394 return e;
11395}
11396
11397
11398/* Add one line of code to the code chain, making sure that 'head' and
11399 'tail' are appropriately updated. */
11400
11401static void
11402add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
11403{
11404 gcc_assert (this_code);
11405 if (*head == NULL)
11406 *head = *tail = *this_code;
11407 else
11408 *tail = gfc_append_code (*tail, *this_code);
11409 *this_code = NULL;
11410}
11411
11412
11413/* Counts the potential number of part array references that would
11414 result from resolution of typebound defined assignments. */
11415
11416static int
11417nonscalar_typebound_assign (gfc_symbol *derived, int depth)
11418{
11419 gfc_component *c;
11420 int c_depth = 0, t_depth;
11421
11422 for (c= derived->components; c; c = c->next)
11423 {
Fritz Reesef6288c22016-05-07 23:16:23 +000011424 if ((!gfc_bt_struct (c->ts.type)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011425 || c->attr.pointer
11426 || c->attr.allocatable
11427 || c->attr.proc_pointer_comp
11428 || c->attr.class_pointer
11429 || c->attr.proc_pointer)
11430 && !c->attr.defined_assign_comp)
11431 continue;
11432
11433 if (c->as && c_depth == 0)
11434 c_depth = 1;
11435
11436 if (c->ts.u.derived->attr.defined_assign_comp)
11437 t_depth = nonscalar_typebound_assign (c->ts.u.derived,
11438 c->as ? 1 : 0);
11439 else
11440 t_depth = 0;
11441
11442 c_depth = t_depth > c_depth ? t_depth : c_depth;
11443 }
11444 return depth + c_depth;
11445}
11446
11447
11448/* Implement 7.2.1.3 of the F08 standard:
11449 "An intrinsic assignment where the variable is of derived type is
11450 performed as if each component of the variable were assigned from the
11451 corresponding component of expr using pointer assignment (7.2.2) for
Steven G. Kargl6ff560c2015-09-21 21:40:26 +000011452 each pointer component, defined assignment for each nonpointer
11453 nonallocatable component of a type that has a type-bound defined
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011454 assignment consistent with the component, intrinsic assignment for
11455 each other nonpointer nonallocatable component, ..."
11456
11457 The pointer assignments are taken care of by the intrinsic
11458 assignment of the structure itself. This function recursively adds
11459 defined assignments where required. The recursion is accomplished
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020011460 by calling gfc_resolve_code.
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011461
11462 When the lhs in a defined assignment has intent INOUT, we need a
11463 temporary for the lhs. In pseudo-code:
11464
11465 ! Only call function lhs once.
11466 if (lhs is not a constant or an variable)
11467 temp_x = expr2
11468 expr2 => temp_x
11469 ! Do the intrinsic assignment
11470 expr1 = expr2
11471 ! Now do the defined assignments
11472 do over components with typebound defined assignment [%cmp]
11473 #if one component's assignment procedure is INOUT
11474 t1 = expr1
11475 #if expr2 non-variable
11476 temp_x = expr2
11477 expr2 => temp_x
11478 # endif
11479 expr1 = expr2
11480 # for each cmp
11481 t1%cmp {defined=} expr2%cmp
11482 expr1%cmp = t1%cmp
11483 #else
11484 expr1 = expr2
11485
11486 # for each cmp
11487 expr1%cmp {defined=} expr2%cmp
11488 #endif
11489 */
11490
11491/* The temporary assignments have to be put on top of the additional
11492 code to avoid the result being changed by the intrinsic assignment.
11493 */
11494static int component_assignment_level = 0;
11495static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
11496
11497static void
11498generate_component_assignments (gfc_code **code, gfc_namespace *ns)
11499{
11500 gfc_component *comp1, *comp2;
11501 gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
11502 gfc_expr *t1;
11503 int error_count, depth;
11504
11505 gfc_get_errors (NULL, &error_count);
11506
11507 /* Filter out continuing processing after an error. */
11508 if (error_count
11509 || (*code)->expr1->ts.type != BT_DERIVED
11510 || (*code)->expr2->ts.type != BT_DERIVED)
11511 return;
11512
11513 /* TODO: Handle more than one part array reference in assignments. */
11514 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
11515 (*code)->expr1->rank ? 1 : 0);
11516 if (depth > 1)
11517 {
Joseph Myersdb30e212015-02-01 00:29:54 +000011518 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011519 "done because multiple part array references would "
11520 "occur in intermediate expressions.", &(*code)->loc);
11521 return;
11522 }
11523
11524 component_assignment_level++;
11525
11526 /* Create a temporary so that functions get called only once. */
11527 if ((*code)->expr2->expr_type != EXPR_VARIABLE
11528 && (*code)->expr2->expr_type != EXPR_CONSTANT)
11529 {
11530 gfc_expr *tmp_expr;
11531
11532 /* Assign the rhs to the temporary. */
11533 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
11534 this_code = build_assignment (EXEC_ASSIGN,
11535 tmp_expr, (*code)->expr2,
11536 NULL, NULL, (*code)->loc);
11537 /* Add the code and substitute the rhs expression. */
11538 add_code_to_chain (&this_code, &tmp_head, &tmp_tail);
11539 gfc_free_expr ((*code)->expr2);
11540 (*code)->expr2 = tmp_expr;
11541 }
11542
11543 /* Do the intrinsic assignment. This is not needed if the lhs is one
11544 of the temporaries generated here, since the intrinsic assignment
11545 to the final result already does this. */
11546 if ((*code)->expr1->symtree->n.sym->name[2] != '@')
11547 {
11548 this_code = build_assignment (EXEC_ASSIGN,
11549 (*code)->expr1, (*code)->expr2,
11550 NULL, NULL, (*code)->loc);
11551 add_code_to_chain (&this_code, &head, &tail);
11552 }
11553
11554 comp1 = (*code)->expr1->ts.u.derived->components;
11555 comp2 = (*code)->expr2->ts.u.derived->components;
11556
11557 t1 = NULL;
11558 for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
11559 {
11560 bool inout = false;
11561
11562 /* The intrinsic assignment does the right thing for pointers
11563 of all kinds and allocatable components. */
Fritz Reesef6288c22016-05-07 23:16:23 +000011564 if (!gfc_bt_struct (comp1->ts.type)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011565 || comp1->attr.pointer
11566 || comp1->attr.allocatable
11567 || comp1->attr.proc_pointer_comp
11568 || comp1->attr.class_pointer
11569 || comp1->attr.proc_pointer)
11570 continue;
11571
Tobias Burnuse3ca3e72022-03-07 17:20:52 +010011572 /* Make an assignment for this component. */
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011573 this_code = build_assignment (EXEC_ASSIGN,
11574 (*code)->expr1, (*code)->expr2,
11575 comp1, comp2, (*code)->loc);
11576
11577 /* Convert the assignment if there is a defined assignment for
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020011578 this type. Otherwise, using the call from gfc_resolve_code,
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011579 recurse into its components. */
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020011580 gfc_resolve_code (this_code, ns);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011581
11582 if (this_code->op == EXEC_ASSIGN_CALL)
11583 {
Janus Weil4cbc9032013-01-29 22:40:51 +010011584 gfc_formal_arglist *dummy_args;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011585 gfc_symbol *rsym;
11586 /* Check that there is a typebound defined assignment. If not,
11587 then this must be a module defined assignment. We cannot
11588 use the defined_assign_comp attribute here because it must
11589 be this derived type that has the defined assignment and not
11590 a parent type. */
11591 if (!(comp1->ts.u.derived->f2k_derived
11592 && comp1->ts.u.derived->f2k_derived
11593 ->tb_op[INTRINSIC_ASSIGN]))
11594 {
11595 gfc_free_statements (this_code);
11596 this_code = NULL;
11597 continue;
11598 }
11599
11600 /* If the first argument of the subroutine has intent INOUT
11601 a temporary must be generated and used instead. */
11602 rsym = this_code->resolved_sym;
Janus Weil4cbc9032013-01-29 22:40:51 +010011603 dummy_args = gfc_sym_get_dummy_args (rsym);
11604 if (dummy_args
11605 && dummy_args->sym->attr.intent == INTENT_INOUT)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011606 {
11607 gfc_code *temp_code;
11608 inout = true;
11609
11610 /* Build the temporary required for the assignment and put
11611 it at the head of the generated code. */
11612 if (!t1)
11613 {
11614 t1 = get_temp_from_expr ((*code)->expr1, ns);
11615 temp_code = build_assignment (EXEC_ASSIGN,
11616 t1, (*code)->expr1,
11617 NULL, NULL, (*code)->loc);
Tobias Burnus5ef70932013-09-15 12:54:10 +020011618
Tobias Burnusd14fc2c2013-09-16 08:42:02 +020011619 /* For allocatable LHS, check whether it is allocated. Note
11620 that allocatable components with defined assignment are
11621 not yet support. See PR 57696. */
11622 if ((*code)->expr1->symtree->n.sym->attr.allocatable)
Tobias Burnus5ef70932013-09-15 12:54:10 +020011623 {
11624 gfc_code *block;
Tobias Burnusd14fc2c2013-09-16 08:42:02 +020011625 gfc_expr *e =
11626 gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
Tobias Burnus5ef70932013-09-15 12:54:10 +020011627 block = gfc_get_code (EXEC_IF);
11628 block->block = gfc_get_code (EXEC_IF);
11629 block->block->expr1
11630 = gfc_build_intrinsic_call (ns,
Tobias Burnusd14fc2c2013-09-16 08:42:02 +020011631 GFC_ISYM_ALLOCATED, "allocated",
11632 (*code)->loc, 1, e);
Tobias Burnus5ef70932013-09-15 12:54:10 +020011633 block->block->next = temp_code;
11634 temp_code = block;
11635 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011636 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
11637 }
11638
11639 /* Replace the first actual arg with the component of the
11640 temporary. */
11641 gfc_free_expr (this_code->ext.actual->expr);
11642 this_code->ext.actual->expr = gfc_copy_expr (t1);
11643 add_comp_ref (this_code->ext.actual->expr, comp1);
Tobias Burnus5ef70932013-09-15 12:54:10 +020011644
Tobias Burnusd14fc2c2013-09-16 08:42:02 +020011645 /* If the LHS variable is allocatable and wasn't allocated and
11646 the temporary is allocatable, pointer assign the address of
11647 the freshly allocated LHS to the temporary. */
11648 if ((*code)->expr1->symtree->n.sym->attr.allocatable
11649 && gfc_expr_attr ((*code)->expr1).allocatable)
Tobias Burnus5ef70932013-09-15 12:54:10 +020011650 {
11651 gfc_code *block;
Tobias Burnus71e482d2013-09-25 21:54:12 +020011652 gfc_expr *cond;
11653
11654 cond = gfc_get_expr ();
Tobias Burnus5ef70932013-09-15 12:54:10 +020011655 cond->ts.type = BT_LOGICAL;
11656 cond->ts.kind = gfc_default_logical_kind;
11657 cond->expr_type = EXPR_OP;
11658 cond->where = (*code)->loc;
11659 cond->value.op.op = INTRINSIC_NOT;
11660 cond->value.op.op1 = gfc_build_intrinsic_call (ns,
Tobias Burnusd14fc2c2013-09-16 08:42:02 +020011661 GFC_ISYM_ALLOCATED, "allocated",
11662 (*code)->loc, 1, gfc_copy_expr (t1));
Tobias Burnus5ef70932013-09-15 12:54:10 +020011663 block = gfc_get_code (EXEC_IF);
11664 block->block = gfc_get_code (EXEC_IF);
11665 block->block->expr1 = cond;
11666 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
11667 t1, (*code)->expr1,
11668 NULL, NULL, (*code)->loc);
11669 add_code_to_chain (&block, &head, &tail);
11670 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011671 }
Tobias Burnus71e482d2013-09-25 21:54:12 +020011672 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011673 else if (this_code->op == EXEC_ASSIGN && !this_code->next)
11674 {
11675 /* Don't add intrinsic assignments since they are already
11676 effected by the intrinsic assignment of the structure. */
11677 gfc_free_statements (this_code);
11678 this_code = NULL;
11679 continue;
11680 }
11681
11682 add_code_to_chain (&this_code, &head, &tail);
11683
11684 if (t1 && inout)
11685 {
11686 /* Transfer the value to the final result. */
11687 this_code = build_assignment (EXEC_ASSIGN,
11688 (*code)->expr1, t1,
11689 comp1, comp2, (*code)->loc);
11690 add_code_to_chain (&this_code, &head, &tail);
11691 }
11692 }
11693
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011694 /* Put the temporary assignments at the top of the generated code. */
11695 if (tmp_head && component_assignment_level == 1)
11696 {
11697 gfc_append_code (tmp_head, head);
11698 head = tmp_head;
11699 tmp_head = tmp_tail = NULL;
11700 }
11701
Tobias Burnus71e482d2013-09-25 21:54:12 +020011702 // If we did a pointer assignment - thus, we need to ensure that the LHS is
11703 // not accidentally deallocated. Hence, nullify t1.
11704 if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable
11705 && gfc_expr_attr ((*code)->expr1).allocatable)
11706 {
11707 gfc_code *block;
11708 gfc_expr *cond;
11709 gfc_expr *e;
11710
11711 e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
11712 cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated",
11713 (*code)->loc, 2, gfc_copy_expr (t1), e);
11714 block = gfc_get_code (EXEC_IF);
11715 block->block = gfc_get_code (EXEC_IF);
11716 block->block->expr1 = cond;
11717 block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
11718 t1, gfc_get_null_expr (&(*code)->loc),
11719 NULL, NULL, (*code)->loc);
11720 gfc_append_code (tail, block);
11721 tail = block;
11722 }
11723
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011724 /* Now attach the remaining code chain to the input code. Step on
11725 to the end of the new code since resolution is complete. */
11726 gcc_assert ((*code)->op == EXEC_ASSIGN);
11727 tail->next = (*code)->next;
11728 /* Overwrite 'code' because this would place the intrinsic assignment
11729 before the temporary for the lhs is created. */
11730 gfc_free_expr ((*code)->expr1);
11731 gfc_free_expr ((*code)->expr2);
11732 **code = *head;
Tobias Burnus71e482d2013-09-25 21:54:12 +020011733 if (head != tail)
11734 free (head);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000011735 *code = tail;
11736
11737 component_assignment_level--;
11738}
11739
11740
Paul Thomas79124112015-09-28 21:18:38 +000011741/* F2008: Pointer function assignments are of the form:
11742 ptr_fcn (args) = expr
11743 This function breaks these assignments into two statements:
11744 temporary_pointer => ptr_fcn(args)
11745 temporary_pointer = expr */
11746
11747static bool
11748resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
11749{
11750 gfc_expr *tmp_ptr_expr;
11751 gfc_code *this_code;
11752 gfc_component *comp;
11753 gfc_symbol *s;
11754
11755 if ((*code)->expr1->expr_type != EXPR_FUNCTION)
11756 return false;
11757
11758 /* Even if standard does not support this feature, continue to build
11759 the two statements to avoid upsetting frontend_passes.c. */
11760 gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
11761 "%L", &(*code)->loc);
11762
11763 comp = gfc_get_proc_ptr_comp ((*code)->expr1);
11764
11765 if (comp)
11766 s = comp->ts.interface;
11767 else
11768 s = (*code)->expr1->symtree->n.sym;
11769
11770 if (s == NULL || !s->result->attr.pointer)
11771 {
11772 gfc_error ("The function result on the lhs of the assignment at "
11773 "%L must have the pointer attribute.",
11774 &(*code)->expr1->where);
11775 (*code)->op = EXEC_NOP;
11776 return false;
11777 }
11778
Tobias Burnus2b0df0a2020-09-07 12:29:05 +020011779 tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
Paul Thomas79124112015-09-28 21:18:38 +000011780
11781 /* get_temp_from_expression is set up for ordinary assignments. To that
11782 end, where array bounds are not known, arrays are made allocatable.
11783 Change the temporary to a pointer here. */
11784 tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
11785 tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
11786 tmp_ptr_expr->where = (*code)->loc;
11787
11788 this_code = build_assignment (EXEC_ASSIGN,
11789 tmp_ptr_expr, (*code)->expr2,
11790 NULL, NULL, (*code)->loc);
11791 this_code->next = (*code)->next;
11792 (*code)->next = this_code;
11793 (*code)->op = EXEC_POINTER_ASSIGN;
11794 (*code)->expr2 = (*code)->expr1;
11795 (*code)->expr1 = tmp_ptr_expr;
11796
11797 return true;
11798}
11799
11800
Paul Thomas78ab5262015-11-15 14:07:52 +000011801/* Deferred character length assignments from an operator expression
11802 require a temporary because the character length of the lhs can
11803 change in the course of the assignment. */
11804
11805static bool
11806deferred_op_assign (gfc_code **code, gfc_namespace *ns)
11807{
11808 gfc_expr *tmp_expr;
11809 gfc_code *this_code;
11810
11811 if (!((*code)->expr1->ts.type == BT_CHARACTER
11812 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
Harald Anlauf7bd4deb2022-09-15 22:06:53 +020011813 && (*code)->expr2->ts.type == BT_CHARACTER
Paul Thomas78ab5262015-11-15 14:07:52 +000011814 && (*code)->expr2->expr_type == EXPR_OP))
11815 return false;
11816
11817 if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
11818 return false;
11819
Paul Thomas524cee42019-02-23 13:18:47 +000011820 if (gfc_expr_attr ((*code)->expr1).pointer)
11821 return false;
11822
Paul Thomas78ab5262015-11-15 14:07:52 +000011823 tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
11824 tmp_expr->where = (*code)->loc;
11825
11826 /* A new charlen is required to ensure that the variable string
11827 length is different to that of the original lhs. */
11828 tmp_expr->ts.u.cl = gfc_get_charlen();
11829 tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
11830 tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
11831 (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
11832
11833 tmp_expr->symtree->n.sym->ts.deferred = 1;
11834
11835 this_code = build_assignment (EXEC_ASSIGN,
11836 (*code)->expr1,
11837 gfc_copy_expr (tmp_expr),
11838 NULL, NULL, (*code)->loc);
11839
11840 (*code)->expr1 = tmp_expr;
11841
11842 this_code->next = (*code)->next;
11843 (*code)->next = this_code;
11844
11845 return true;
11846}
11847
11848
Harald Anlauf5edd0802022-05-09 22:14:21 +020011849static bool
11850check_team (gfc_expr *team, const char *intrinsic)
11851{
11852 if (team->rank != 0
11853 || team->ts.type != BT_DERIVED
11854 || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
11855 || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
11856 {
11857 gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
11858 "of type TEAM_TYPE", intrinsic, &team->where);
11859 return false;
11860 }
11861
11862 return true;
11863}
11864
11865
Diego Novillo6de9cd92004-05-13 02:41:07 -040011866/* Given a block of code, recursively resolve everything pointed to by this
11867 code block. */
11868
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020011869void
11870gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
Diego Novillo6de9cd92004-05-13 02:41:07 -040011871{
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011872 int omp_workshare_save;
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020011873 int forall_save, do_concurrent_save;
Diego Novillo6de9cd92004-05-13 02:41:07 -040011874 code_stack frame;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030011875 bool t;
Diego Novillo6de9cd92004-05-13 02:41:07 -040011876
11877 frame.prev = cs_base;
11878 frame.head = code;
11879 cs_base = &frame;
11880
Tobias Schlüterd80c6952009-03-29 19:15:48 +020011881 find_reachable_labels (code);
Tobias Schlüter0615f922007-04-13 15:48:08 +020011882
Diego Novillo6de9cd92004-05-13 02:41:07 -040011883 for (; code; code = code->next)
11884 {
11885 frame.current = code;
Paul Thomasd68bd5a2006-06-25 15:11:02 +000011886 forall_save = forall_flag;
Thomas Koenigce96d372013-09-02 22:09:07 +000011887 do_concurrent_save = gfc_do_concurrent_flag;
Diego Novillo6de9cd92004-05-13 02:41:07 -040011888
11889 if (code->op == EXEC_FORALL)
11890 {
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011891 forall_flag = 1;
11892 gfc_resolve_forall (code, ns, forall_save);
Paul Thomasd68bd5a2006-06-25 15:11:02 +000011893 forall_flag = 2;
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011894 }
11895 else if (code->block)
11896 {
11897 omp_workshare_save = -1;
11898 switch (code->op)
11899 {
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010011900 case EXEC_OACC_PARALLEL_LOOP:
11901 case EXEC_OACC_PARALLEL:
11902 case EXEC_OACC_KERNELS_LOOP:
11903 case EXEC_OACC_KERNELS:
Maciej W. Rozycki62aee282019-11-12 08:45:35 +000011904 case EXEC_OACC_SERIAL_LOOP:
11905 case EXEC_OACC_SERIAL:
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010011906 case EXEC_OACC_DATA:
11907 case EXEC_OACC_HOST_DATA:
11908 case EXEC_OACC_LOOP:
11909 gfc_resolve_oacc_blocks (code, ns);
11910 break;
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011911 case EXEC_OMP_PARALLEL_WORKSHARE:
11912 omp_workshare_save = omp_workshare_flag;
11913 omp_workshare_flag = 1;
11914 gfc_resolve_omp_parallel_blocks (code, ns);
11915 break;
Tobias Burnus61c2d472020-09-09 09:33:51 +020011916 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11917 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011918 case EXEC_OMP_PARALLEL:
11919 case EXEC_OMP_PARALLEL_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020011920 case EXEC_OMP_PARALLEL_DO_SIMD:
Tobias Burnus53d5b592021-08-16 09:26:26 +020011921 case EXEC_OMP_PARALLEL_MASKED:
11922 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11923 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
Tobias Burnus0e3702f2021-05-14 19:21:47 +020011924 case EXEC_OMP_PARALLEL_MASTER:
Tobias Burnusf6bf4362021-06-01 12:46:37 +020011925 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11926 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011927 case EXEC_OMP_PARALLEL_SECTIONS:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010011928 case EXEC_OMP_TARGET_PARALLEL:
11929 case EXEC_OMP_TARGET_PARALLEL_DO:
11930 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020011931 case EXEC_OMP_TARGET_TEAMS:
11932 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11933 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11934 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11935 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
Jakub Jelineka68ab352008-06-06 15:01:54 +020011936 case EXEC_OMP_TASK:
Jakub Jelinekcd30a0b2017-10-19 09:38:59 +020011937 case EXEC_OMP_TASKLOOP:
11938 case EXEC_OMP_TASKLOOP_SIMD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020011939 case EXEC_OMP_TEAMS:
11940 case EXEC_OMP_TEAMS_DISTRIBUTE:
11941 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11942 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11943 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011944 omp_workshare_save = omp_workshare_flag;
11945 omp_workshare_flag = 0;
11946 gfc_resolve_omp_parallel_blocks (code, ns);
11947 break;
Jakub Jelinekf014c652014-06-18 09:16:12 +020011948 case EXEC_OMP_DISTRIBUTE:
11949 case EXEC_OMP_DISTRIBUTE_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011950 case EXEC_OMP_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020011951 case EXEC_OMP_DO_SIMD:
11952 case EXEC_OMP_SIMD:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010011953 case EXEC_OMP_TARGET_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011954 gfc_resolve_omp_do_blocks (code, ns);
11955 break;
Janus Weild1039122010-03-03 16:12:40 +010011956 case EXEC_SELECT_TYPE:
Paul Thomasc4a678982020-12-27 14:59:38 +000011957 case EXEC_SELECT_RANK:
11958 /* Blocks are handled in resolve_select_type/rank because we
11959 have to transform the SELECT TYPE into ASSOCIATE first. */
Janus Weild1039122010-03-03 16:12:40 +010011960 break;
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020011961 case EXEC_DO_CONCURRENT:
Thomas Koenigce96d372013-09-02 22:09:07 +000011962 gfc_do_concurrent_flag = 1;
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020011963 gfc_resolve_blocks (code->block, ns);
Thomas Koenigce96d372013-09-02 22:09:07 +000011964 gfc_do_concurrent_flag = 2;
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020011965 break;
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011966 case EXEC_OMP_WORKSHARE:
11967 omp_workshare_save = omp_workshare_flag;
11968 omp_workshare_flag = 1;
Tobias Burnuseea58ad2012-05-30 08:26:09 +020011969 /* FALL THROUGH */
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010011970 default:
11971 gfc_resolve_blocks (code->block, ns);
11972 break;
11973 }
11974
11975 if (omp_workshare_save != -1)
11976 omp_workshare_flag = omp_workshare_save;
11977 }
Paul Thomas79124112015-09-28 21:18:38 +000011978start:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030011979 t = true;
Janus Weil713485c2009-05-06 23:17:16 +020011980 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
Steven G. Kargla5139272009-05-13 20:49:13 +000011981 t = gfc_resolve_expr (code->expr1);
Paul Thomasd68bd5a2006-06-25 15:11:02 +000011982 forall_flag = forall_save;
Thomas Koenigce96d372013-09-02 22:09:07 +000011983 gfc_do_concurrent_flag = do_concurrent_save;
Paul Thomasd68bd5a2006-06-25 15:11:02 +000011984
Janne Blomqvist524af0d2013-04-11 00:36:58 +030011985 if (!gfc_resolve_expr (code->expr2))
11986 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040011987
Janus Weil8460475b42009-10-23 13:01:38 +020011988 if (code->op == EXEC_ALLOCATE
Janne Blomqvist524af0d2013-04-11 00:36:58 +030011989 && !gfc_resolve_expr (code->expr3))
11990 t = false;
Janus Weil8460475b42009-10-23 13:01:38 +020011991
Diego Novillo6de9cd92004-05-13 02:41:07 -040011992 switch (code->op)
11993 {
11994 case EXEC_NOP:
Tobias Schlüterd80c6952009-03-29 19:15:48 +020011995 case EXEC_END_BLOCK:
Mikael Morindf1a69f2011-08-19 00:42:38 +020011996 case EXEC_END_NESTED_BLOCK:
Diego Novillo6de9cd92004-05-13 02:41:07 -040011997 case EXEC_CYCLE:
Diego Novillo6de9cd92004-05-13 02:41:07 -040011998 case EXEC_PAUSE:
Harald Anlauf916b8092022-02-23 23:08:29 +010011999 break;
12000
Diego Novillo6de9cd92004-05-13 02:41:07 -040012001 case EXEC_STOP:
Tobias Burnusd0a4a612010-04-06 18:26:02 +020012002 case EXEC_ERROR_STOP:
Harald Anlauf916b8092022-02-23 23:08:29 +010012003 if (code->expr2 != NULL
12004 && (code->expr2->ts.type != BT_LOGICAL
12005 || code->expr2->rank != 0))
12006 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
12007 &code->expr2->where);
12008 break;
12009
Diego Novillo6de9cd92004-05-13 02:41:07 -040012010 case EXEC_EXIT:
12011 case EXEC_CONTINUE:
12012 case EXEC_DT_END:
Daniel Kraft4a44a722009-08-27 13:42:56 +020012013 case EXEC_ASSIGN_CALL:
Tobias Burnusbc0229f2014-08-14 20:39:15 +020012014 break;
12015
Tobias Burnusd0a4a612010-04-06 18:26:02 +020012016 case EXEC_CRITICAL:
Tobias Burnusbc0229f2014-08-14 20:39:15 +020012017 resolve_critical (code);
Tobias Burnusd0a4a612010-04-06 18:26:02 +020012018 break;
12019
12020 case EXEC_SYNC_ALL:
12021 case EXEC_SYNC_IMAGES:
12022 case EXEC_SYNC_MEMORY:
12023 resolve_sync (code);
Paul Thomas0e9a4452006-06-07 07:20:39 +000012024 break;
12025
Tobias Burnus5493aa12011-06-08 08:28:41 +020012026 case EXEC_LOCK:
12027 case EXEC_UNLOCK:
Tobias Burnus5df445a2015-12-02 22:59:05 +010012028 case EXEC_EVENT_POST:
12029 case EXEC_EVENT_WAIT:
12030 resolve_lock_unlock_event (code);
Tobias Burnus5493aa12011-06-08 08:28:41 +020012031 break;
12032
Andre Vehreschildef78bc32017-03-05 12:35:47 +010012033 case EXEC_FAIL_IMAGE:
Harald Anlauf5edd0802022-05-09 22:14:21 +020012034 break;
12035
Damian Rousonf8862a12018-01-26 20:14:09 +000012036 case EXEC_FORM_TEAM:
Harald Anlauf5edd0802022-05-09 22:14:21 +020012037 if (code->expr1 != NULL
12038 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
12039 gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
12040 "a scalar INTEGER", &code->expr1->where);
12041 check_team (code->expr2, "FORM TEAM");
12042 break;
12043
Damian Rousonf8862a12018-01-26 20:14:09 +000012044 case EXEC_CHANGE_TEAM:
Harald Anlauf5edd0802022-05-09 22:14:21 +020012045 check_team (code->expr1, "CHANGE TEAM");
12046 break;
12047
Damian Rousonf8862a12018-01-26 20:14:09 +000012048 case EXEC_END_TEAM:
Harald Anlauf5edd0802022-05-09 22:14:21 +020012049 break;
12050
Damian Rousonf8862a12018-01-26 20:14:09 +000012051 case EXEC_SYNC_TEAM:
Harald Anlauf5edd0802022-05-09 22:14:21 +020012052 check_team (code->expr1, "SYNC TEAM");
Andre Vehreschildef78bc32017-03-05 12:35:47 +010012053 break;
12054
Paul Brook3d79abb2004-08-17 15:34:12 +000012055 case EXEC_ENTRY:
Paul Thomas0e9a4452006-06-07 07:20:39 +000012056 /* Keep track of which entry we are up to. */
12057 current_entry_id = code->ext.entry->id;
Diego Novillo6de9cd92004-05-13 02:41:07 -040012058 break;
12059
12060 case EXEC_WHERE:
12061 resolve_where (code, NULL);
12062 break;
12063
12064 case EXEC_GOTO:
Steven G. Kargla5139272009-05-13 20:49:13 +000012065 if (code->expr1 != NULL)
Feng Wangce2df7c2005-03-15 02:52:38 +000012066 {
Harald Anlauf824084e2020-07-06 18:52:39 +020012067 if (code->expr1->expr_type != EXPR_VARIABLE
12068 || code->expr1->ts.type != BT_INTEGER
12069 || (code->expr1->ref
12070 && code->expr1->ref->type == REF_ARRAY)
12071 || code->expr1->symtree == NULL
12072 || (code->expr1->symtree->n.sym
12073 && (code->expr1->symtree->n.sym->attr.flavor
12074 == FL_PARAMETER)))
12075 gfc_error ("ASSIGNED GOTO statement at %L requires a "
12076 "scalar INTEGER variable", &code->expr1->where);
12077 else if (code->expr1->symtree->n.sym
12078 && code->expr1->symtree->n.sym->attr.assign != 1)
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +000012079 gfc_error ("Variable %qs has not been assigned a target "
Steven G. Kargla5139272009-05-13 20:49:13 +000012080 "label at %L", code->expr1->symtree->n.sym->name,
12081 &code->expr1->where);
Feng Wangce2df7c2005-03-15 02:52:38 +000012082 }
12083 else
Steven G. Kargl79bd1942009-05-13 16:17:59 +000012084 resolve_branch (code->label1, code);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012085 break;
12086
12087 case EXEC_RETURN:
Steven G. Kargla5139272009-05-13 20:49:13 +000012088 if (code->expr1 != NULL
12089 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
Paul Thomasb6398822006-05-15 17:16:26 +000012090 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
Steven G. Kargla5139272009-05-13 20:49:13 +000012091 "INTEGER return specifier", &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012092 break;
12093
Paul Thomas6b591ec2006-10-19 04:51:14 +000012094 case EXEC_INIT_ASSIGN:
Tobias Burnus5c71a5e2009-05-13 16:52:54 +020012095 case EXEC_END_PROCEDURE:
Paul Thomas6b591ec2006-10-19 04:51:14 +000012096 break;
12097
Diego Novillo6de9cd92004-05-13 02:41:07 -040012098 case EXEC_ASSIGN:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012099 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -040012100 break;
12101
Tobias Burnusba9fa682020-12-17 10:39:09 +010012102 if (code->expr1->ts.type == BT_CLASS)
12103 gfc_find_vtab (&code->expr2->ts);
12104
Tobias Burnusb5116262014-06-17 22:54:14 +020012105 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
Joost VandeVondele1cc0e192014-09-20 11:48:00 +000012106 the LHS. */
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020012107 if (code->expr1->expr_type == EXPR_FUNCTION
12108 && code->expr1->value.function.isym
12109 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
12110 remove_caf_get_intrinsic (code->expr1);
12111
Paul Thomas79124112015-09-28 21:18:38 +000012112 /* If this is a pointer function in an lvalue variable context,
12113 the new code will have to be resolved afresh. This is also the
12114 case with an error, where the code is transformed into NOP to
12115 prevent ICEs downstream. */
12116 if (resolve_ptr_fcn_assign (&code, ns)
12117 || code->op == EXEC_NOP)
12118 goto start;
12119
Paul Thomas22c23882014-10-18 14:35:51 +000012120 if (!gfc_check_vardef_context (code->expr1, false, false, false,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012121 _("assignment")))
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012122 break;
12123
Paul Thomasc5422462007-10-21 18:10:00 +000012124 if (resolve_ordinary_assign (code, ns))
Janus Weil664e4112009-09-11 00:47:03 +020012125 {
Tobias Burnus582776e2021-05-17 13:20:27 +020012126 if (omp_workshare_flag)
12127 {
12128 gfc_error ("Expected intrinsic assignment in OMP WORKSHARE "
12129 "at %L", &code->loc);
12130 break;
12131 }
Janus Weil664e4112009-09-11 00:47:03 +020012132 if (code->op == EXEC_COMPCALL)
12133 goto compcall;
12134 else
12135 goto call;
12136 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012137
Paul Thomas78ab5262015-11-15 14:07:52 +000012138 /* Check for dependencies in deferred character length array
12139 assignments and generate a temporary, if necessary. */
12140 if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
12141 break;
12142
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012143 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
Tobias Burnus8a8d1a12014-05-08 19:00:07 +020012144 if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
Paul Thomas79124112015-09-28 21:18:38 +000012145 && code->expr1->ts.u.derived
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012146 && code->expr1->ts.u.derived->attr.defined_assign_comp)
12147 generate_component_assignments (&code, ns);
12148
Diego Novillo6de9cd92004-05-13 02:41:07 -040012149 break;
12150
12151 case EXEC_LABEL_ASSIGN:
Steven G. Kargl79bd1942009-05-13 16:17:59 +000012152 if (code->label1->defined == ST_LABEL_UNKNOWN)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012153 gfc_error ("Label %d referenced at %L is never defined",
Steven G. Kargl79bd1942009-05-13 16:17:59 +000012154 code->label1->value, &code->label1->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012155 if (t
Steven G. Kargla5139272009-05-13 20:49:13 +000012156 && (code->expr1->expr_type != EXPR_VARIABLE
12157 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER
12158 || code->expr1->symtree->n.sym->ts.kind
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012159 != gfc_default_integer_kind
Harald Anlauf1fa08dc2020-07-08 20:53:12 +020012160 || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
Steven G. Kargla5139272009-05-13 20:49:13 +000012161 || code->expr1->symtree->n.sym->as != NULL))
Tobias Schlüter40f21652004-12-08 13:27:54 +010012162 gfc_error ("ASSIGN statement at %L requires a scalar "
Steven G. Kargla5139272009-05-13 20:49:13 +000012163 "default INTEGER variable", &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012164 break;
12165
12166 case EXEC_POINTER_ASSIGN:
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012167 {
12168 gfc_expr* e;
Diego Novillo6de9cd92004-05-13 02:41:07 -040012169
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012170 if (!t)
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012171 break;
12172
12173 /* This is both a variable definition and pointer assignment
12174 context, so check both of them. For rank remapping, a final
12175 array ref may be present on the LHS and fool gfc_expr_attr
12176 used in gfc_check_vardef_context. Remove it. */
12177 e = remove_last_array_ref (code->expr1);
Tobias Burnus57bf28ea2012-10-28 17:57:12 +010012178 t = gfc_check_vardef_context (e, true, false, false,
Tobias Burnusfea54932011-06-20 23:12:39 +020012179 _("pointer assignment"));
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012180 if (t)
Tobias Burnus57bf28ea2012-10-28 17:57:12 +010012181 t = gfc_check_vardef_context (e, false, false, false,
Tobias Burnusfea54932011-06-20 23:12:39 +020012182 _("pointer assignment"));
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012183 gfc_free_expr (e);
Thomas Koenig83fad922018-11-18 09:16:19 +000012184
12185 t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
12186
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012187 if (!t)
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012188 break;
12189
Andre Vehreschild574284e2016-10-22 14:33:38 +020012190 /* Assigning a class object always is a regular assign. */
12191 if (code->expr2->ts.type == BT_CLASS
Paul Thomasda3723a2017-10-02 18:17:39 +000012192 && code->expr1->ts.type == BT_CLASS
José Rui Faustino de Sousa98c5b592021-04-16 16:17:21 +000012193 && CLASS_DATA (code->expr2)
Andre Vehreschild574284e2016-10-22 14:33:38 +020012194 && !CLASS_DATA (code->expr2)->attr.dimension
Andre Vehreschild574284e2016-10-22 14:33:38 +020012195 && !(gfc_expr_attr (code->expr1).proc_pointer
12196 && code->expr2->expr_type == EXPR_VARIABLE
12197 && code->expr2->symtree->n.sym->attr.flavor
12198 == FL_PROCEDURE))
12199 code->op = EXEC_ASSIGN;
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012200 break;
12201 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040012202
12203 case EXEC_ARITHMETIC_IF:
Steven G. Kargle2eb0802015-09-21 18:09:13 +000012204 {
12205 gfc_expr *e = code->expr1;
Diego Novillo6de9cd92004-05-13 02:41:07 -040012206
Steven G. Kargl2d2de602015-09-25 22:30:26 +000012207 gfc_resolve_expr (e);
12208 if (e->expr_type == EXPR_NULL)
12209 gfc_error ("Invalid NULL at %L", &e->where);
12210
Steven G. Kargle2eb0802015-09-21 18:09:13 +000012211 if (t && (e->rank > 0
12212 || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER)))
12213 gfc_error ("Arithmetic IF statement at %L requires a scalar "
Steven G. Kargl2d2de602015-09-25 22:30:26 +000012214 "REAL or INTEGER expression", &e->where);
Steven G. Kargle2eb0802015-09-21 18:09:13 +000012215
12216 resolve_branch (code->label1, code);
12217 resolve_branch (code->label2, code);
12218 resolve_branch (code->label3, code);
12219 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040012220 break;
12221
12222 case EXEC_IF:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012223 if (t && code->expr1 != NULL
Steven G. Kargla5139272009-05-13 20:49:13 +000012224 && (code->expr1->ts.type != BT_LOGICAL
12225 || code->expr1->rank != 0))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012226 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
Steven G. Kargla5139272009-05-13 20:49:13 +000012227 &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012228 break;
12229
12230 case EXEC_CALL:
12231 call:
12232 resolve_call (code);
12233 break;
12234
Daniel Kraft8e1f7522008-08-28 20:03:02 +020012235 case EXEC_COMPCALL:
Janus Weil664e4112009-09-11 00:47:03 +020012236 compcall:
Paul Thomas6a943ee2010-03-12 22:00:52 +000012237 resolve_typebound_subroutine (code);
Daniel Kraft8e1f7522008-08-28 20:03:02 +020012238 break;
12239
Janus Weil713485c2009-05-06 23:17:16 +020012240 case EXEC_CALL_PPC:
Daniel Kraft9abe5e52009-09-29 09:42:42 +020012241 resolve_ppc_call (code);
Janus Weil713485c2009-05-06 23:17:16 +020012242 break;
12243
Diego Novillo6de9cd92004-05-13 02:41:07 -040012244 case EXEC_SELECT:
12245 /* Select is complicated. Also, a SELECT construct could be
12246 a transformed computed GOTO. */
Janus Weilad3e2ad2013-01-23 22:38:40 +010012247 resolve_select (code, false);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012248 break;
12249
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020012250 case EXEC_SELECT_TYPE:
Daniel Kraft8c91ab32010-09-23 10:37:54 +020012251 resolve_select_type (code, ns);
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020012252 break;
12253
Paul Thomas70570ec2019-09-01 12:53:02 +000012254 case EXEC_SELECT_RANK:
12255 resolve_select_rank (code, ns);
12256 break;
12257
Daniel Kraft9abe5e52009-09-29 09:42:42 +020012258 case EXEC_BLOCK:
Daniel Kraft52bf62f2010-08-15 21:46:21 +020012259 resolve_block_construct (code);
Daniel Kraft9abe5e52009-09-29 09:42:42 +020012260 break;
12261
Diego Novillo6de9cd92004-05-13 02:41:07 -040012262 case EXEC_DO:
12263 if (code->ext.iterator != NULL)
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012264 {
12265 gfc_iterator *iter = code->ext.iterator;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012266 if (gfc_resolve_iterator (iter, true, false))
Jakub Jelinekcd30a0b2017-10-19 09:38:59 +020012267 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym,
12268 true);
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012269 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040012270 break;
12271
12272 case EXEC_DO_WHILE:
Steven G. Kargla5139272009-05-13 20:49:13 +000012273 if (code->expr1 == NULL)
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020012274 gfc_internal_error ("gfc_resolve_code(): No expression on "
12275 "DO WHILE");
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012276 if (t
Steven G. Kargla5139272009-05-13 20:49:13 +000012277 && (code->expr1->rank != 0
12278 || code->expr1->ts.type != BT_LOGICAL))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012279 gfc_error ("Exit condition of DO WHILE loop at %L must be "
Steven G. Kargla5139272009-05-13 20:49:13 +000012280 "a scalar LOGICAL expression", &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012281 break;
12282
12283 case EXEC_ALLOCATE:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012284 if (t)
Paul Thomasb9332b02008-02-03 11:29:27 +000012285 resolve_allocate_deallocate (code, "ALLOCATE");
Diego Novillo6de9cd92004-05-13 02:41:07 -040012286
12287 break;
12288
12289 case EXEC_DEALLOCATE:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012290 if (t)
Paul Thomasb9332b02008-02-03 11:29:27 +000012291 resolve_allocate_deallocate (code, "DEALLOCATE");
Diego Novillo6de9cd92004-05-13 02:41:07 -040012292
12293 break;
12294
12295 case EXEC_OPEN:
Fritz Reese44facdb2020-04-09 16:55:44 -040012296 if (!gfc_resolve_open (code->ext.open, &code->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012297 break;
12298
12299 resolve_branch (code->ext.open->err, code);
12300 break;
12301
12302 case EXEC_CLOSE:
Fritz Reese44facdb2020-04-09 16:55:44 -040012303 if (!gfc_resolve_close (code->ext.close, &code->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012304 break;
12305
12306 resolve_branch (code->ext.close->err, code);
12307 break;
12308
12309 case EXEC_BACKSPACE:
12310 case EXEC_ENDFILE:
12311 case EXEC_REWIND:
Janne Blomqvist6403ec52005-08-08 01:56:19 +030012312 case EXEC_FLUSH:
Steven G. Kargl3d07fb22018-12-11 23:13:19 +000012313 if (!gfc_resolve_filepos (code->ext.filepos, &code->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012314 break;
12315
12316 resolve_branch (code->ext.filepos->err, code);
12317 break;
12318
12319 case EXEC_INQUIRE:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012320 if (!gfc_resolve_inquire (code->ext.inquire))
Janne Blomqvist8750f9c2004-06-22 03:43:55 +030012321 break;
12322
12323 resolve_branch (code->ext.inquire->err, code);
12324 break;
12325
12326 case EXEC_IOLENGTH:
Paul Brook6e45f572004-09-08 14:33:03 +000012327 gcc_assert (code->ext.inquire != NULL);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012328 if (!gfc_resolve_inquire (code->ext.inquire))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012329 break;
12330
12331 resolve_branch (code->ext.inquire->err, code);
12332 break;
12333
Jerry DeLisle6f0f0b22008-04-05 22:23:27 +000012334 case EXEC_WAIT:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012335 if (!gfc_resolve_wait (code->ext.wait))
Jerry DeLisle6f0f0b22008-04-05 22:23:27 +000012336 break;
12337
12338 resolve_branch (code->ext.wait->err, code);
12339 resolve_branch (code->ext.wait->end, code);
12340 resolve_branch (code->ext.wait->eor, code);
12341 break;
12342
Diego Novillo6de9cd92004-05-13 02:41:07 -040012343 case EXEC_READ:
12344 case EXEC_WRITE:
Fritz Reese44facdb2020-04-09 16:55:44 -040012345 if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
Diego Novillo6de9cd92004-05-13 02:41:07 -040012346 break;
12347
12348 resolve_branch (code->ext.dt->err, code);
12349 resolve_branch (code->ext.dt->end, code);
12350 resolve_branch (code->ext.dt->eor, code);
12351 break;
12352
Tobias Schlüter0e6928d2004-09-01 23:07:39 +020012353 case EXEC_TRANSFER:
12354 resolve_transfer (code);
12355 break;
12356
Tobias Burnus8c6a85e2011-09-08 08:38:13 +020012357 case EXEC_DO_CONCURRENT:
Diego Novillo6de9cd92004-05-13 02:41:07 -040012358 case EXEC_FORALL:
12359 resolve_forall_iterators (code->ext.forall_iterator);
12360
Tobias Burnusd5656542010-11-12 00:07:23 +010012361 if (code->expr1 != NULL
12362 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
12363 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
Steven G. Kargla5139272009-05-13 20:49:13 +000012364 "expression", &code->expr1->where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012365 break;
12366
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010012367 case EXEC_OACC_PARALLEL_LOOP:
12368 case EXEC_OACC_PARALLEL:
12369 case EXEC_OACC_KERNELS_LOOP:
12370 case EXEC_OACC_KERNELS:
Maciej W. Rozycki62aee282019-11-12 08:45:35 +000012371 case EXEC_OACC_SERIAL_LOOP:
12372 case EXEC_OACC_SERIAL:
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010012373 case EXEC_OACC_DATA:
12374 case EXEC_OACC_HOST_DATA:
12375 case EXEC_OACC_LOOP:
12376 case EXEC_OACC_UPDATE:
12377 case EXEC_OACC_WAIT:
12378 case EXEC_OACC_CACHE:
12379 case EXEC_OACC_ENTER_DATA:
12380 case EXEC_OACC_EXIT_DATA:
Thomas Schwinge4bf9e5a2015-11-03 12:28:22 +010012381 case EXEC_OACC_ATOMIC:
James Norrisdc7a8b42015-11-22 16:45:38 +000012382 case EXEC_OACC_DECLARE:
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010012383 gfc_resolve_oacc_directive (code, ns);
12384 break;
12385
Tobias Burnuse2a22842022-10-05 19:25:27 +020012386 case EXEC_OMP_ASSUME:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012387 case EXEC_OMP_ATOMIC:
12388 case EXEC_OMP_BARRIER:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020012389 case EXEC_OMP_CANCEL:
12390 case EXEC_OMP_CANCELLATION_POINT:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012391 case EXEC_OMP_CRITICAL:
12392 case EXEC_OMP_FLUSH:
Tobias Burnusa61c4962021-04-21 10:58:29 +020012393 case EXEC_OMP_DEPOBJ:
Jakub Jelinekf014c652014-06-18 09:16:12 +020012394 case EXEC_OMP_DISTRIBUTE:
12395 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12396 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12397 case EXEC_OMP_DISTRIBUTE_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012398 case EXEC_OMP_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020012399 case EXEC_OMP_DO_SIMD:
Tobias Burnus77167192021-08-20 12:12:51 +020012400 case EXEC_OMP_ERROR:
Tobias Burnus178191e2021-06-04 12:06:59 +020012401 case EXEC_OMP_LOOP:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012402 case EXEC_OMP_MASTER:
Tobias Burnusf6bf4362021-06-01 12:46:37 +020012403 case EXEC_OMP_MASTER_TASKLOOP:
12404 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
Tobias Burnus53d5b592021-08-16 09:26:26 +020012405 case EXEC_OMP_MASKED:
12406 case EXEC_OMP_MASKED_TASKLOOP:
12407 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012408 case EXEC_OMP_ORDERED:
Tobias Burnus005cff42020-12-08 16:49:46 +010012409 case EXEC_OMP_SCAN:
Tobias Burnusf8d535f2021-08-17 15:50:11 +020012410 case EXEC_OMP_SCOPE:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012411 case EXEC_OMP_SECTIONS:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020012412 case EXEC_OMP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012413 case EXEC_OMP_SINGLE:
Jakub Jelinekf014c652014-06-18 09:16:12 +020012414 case EXEC_OMP_TARGET:
12415 case EXEC_OMP_TARGET_DATA:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010012416 case EXEC_OMP_TARGET_ENTER_DATA:
12417 case EXEC_OMP_TARGET_EXIT_DATA:
12418 case EXEC_OMP_TARGET_PARALLEL:
12419 case EXEC_OMP_TARGET_PARALLEL_DO:
12420 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020012421 case EXEC_OMP_TARGET_PARALLEL_LOOP:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010012422 case EXEC_OMP_TARGET_SIMD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020012423 case EXEC_OMP_TARGET_TEAMS:
12424 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12425 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12426 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12427 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020012428 case EXEC_OMP_TARGET_TEAMS_LOOP:
Jakub Jelinekf014c652014-06-18 09:16:12 +020012429 case EXEC_OMP_TARGET_UPDATE:
12430 case EXEC_OMP_TASK:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020012431 case EXEC_OMP_TASKGROUP:
Jakub Jelinekb4c3a852016-11-10 12:38:05 +010012432 case EXEC_OMP_TASKLOOP:
12433 case EXEC_OMP_TASKLOOP_SIMD:
Jakub Jelineka68ab352008-06-06 15:01:54 +020012434 case EXEC_OMP_TASKWAIT:
Jakub Jelinek20906c62011-08-02 18:13:29 +020012435 case EXEC_OMP_TASKYIELD:
Jakub Jelinekf014c652014-06-18 09:16:12 +020012436 case EXEC_OMP_TEAMS:
12437 case EXEC_OMP_TEAMS_DISTRIBUTE:
12438 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12439 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12440 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020012441 case EXEC_OMP_TEAMS_LOOP:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012442 case EXEC_OMP_WORKSHARE:
12443 gfc_resolve_omp_directive (code, ns);
12444 break;
12445
12446 case EXEC_OMP_PARALLEL:
12447 case EXEC_OMP_PARALLEL_DO:
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020012448 case EXEC_OMP_PARALLEL_DO_SIMD:
Tobias Burnus178191e2021-06-04 12:06:59 +020012449 case EXEC_OMP_PARALLEL_LOOP:
Tobias Burnus53d5b592021-08-16 09:26:26 +020012450 case EXEC_OMP_PARALLEL_MASKED:
12451 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12452 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
Tobias Burnus0e3702f2021-05-14 19:21:47 +020012453 case EXEC_OMP_PARALLEL_MASTER:
Tobias Burnusf6bf4362021-06-01 12:46:37 +020012454 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12455 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010012456 case EXEC_OMP_PARALLEL_SECTIONS:
12457 case EXEC_OMP_PARALLEL_WORKSHARE:
12458 omp_workshare_save = omp_workshare_flag;
12459 omp_workshare_flag = 0;
12460 gfc_resolve_omp_directive (code, ns);
12461 omp_workshare_flag = omp_workshare_save;
12462 break;
12463
Diego Novillo6de9cd92004-05-13 02:41:07 -040012464 default:
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020012465 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
Diego Novillo6de9cd92004-05-13 02:41:07 -040012466 }
12467 }
12468
12469 cs_base = frame.prev;
12470}
12471
12472
12473/* Resolve initial values and make sure they are compatible with
12474 the variable. */
12475
12476static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012477resolve_values (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -040012478{
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012479 bool t;
Janus Weil80f95222010-08-19 00:32:22 +020012480
Tobias Burnus22c30bc2012-01-16 20:50:11 +010012481 if (sym->value == NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -040012482 return;
12483
Tobias Burnusece8b0f2021-10-06 08:47:40 +020012484 if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced)
Tobias Burnus0caf4002020-11-03 09:55:58 +010012485 gfc_warning (OPT_Wdeprecated_declarations,
12486 "Using parameter %qs declared at %L is deprecated",
12487 sym->name, &sym->declared_at);
12488
Janus Weil80f95222010-08-19 00:32:22 +020012489 if (sym->value->expr_type == EXPR_STRUCTURE)
12490 t= resolve_structure_cons (sym->value, 1);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012491 else
Janus Weil80f95222010-08-19 00:32:22 +020012492 t = gfc_resolve_expr (sym->value);
12493
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012494 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -040012495 return;
12496
Tobias Burnuse35e87d2013-01-07 19:30:11 +010012497 gfc_check_assign_symbol (sym, NULL, sym->value);
Diego Novillo6de9cd92004-05-13 02:41:07 -040012498}
12499
12500
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012501/* Verify any BIND(C) derived types in the namespace so we can report errors
12502 for them once, rather than for each variable declared of that type. */
12503
12504static void
12505resolve_bind_c_derived_types (gfc_symbol *derived_sym)
12506{
12507 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
12508 && derived_sym->attr.is_bind_c == 1)
12509 verify_bind_c_derived_type (derived_sym);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012510
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012511 return;
12512}
12513
12514
Paul Thomase73d3ca2016-08-31 05:36:22 +000012515/* Check the interfaces of DTIO procedures associated with derived
12516 type 'sym'. These procedures can either have typebound bindings or
12517 can appear in DTIO generic interfaces. */
12518
12519static void
12520gfc_verify_DTIO_procedures (gfc_symbol *sym)
12521{
12522 if (!sym || sym->attr.flavor != FL_DERIVED)
12523 return;
12524
12525 gfc_check_dtio_interfaces (sym);
12526
12527 return;
12528}
12529
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012530/* Verify that any binding labels used in a given namespace do not collide
Tobias Burnus77f86822013-05-20 22:08:05 +020012531 with the names or binding labels of any global symbols. Multiple INTERFACE
12532 for the same procedure are permitted. */
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012533
12534static void
12535gfc_verify_binding_labels (gfc_symbol *sym)
12536{
Tobias Burnus77f86822013-05-20 22:08:05 +020012537 gfc_gsymbol *gsym;
12538 const char *module;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012539
Tobias Burnus77f86822013-05-20 22:08:05 +020012540 if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c
12541 || sym->attr.flavor == FL_DERIVED || !sym->binding_label)
12542 return;
12543
Dominique d'Humieres98452462017-12-10 20:11:18 +010012544 gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);
Tobias Burnus77f86822013-05-20 22:08:05 +020012545
12546 if (sym->module)
12547 module = sym->module;
12548 else if (sym->ns && sym->ns->proc_name
12549 && sym->ns->proc_name->attr.flavor == FL_MODULE)
12550 module = sym->ns->proc_name->name;
12551 else if (sym->ns && sym->ns->parent
12552 && sym->ns && sym->ns->parent->proc_name
12553 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
12554 module = sym->ns->parent->proc_name->name;
12555 else
12556 module = NULL;
12557
12558 if (!gsym
12559 || (!gsym->defined
12560 && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012561 {
Tobias Burnus77f86822013-05-20 22:08:05 +020012562 if (!gsym)
Thomas Koenig55b9c612019-03-13 07:21:33 +000012563 gsym = gfc_get_gsymbol (sym->binding_label, true);
Tobias Burnus77f86822013-05-20 22:08:05 +020012564 gsym->where = sym->declared_at;
12565 gsym->sym_name = sym->name;
12566 gsym->binding_label = sym->binding_label;
Tobias Burnus77f86822013-05-20 22:08:05 +020012567 gsym->ns = sym->ns;
12568 gsym->mod_name = module;
12569 if (sym->attr.function)
12570 gsym->type = GSYM_FUNCTION;
12571 else if (sym->attr.subroutine)
12572 gsym->type = GSYM_SUBROUTINE;
12573 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
12574 gsym->defined = sym->attr.if_source != IFSRC_IFBODY;
12575 return;
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012576 }
Tobias Burnus77f86822013-05-20 22:08:05 +020012577
12578 if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
12579 {
Dominique d'Humieres98452462017-12-10 20:11:18 +010012580 gfc_error ("Variable %qs with binding label %qs at %L uses the same global "
Tobias Burnus77f86822013-05-20 22:08:05 +020012581 "identifier as entity at %L", sym->name,
12582 sym->binding_label, &sym->declared_at, &gsym->where);
12583 /* Clear the binding label to prevent checking multiple times. */
12584 sym->binding_label = NULL;
Steven G. Kargl26420122019-01-13 04:02:46 +000012585 return;
Tobias Burnus77f86822013-05-20 22:08:05 +020012586 }
Steven G. Kargl26420122019-01-13 04:02:46 +000012587
12588 if (sym->attr.flavor == FL_VARIABLE && module
12589 && (strcmp (module, gsym->mod_name) != 0
12590 || strcmp (sym->name, gsym->sym_name) != 0))
Tobias Burnus77f86822013-05-20 22:08:05 +020012591 {
12592 /* This can only happen if the variable is defined in a module - if it
12593 isn't the same module, reject it. */
Dominique d'Humieres98452462017-12-10 20:11:18 +010012594 gfc_error ("Variable %qs from module %qs with binding label %qs at %L "
12595 "uses the same global identifier as entity at %L from module %qs",
Tobias Burnus77f86822013-05-20 22:08:05 +020012596 sym->name, module, sym->binding_label,
12597 &sym->declared_at, &gsym->where, gsym->mod_name);
12598 sym->binding_label = NULL;
Steven G. Kargl26420122019-01-13 04:02:46 +000012599 return;
Tobias Burnus77f86822013-05-20 22:08:05 +020012600 }
Steven G. Kargl26420122019-01-13 04:02:46 +000012601
12602 if ((sym->attr.function || sym->attr.subroutine)
12603 && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION)
12604 || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
12605 && (sym != gsym->ns->proc_name && sym->attr.entry == 0)
12606 && (module != gsym->mod_name
12607 || strcmp (gsym->sym_name, sym->name) != 0
12608 || (module && strcmp (module, gsym->mod_name) != 0)))
Tobias Burnus77f86822013-05-20 22:08:05 +020012609 {
Janus Weil76d3d472014-01-08 16:25:22 +010012610 /* Print an error if the procedure is defined multiple times; we have to
Tobias Burnus77f86822013-05-20 22:08:05 +020012611 exclude references to the same procedure via module association or
12612 multiple checks for the same procedure. */
Dominique d'Humieres98452462017-12-10 20:11:18 +010012613 gfc_error ("Procedure %qs with binding label %qs at %L uses the same "
Tobias Burnus77f86822013-05-20 22:08:05 +020012614 "global identifier as entity at %L", sym->name,
12615 sym->binding_label, &sym->declared_at, &gsym->where);
12616 sym->binding_label = NULL;
12617 }
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000012618}
12619
12620
Paul Thomas2ed8d222006-02-13 21:22:55 +000012621/* Resolve an index expression. */
12622
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012623static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012624resolve_index_expr (gfc_expr *e)
Paul Thomas2ed8d222006-02-13 21:22:55 +000012625{
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012626 if (!gfc_resolve_expr (e))
12627 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012628
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012629 if (!gfc_simplify_expr (e, 0))
12630 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012631
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012632 if (!gfc_specification_expr (e))
12633 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012634
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012635 return true;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012636}
12637
Steven G. Kargle69afb22010-11-02 17:09:58 +000012638
Tobias Schlüter110eec22005-12-22 12:37:03 +010012639/* Resolve a charlen structure. */
12640
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012641static bool
Tobias Schlüter110eec22005-12-22 12:37:03 +010012642resolve_charlen (gfc_charlen *cl)
12643{
Janne Blomqvistf6222212018-01-05 21:01:12 +020012644 int k;
Tobias Burnusfd061182012-10-18 19:09:13 +020012645 bool saved_specification_expr;
Tobias Schlüter5cd09fa2007-04-12 20:48:06 +020012646
Tobias Schlüter110eec22005-12-22 12:37:03 +010012647 if (cl->resolved)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012648 return true;
Tobias Schlüter110eec22005-12-22 12:37:03 +010012649
12650 cl->resolved = 1;
Tobias Burnusfd061182012-10-18 19:09:13 +020012651 saved_specification_expr = specification_expr;
12652 specification_expr = true;
Paul Thomas0e9a4452006-06-07 07:20:39 +000012653
Harald Anlaufc1a2cf82021-01-14 19:17:05 +010012654 if (cl->length_from_typespec)
Paul Thomas0e9a4452006-06-07 07:20:39 +000012655 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012656 if (!gfc_resolve_expr (cl->length))
Tobias Burnusfd061182012-10-18 19:09:13 +020012657 {
12658 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012659 return false;
Tobias Burnusfd061182012-10-18 19:09:13 +020012660 }
Tobias Burnus239b48d2012-05-23 22:35:30 +020012661
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012662 if (!gfc_simplify_expr (cl->length, 0))
Tobias Burnusfd061182012-10-18 19:09:13 +020012663 {
12664 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012665 return false;
Tobias Burnusfd061182012-10-18 19:09:13 +020012666 }
Steven G. Kargl266404a2018-01-10 21:31:43 +000012667
12668 /* cl->length has been resolved. It should have an integer type. */
Paul Thomasc6b0e332021-01-25 10:27:51 +000012669 if (cl->length
12670 && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0))
Steven G. Kargl266404a2018-01-10 21:31:43 +000012671 {
12672 gfc_error ("Scalar INTEGER expression expected at %L",
12673 &cl->length->where);
12674 return false;
12675 }
Tobias Burnus239b48d2012-05-23 22:35:30 +020012676 }
12677 else
12678 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012679 if (!resolve_index_expr (cl->length))
Tobias Burnus239b48d2012-05-23 22:35:30 +020012680 {
Tobias Burnusfd061182012-10-18 19:09:13 +020012681 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012682 return false;
Tobias Burnus239b48d2012-05-23 22:35:30 +020012683 }
Paul Thomas0e9a4452006-06-07 07:20:39 +000012684 }
Tobias Schlüter110eec22005-12-22 12:37:03 +010012685
Steven G. Kargl98a819e2015-10-17 16:50:47 +000012686 /* F2008, 4.4.3.2: If the character length parameter value evaluates to
12687 a negative value, the length of character entities declared is zero. */
Janne Blomqvistf6222212018-01-05 21:01:12 +020012688 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
12689 && mpz_sgn (cl->length->value.integer) < 0)
Steven G. Kargl98a819e2015-10-17 16:50:47 +000012690 gfc_replace_expr (cl->length,
Janne Blomqvistf6222212018-01-05 21:01:12 +020012691 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0));
Tobias Schlüter5cd09fa2007-04-12 20:48:06 +020012692
Francois-Xavier Coudertb0c06812009-05-16 16:53:02 +000012693 /* Check that the character length is not too large. */
12694 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
12695 if (cl->length && cl->length->expr_type == EXPR_CONSTANT
12696 && cl->length->ts.type == BT_INTEGER
12697 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
12698 {
12699 gfc_error ("String length at %L is too large", &cl->length->where);
Tobias Burnusfd061182012-10-18 19:09:13 +020012700 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012701 return false;
Francois-Xavier Coudertb0c06812009-05-16 16:53:02 +000012702 }
12703
Tobias Burnusfd061182012-10-18 19:09:13 +020012704 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012705 return true;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012706}
12707
12708
Steven G. Kargl66e4ab32007-06-07 18:10:31 +000012709/* Test for non-constant shape arrays. */
Paul Thomas3e1cf502006-02-19 15:24:26 +000012710
12711static bool
12712is_non_constant_shape_array (gfc_symbol *sym)
12713{
12714 gfc_expr *e;
12715 int i;
Paul Thomas0e9a4452006-06-07 07:20:39 +000012716 bool not_constant;
Paul Thomas3e1cf502006-02-19 15:24:26 +000012717
Paul Thomas0e9a4452006-06-07 07:20:39 +000012718 not_constant = false;
Paul Thomas3e1cf502006-02-19 15:24:26 +000012719 if (sym->as != NULL)
12720 {
12721 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
12722 has not been simplified; parameter array references. Do the
12723 simplification now. */
Tobias Burnusbe59db22010-04-06 20:16:13 +020012724 for (i = 0; i < sym->as->rank + sym->as->corank; i++)
Paul Thomas3e1cf502006-02-19 15:24:26 +000012725 {
Martin Liskad1365952019-10-24 10:49:02 +020012726 if (i == GFC_MAX_DIMENSIONS)
12727 break;
12728
Paul Thomas3e1cf502006-02-19 15:24:26 +000012729 e = sym->as->lower[i];
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012730 if (e && (!resolve_index_expr(e)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012731 || !gfc_is_constant_expr (e)))
Paul Thomas0e9a4452006-06-07 07:20:39 +000012732 not_constant = true;
Paul Thomas3e1cf502006-02-19 15:24:26 +000012733 e = sym->as->upper[i];
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012734 if (e && (!resolve_index_expr(e)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012735 || !gfc_is_constant_expr (e)))
Paul Thomas0e9a4452006-06-07 07:20:39 +000012736 not_constant = true;
Paul Thomas3e1cf502006-02-19 15:24:26 +000012737 }
12738 }
Paul Thomas0e9a4452006-06-07 07:20:39 +000012739 return not_constant;
Paul Thomas3e1cf502006-02-19 15:24:26 +000012740}
12741
Asher Langton51b09ce2007-09-21 02:34:14 +000012742/* Given a symbol and an initialization expression, add code to initialize
12743 the symbol to the function entry. */
Paul Thomas6b591ec2006-10-19 04:51:14 +000012744static void
Asher Langton51b09ce2007-09-21 02:34:14 +000012745build_init_assign (gfc_symbol *sym, gfc_expr *init)
Paul Thomas6b591ec2006-10-19 04:51:14 +000012746{
12747 gfc_expr *lval;
Paul Thomas6b591ec2006-10-19 04:51:14 +000012748 gfc_code *init_st;
12749 gfc_namespace *ns = sym->ns;
12750
Paul Thomas6b591ec2006-10-19 04:51:14 +000012751 /* Search for the function namespace if this is a contained
12752 function without an explicit result. */
12753 if (sym->attr.function && sym == sym->result
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012754 && sym->name != sym->ns->proc_name->name)
Paul Thomas6b591ec2006-10-19 04:51:14 +000012755 {
12756 ns = ns->contained;
12757 for (;ns; ns = ns->sibling)
12758 if (strcmp (ns->proc_name->name, sym->name) == 0)
12759 break;
12760 }
12761
12762 if (ns == NULL)
12763 {
12764 gfc_free_expr (init);
12765 return;
12766 }
12767
12768 /* Build an l-value expression for the result. */
Paul Thomas08113c72007-07-24 19:15:27 +000012769 lval = gfc_lval_expr_from_sym (sym);
Paul Thomas6b591ec2006-10-19 04:51:14 +000012770
12771 /* Add the code at scope entry. */
Janus Weil11e52742013-08-09 21:26:07 +020012772 init_st = gfc_get_code (EXEC_INIT_ASSIGN);
Paul Thomas6b591ec2006-10-19 04:51:14 +000012773 init_st->next = ns->code;
12774 ns->code = init_st;
12775
12776 /* Assign the default initializer to the l-value. */
12777 init_st->loc = sym->declared_at;
Steven G. Kargla5139272009-05-13 20:49:13 +000012778 init_st->expr1 = lval;
Paul Thomas6b591ec2006-10-19 04:51:14 +000012779 init_st->expr2 = init;
12780}
12781
Fritz Reese7fc61622016-08-15 21:19:09 +000012782
12783/* Whether or not we can generate a default initializer for a symbol. */
12784
12785static bool
12786can_generate_init (gfc_symbol *sym)
12787{
12788 symbol_attribute *a;
12789 if (!sym)
12790 return false;
12791 a = &sym->attr;
12792
12793 /* These symbols should never have a default initialization. */
12794 return !(
12795 a->allocatable
12796 || a->external
12797 || a->pointer
12798 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
12799 && (CLASS_DATA (sym)->attr.class_pointer
12800 || CLASS_DATA (sym)->attr.proc_pointer))
12801 || a->in_equivalence
12802 || a->in_common
12803 || a->data
12804 || sym->module
12805 || a->cray_pointee
12806 || a->cray_pointer
12807 || sym->assoc
12808 || (!a->referenced && !a->result)
Tobias Burnus51d9ef72021-10-04 09:38:43 +020012809 || (a->dummy && (a->intent != INTENT_OUT
12810 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY))
Fritz Reese7fc61622016-08-15 21:19:09 +000012811 || (a->function && sym != sym->result)
12812 );
12813}
12814
12815
Asher Langton51b09ce2007-09-21 02:34:14 +000012816/* Assign the default initializer to a derived type variable or result. */
12817
12818static void
12819apply_default_init (gfc_symbol *sym)
12820{
12821 gfc_expr *init = NULL;
12822
12823 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
12824 return;
12825
Janus Weilbc21d312009-08-13 21:46:46 +020012826 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived)
Fritz Reese7fc61622016-08-15 21:19:09 +000012827 init = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
Asher Langton51b09ce2007-09-21 02:34:14 +000012828
Janus Weil50f30802010-09-01 22:50:46 +020012829 if (init == NULL && sym->ts.type != BT_CLASS)
Asher Langton51b09ce2007-09-21 02:34:14 +000012830 return;
12831
12832 build_init_assign (sym, init);
Tobias Burnus86e6a232010-09-02 12:11:39 +020012833 sym->attr.referenced = 1;
Asher Langton51b09ce2007-09-21 02:34:14 +000012834}
12835
Fritz Reese7fc61622016-08-15 21:19:09 +000012836
12837/* Build an initializer for a local. Returns null if the symbol should not have
12838 a default initialization. */
12839
Asher Langton51b09ce2007-09-21 02:34:14 +000012840static gfc_expr *
12841build_default_init_expr (gfc_symbol *sym)
12842{
Asher Langton51b09ce2007-09-21 02:34:14 +000012843 /* These symbols should never have a default initialization. */
Toon Moenea3fd80ea2011-12-15 18:26:02 +000012844 if (sym->attr.allocatable
Asher Langton51b09ce2007-09-21 02:34:14 +000012845 || sym->attr.external
12846 || sym->attr.dummy
12847 || sym->attr.pointer
12848 || sym->attr.in_equivalence
12849 || sym->attr.in_common
12850 || sym->attr.data
12851 || sym->module
12852 || sym->attr.cray_pointee
Tobias Burnusa67cfde2012-06-04 23:01:02 +020012853 || sym->attr.cray_pointer
12854 || sym->assoc)
Asher Langton51b09ce2007-09-21 02:34:14 +000012855 return NULL;
12856
Fritz Reese7fc61622016-08-15 21:19:09 +000012857 /* Get the appropriate init expression. */
12858 return gfc_build_default_init_expr (&sym->ts, &sym->declared_at);
Asher Langton51b09ce2007-09-21 02:34:14 +000012859}
12860
12861/* Add an initialization expression to a local variable. */
12862static void
12863apply_default_init_local (gfc_symbol *sym)
12864{
12865 gfc_expr *init = NULL;
12866
12867 /* The symbol should be a variable or a function return value. */
12868 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
12869 || (sym->attr.function && sym->result != sym))
12870 return;
12871
12872 /* Try to build the initializer expression. If we can't initialize
12873 this symbol, then init will be NULL. */
12874 init = build_default_init_expr (sym);
12875 if (init == NULL)
12876 return;
12877
Tobias Burnus068ed5e2012-01-14 13:05:59 +010012878 /* For saved variables, we don't want to add an initializer at function
12879 entry, so we just add a static initializer. Note that automatic variables
Tobias Burnusfab99ea2013-02-15 09:50:37 +010012880 are stack allocated even with -fno-automatic; we have also to exclude
12881 result variable, which are also nonstatic. */
Fritz Reese34d567d2016-09-23 21:06:18 +000012882 if (!sym->attr.automatic
12883 && (sym->attr.save || sym->ns->save_all
12884 || (flag_max_stack_var_size == 0 && !sym->attr.result
12885 && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive)
12886 && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))))
Asher Langton51b09ce2007-09-21 02:34:14 +000012887 {
12888 /* Don't clobber an existing initializer! */
12889 gcc_assert (sym->value == NULL);
12890 sym->value = init;
12891 return;
12892 }
12893
12894 build_init_assign (sym, init);
12895}
Paul Thomas6b591ec2006-10-19 04:51:14 +000012896
Steven G. Kargle69afb22010-11-02 17:09:58 +000012897
Steven G. Kargl66e4ab32007-06-07 18:10:31 +000012898/* Resolution of common features of flavors variable and procedure. */
Paul Thomas2ed8d222006-02-13 21:22:55 +000012899
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012900static bool
Paul Thomas2ed8d222006-02-13 21:22:55 +000012901resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
12902{
Tobias Burnusfac665b2011-12-19 09:15:47 +010012903 gfc_array_spec *as;
12904
Harald Anlauf70c884a2020-07-10 21:35:35 +020012905 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
12906 && sym->ts.u.derived && CLASS_DATA (sym))
Tobias Burnusfac665b2011-12-19 09:15:47 +010012907 as = CLASS_DATA (sym)->as;
12908 else
12909 as = sym->as;
12910
Paul Thomas2ed8d222006-02-13 21:22:55 +000012911 /* Constraints on deferred shape variable. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010012912 if (as == NULL || as->type != AS_DEFERRED)
Paul Thomas2ed8d222006-02-13 21:22:55 +000012913 {
Tobias Burnusfac665b2011-12-19 09:15:47 +010012914 bool pointer, allocatable, dimension;
12915
Harald Anlauf70c884a2020-07-10 21:35:35 +020012916 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
12917 && sym->ts.u.derived && CLASS_DATA (sym))
Paul Thomas2ed8d222006-02-13 21:22:55 +000012918 {
Tobias Burnusfac665b2011-12-19 09:15:47 +010012919 pointer = CLASS_DATA (sym)->attr.class_pointer;
12920 allocatable = CLASS_DATA (sym)->attr.allocatable;
12921 dimension = CLASS_DATA (sym)->attr.dimension;
12922 }
12923 else
12924 {
Paul Thomas4cc70462012-12-21 14:29:34 +000012925 pointer = sym->attr.pointer && !sym->attr.select_type_temporary;
Tobias Burnusfac665b2011-12-19 09:15:47 +010012926 allocatable = sym->attr.allocatable;
12927 dimension = sym->attr.dimension;
12928 }
12929
12930 if (allocatable)
12931 {
Tobias Burnusc62c6622012-07-20 07:56:37 +020012932 if (dimension && as->type != AS_ASSUMED_RANK)
Janus Weil2fbd4112009-08-31 12:22:32 +020012933 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012934 gfc_error ("Allocatable array %qs at %L must have a deferred "
Tobias Burnusc62c6622012-07-20 07:56:37 +020012935 "shape or assumed rank", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012936 return false;
Janus Weil2fbd4112009-08-31 12:22:32 +020012937 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012938 else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012939 "%qs at %L may not be ALLOCATABLE",
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012940 sym->name, &sym->declared_at))
12941 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012942 }
12943
Tobias Burnusc62c6622012-07-20 07:56:37 +020012944 if (pointer && dimension && as->type != AS_ASSUMED_RANK)
Paul Thomas2ed8d222006-02-13 21:22:55 +000012945 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012946 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
Tobias Burnusc62c6622012-07-20 07:56:37 +020012947 "assumed rank", sym->name, &sym->declared_at);
Linus Koenigefbf7392020-04-13 16:30:44 +020012948 sym->error = 1;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012949 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012950 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000012951 }
12952 else
12953 {
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020012954 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
Tobias Burnus12578be2011-04-29 18:49:53 +020012955 && sym->ts.type != BT_CLASS && !sym->assoc)
Paul Thomas2ed8d222006-02-13 21:22:55 +000012956 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012957 gfc_error ("Array %qs at %L cannot have a deferred shape",
Paul Thomas2ed8d222006-02-13 21:22:55 +000012958 sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012959 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012960 }
12961 }
Janus Weil233961d2010-05-17 10:25:06 +020012962
12963 /* Constraints on polymorphic variables. */
12964 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
12965 {
12966 /* F03:C502. */
Janus Weild40477b2010-07-11 09:55:11 +020012967 if (sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +020012968 && sym->ts.u.derived
Paul Thomas8b704312012-12-20 00:15:00 +000012969 && !sym->attr.select_type_temporary
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012970 && !UNLIMITED_POLY (sym)
Harald Anlauf96e42442022-11-16 21:41:19 +010012971 && CLASS_DATA (sym)->ts.u.derived
Janus Weild40477b2010-07-11 09:55:11 +020012972 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
Janus Weil233961d2010-05-17 10:25:06 +020012973 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012974 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
Janus Weil7a08eda12010-05-30 23:56:11 +020012975 CLASS_DATA (sym)->ts.u.derived->name, sym->name,
12976 &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012977 return false;
Janus Weil233961d2010-05-17 10:25:06 +020012978 }
12979
12980 /* F03:C509. */
Daniel Kraft3e782382010-08-26 21:48:43 +020012981 /* Assume that use associated symbols were checked in the module ns.
12982 Class-variables that are associate-names are also something special
12983 and excepted from the test. */
12984 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
Janus Weil233961d2010-05-17 10:25:06 +020012985 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010012986 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
Janus Weil233961d2010-05-17 10:25:06 +020012987 "or pointer", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012988 return false;
Janus Weil233961d2010-05-17 10:25:06 +020012989 }
12990 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000012991
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012992 return true;
Paul Thomas2ed8d222006-02-13 21:22:55 +000012993}
12994
Steven G. Kargledf1eac2007-01-20 22:01:41 +000012995
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020012996/* Additional checks for symbols with flavor variable and derived
12997 type. To be called from resolve_fl_variable. */
12998
Janne Blomqvist524af0d2013-04-11 00:36:58 +030012999static bool
Tobias Schlüter9de88092007-10-08 22:54:47 +020013000resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013001{
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020013002 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013003
13004 /* Check to see if a derived type is blocked from being host
13005 associated by the presence of another class I symbol in the same
13006 namespace. 14.6.1.3 of the standard and the discussion on
13007 comp.lang.fortran. */
Harald Anlauf70c884a2020-07-10 21:35:35 +020013008 if (sym->ts.u.derived
13009 && sym->ns != sym->ts.u.derived->ns
Paul Thomas8532a012018-08-12 10:55:13 +000013010 && !sym->ts.u.derived->attr.use_assoc
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013011 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
13012 {
13013 gfc_symbol *s;
Janus Weilbc21d312009-08-13 21:46:46 +020013014 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
Tobias Burnusc3f34952011-11-16 22:37:43 +010013015 if (s && s->attr.generic)
13016 s = gfc_find_dt_in_generic (s);
Fritz Reesef6288c22016-05-07 23:16:23 +000013017 if (s && !gfc_fl_struct (s->attr.flavor))
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013018 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000013019 gfc_error ("The type %qs cannot be host associated at %L "
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013020 "because it is blocked by an incompatible object "
13021 "of the same name declared at %L",
Janus Weilbc21d312009-08-13 21:46:46 +020013022 sym->ts.u.derived->name, &sym->declared_at,
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013023 &s->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013024 return false;
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013025 }
13026 }
13027
13028 /* 4th constraint in section 11.3: "If an object of a type for which
13029 component-initialization is specified (R429) appears in the
13030 specification-part of a module and does not have the ALLOCATABLE
13031 or POINTER attribute, the object shall have the SAVE attribute."
13032
13033 The check for initializers is performed with
Daniel Franke16e520b2010-05-19 09:07:25 -040013034 gfc_has_default_initializer because gfc_default_initializer generates
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013035 a hidden default for allocatable components. */
Tobias Schlüter9de88092007-10-08 22:54:47 +020013036 if (!(sym->value || no_init_flag) && sym->ns->proc_name
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013037 && sym->ns->proc_name->attr.flavor == FL_MODULE
Fritz Reese34d567d2016-09-23 21:06:18 +000013038 && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013039 && !sym->attr.pointer && !sym->attr.allocatable
Daniel Franke16e520b2010-05-19 09:07:25 -040013040 && gfc_has_default_initializer (sym->ts.u.derived)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013041 && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013042 "%qs at %L, needed due to the default "
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013043 "initialization", sym->name, &sym->declared_at))
13044 return false;
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013045
13046 /* Assign default initializer. */
13047 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
Tobias Burnus51d9ef72021-10-04 09:38:43 +020013048 && (!no_init_flag
13049 || (sym->attr.intent == INTENT_OUT
13050 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)))
Fritz Reese7fc61622016-08-15 21:19:09 +000013051 sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym));
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013052
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013053 return true;
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013054}
13055
13056
Steven G. Karglf2bc4e42016-09-04 20:00:48 +000013057/* F2008, C402 (R401): A colon shall not be used as a type-param-value
13058 except in the declaration of an entity or component that has the POINTER
13059 or ALLOCATABLE attribute. */
13060
13061static bool
13062deferred_requirements (gfc_symbol *sym)
13063{
13064 if (sym->ts.deferred
13065 && !(sym->attr.pointer
13066 || sym->attr.allocatable
Paul Thomasb89a63b2017-09-21 18:40:21 +000013067 || sym->attr.associate_var
Steven G. Karglf2bc4e42016-09-04 20:00:48 +000013068 || sym->attr.omp_udr_artificial_var))
13069 {
Steven G. Kargl9b158932019-06-21 20:24:01 +000013070 /* If a function has a result variable, only check the variable. */
13071 if (sym->result && sym->name != sym->result->name)
13072 return true;
13073
Steven G. Karglf2bc4e42016-09-04 20:00:48 +000013074 gfc_error ("Entity %qs at %L has a deferred type parameter and "
13075 "requires either the POINTER or ALLOCATABLE attribute",
13076 sym->name, &sym->declared_at);
13077 return false;
13078 }
13079 return true;
13080}
13081
13082
Paul Thomas2ed8d222006-02-13 21:22:55 +000013083/* Resolve symbols with flavor variable. */
13084
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013085static bool
Paul Thomas2ed8d222006-02-13 21:22:55 +000013086resolve_fl_variable (gfc_symbol *sym, int mp_flag)
13087{
Janus Weilf8add002019-01-05 15:32:12 +010013088 const char *auto_save_msg = "Automatic object %qs at %L cannot have the "
13089 "SAVE attribute";
Paul Thomas2ed8d222006-02-13 21:22:55 +000013090
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013091 if (!resolve_fl_var_and_proc (sym, mp_flag))
13092 return false;
Tobias Schlüter110eec22005-12-22 12:37:03 +010013093
Paul Thomas0e9a4452006-06-07 07:20:39 +000013094 /* Set this flag to check that variables are parameters of all entries.
13095 This check is effected by the call to gfc_resolve_expr through
13096 is_non_constant_shape_array. */
Janus Weilf8add002019-01-05 15:32:12 +010013097 bool saved_specification_expr = specification_expr;
Tobias Burnusfd061182012-10-18 19:09:13 +020013098 specification_expr = true;
Paul Thomas0e9a4452006-06-07 07:20:39 +000013099
Tobias Schlüterc4d45562007-10-07 13:45:15 +020013100 if (sym->ns->proc_name
13101 && (sym->ns->proc_name->attr.flavor == FL_MODULE
13102 || sym->ns->proc_name->attr.is_main_program)
13103 && !sym->attr.use_assoc
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013104 && !sym->attr.allocatable
13105 && !sym->attr.pointer
13106 && is_non_constant_shape_array (sym))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013107 {
Janus Weil068b9612016-12-12 19:54:54 +010013108 /* F08:C541. The shape of an array defined in a main program or module
13109 * needs to be constant. */
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000013110 gfc_error ("The module or main program array %qs at %L must "
Tobias Schlüterc4d45562007-10-07 13:45:15 +020013111 "have constant shape", sym->name, &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013112 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013113 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013114 }
13115
Steven G. Kargle69afb22010-11-02 17:09:58 +000013116 /* Constraints on deferred type parameter. */
Steven G. Karglf2bc4e42016-09-04 20:00:48 +000013117 if (!deferred_requirements (sym))
13118 return false;
Steven G. Kargle69afb22010-11-02 17:09:58 +000013119
Steven G. Kargl50b01e12016-10-05 21:14:14 +000013120 if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013121 {
13122 /* Make sure that character string variables with assumed length are
13123 dummy arguments. */
Janus Weilf8add002019-01-05 15:32:12 +010013124 gfc_expr *e = NULL;
13125
Steven G. Kargl7d5641422018-12-19 22:31:25 +000013126 if (sym->ts.u.cl)
13127 e = sym->ts.u.cl->length;
13128 else
13129 return false;
13130
Steven G. Kargle69afb22010-11-02 17:09:58 +000013131 if (e == NULL && !sym->attr.dummy && !sym->attr.result
Jakub Jelinek5f236712014-06-06 09:24:38 +020013132 && !sym->ts.deferred && !sym->attr.select_type_temporary
13133 && !sym->attr.omp_udr_artificial_var)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013134 {
13135 gfc_error ("Entity with assumed character length at %L must be a "
13136 "dummy argument or a PARAMETER", &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013137 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013138 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013139 }
13140
Janus Weil80f95222010-08-19 00:32:22 +020013141 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
Paul Thomas0e9a4452006-06-07 07:20:39 +000013142 {
13143 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013144 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013145 return false;
Paul Thomas0e9a4452006-06-07 07:20:39 +000013146 }
13147
Paul Thomas2ed8d222006-02-13 21:22:55 +000013148 if (!gfc_is_constant_expr (e)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013149 && !(e->expr_type == EXPR_VARIABLE
Janus Weil30228b62011-08-17 11:14:18 +020013150 && e->symtree->n.sym->attr.flavor == FL_PARAMETER))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013151 {
Janus Weil30228b62011-08-17 11:14:18 +020013152 if (!sym->attr.use_assoc && sym->ns->proc_name
13153 && (sym->ns->proc_name->attr.flavor == FL_MODULE
13154 || sym->ns->proc_name->attr.is_main_program))
13155 {
Manuel López-Ibáñezfea70c92015-05-23 23:02:52 +000013156 gfc_error ("%qs at %L must have constant character length "
Janus Weil30228b62011-08-17 11:14:18 +020013157 "in this context", sym->name, &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013158 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013159 return false;
Janus Weil30228b62011-08-17 11:14:18 +020013160 }
13161 if (sym->attr.in_common)
13162 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013163 gfc_error ("COMMON variable %qs at %L must have constant "
Janus Weil30228b62011-08-17 11:14:18 +020013164 "character length", sym->name, &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013165 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013166 return false;
Janus Weil30228b62011-08-17 11:14:18 +020013167 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000013168 }
13169 }
13170
Asher Langton51b09ce2007-09-21 02:34:14 +000013171 if (sym->value == NULL && sym->attr.referenced)
13172 apply_default_init_local (sym); /* Try to apply a default initialization. */
13173
Tobias Schlüter9de88092007-10-08 22:54:47 +020013174 /* Determine if the symbol may not have an initializer. */
Janus Weilf8add002019-01-05 15:32:12 +010013175 int no_init_flag = 0, automatic_flag = 0;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013176 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
Tobias Schlüter9de88092007-10-08 22:54:47 +020013177 || sym->attr.intrinsic || sym->attr.result)
13178 no_init_flag = 1;
Tobias Burnusbe59db22010-04-06 20:16:13 +020013179 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
Tobias Schlüter9de88092007-10-08 22:54:47 +020013180 && is_non_constant_shape_array (sym))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013181 {
Tobias Schlüter9de88092007-10-08 22:54:47 +020013182 no_init_flag = automatic_flag = 1;
Paul Thomas0e9a4452006-06-07 07:20:39 +000013183
Tobias Burnus53490802007-07-05 14:51:51 +020013184 /* Also, they must not have the SAVE attribute.
13185 SAVE_IMPLICIT is checked below. */
Tobias Burnus9f3761c2011-05-31 20:25:51 +020013186 if (sym->as && sym->attr.codimension)
13187 {
13188 int corank = sym->as->corank;
13189 sym->as->corank = 0;
13190 no_init_flag = automatic_flag = is_non_constant_shape_array (sym);
13191 sym->as->corank = corank;
13192 }
13193 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
Paul Thomas0e9a4452006-06-07 07:20:39 +000013194 {
13195 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
Tobias Burnusfd061182012-10-18 19:09:13 +020013196 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013197 return false;
Paul Thomas0e9a4452006-06-07 07:20:39 +000013198 }
Tobias Schlüter448d2cd2007-10-03 13:37:44 +020013199 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000013200
Steven G. Kargl7a99def2008-10-12 09:38:18 +000013201 /* Ensure that any initializer is simplified. */
13202 if (sym->value)
13203 gfc_simplify_expr (sym->value, 1);
13204
Paul Thomas2ed8d222006-02-13 21:22:55 +000013205 /* Reject illegal initializers. */
Tobias Schlüter9de88092007-10-08 22:54:47 +020013206 if (!sym->mark && sym->value)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013207 {
Janus Weilda285ce2011-02-02 14:11:50 +010013208 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS
13209 && CLASS_DATA (sym)->attr.allocatable))
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013210 gfc_error ("Allocatable %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013211 sym->name, &sym->declared_at);
13212 else if (sym->attr.external)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013213 gfc_error ("External %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013214 sym->name, &sym->declared_at);
Mark Egglestonbae66e02020-06-10 07:22:50 +010013215 else if (sym->attr.dummy)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013216 gfc_error ("Dummy %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013217 sym->name, &sym->declared_at);
13218 else if (sym->attr.intrinsic)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013219 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013220 sym->name, &sym->declared_at);
13221 else if (sym->attr.result)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013222 gfc_error ("Function result %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013223 sym->name, &sym->declared_at);
Tobias Schlüter9de88092007-10-08 22:54:47 +020013224 else if (automatic_flag)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013225 gfc_error ("Automatic array %qs at %L cannot have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013226 sym->name, &sym->declared_at);
Paul Thomas145bdc22007-04-07 20:25:43 +000013227 else
13228 goto no_init_error;
Tobias Burnusfd061182012-10-18 19:09:13 +020013229 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013230 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013231 }
13232
Paul Thomas145bdc22007-04-07 20:25:43 +000013233no_init_error:
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020013234 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
Tobias Burnusfd061182012-10-18 19:09:13 +020013235 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013236 bool res = resolve_fl_variable_derived (sym, no_init_flag);
Tobias Burnusfd061182012-10-18 19:09:13 +020013237 specification_expr = saved_specification_expr;
13238 return res;
13239 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000013240
Tobias Burnusfd061182012-10-18 19:09:13 +020013241 specification_expr = saved_specification_expr;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013242 return true;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013243}
13244
13245
Paul Thomas4668d6f2015-07-02 20:39:56 +000013246/* Compare the dummy characteristics of a module procedure interface
13247 declaration with the corresponding declaration in a submodule. */
13248static gfc_formal_arglist *new_formal;
13249static char errmsg[200];
13250
13251static void
13252compare_fsyms (gfc_symbol *sym)
13253{
13254 gfc_symbol *fsym;
13255
13256 if (sym == NULL || new_formal == NULL)
13257 return;
13258
13259 fsym = new_formal->sym;
13260
13261 if (sym == fsym)
13262 return;
13263
13264 if (strcmp (sym->name, fsym->name) == 0)
13265 {
13266 if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
13267 gfc_error ("%s at %L", errmsg, &fsym->declared_at);
13268 }
13269}
13270
13271
Paul Thomas2ed8d222006-02-13 21:22:55 +000013272/* Resolve a procedure. */
13273
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013274static bool
Paul Thomas2ed8d222006-02-13 21:22:55 +000013275resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
13276{
13277 gfc_formal_arglist *arg;
Bernhard Reutner-Fischera16010a2021-10-31 17:17:56 +010013278 bool allocatable_or_pointer = false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013279
13280 if (sym->attr.function
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013281 && !resolve_fl_var_and_proc (sym, mp_flag))
13282 return false;
Tobias Schlüter110eec22005-12-22 12:37:03 +010013283
Steven G. Kargl9b158932019-06-21 20:24:01 +000013284 /* Constraints on deferred type parameter. */
13285 if (!deferred_requirements (sym))
13286 return false;
13287
Paul Thomas92c59192006-11-22 00:05:10 +000013288 if (sym->ts.type == BT_CHARACTER)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013289 {
Janus Weilbc21d312009-08-13 21:46:46 +020013290 gfc_charlen *cl = sym->ts.u.cl;
Paul Thomas8111a922007-05-06 15:12:01 +000013291
13292 if (cl && cl->length && gfc_is_constant_expr (cl->length)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013293 && !resolve_charlen (cl))
13294 return false;
Paul Thomas8111a922007-05-06 15:12:01 +000013295
Tobias Burnusd94be5e2009-12-15 09:37:41 +010013296 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
13297 && sym->attr.proc == PROC_ST_FUNCTION)
Paul Thomas92c59192006-11-22 00:05:10 +000013298 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013299 gfc_error ("Character-valued statement function %qs at %L must "
Tobias Burnusd94be5e2009-12-15 09:37:41 +010013300 "have constant length", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013301 return false;
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013302 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000013303 }
13304
Paul Thomas37e47ee2006-03-28 10:13:50 +000013305 /* Ensure that derived type for are not of a private type. Internal
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +000013306 module procedures are excluded by 2.2.3.3 - i.e., they are not
Kazu Hiratab82feea2006-04-08 14:31:12 +000013307 externally accessible and can access all the objects accessible in
Steven G. Kargl66e4ab32007-06-07 18:10:31 +000013308 the host. */
Janus Weilf8add002019-01-05 15:32:12 +010013309 if (!(sym->ns->parent && sym->ns->parent->proc_name
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013310 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
Janus Weil6e2062b2011-02-18 11:04:30 +010013311 && gfc_check_symbol_access (sym))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013312 {
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013313 gfc_interface *iface;
13314
Janus Weil4cbc9032013-01-29 22:40:51 +010013315 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013316 {
13317 if (arg->sym
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013318 && arg->sym->ts.type == BT_DERIVED
Mark Eggleston647340c2020-06-22 13:35:01 +010013319 && arg->sym->ts.u.derived
Janus Weilbc21d312009-08-13 21:46:46 +020013320 && !arg->sym->ts.u.derived->attr.use_assoc
Janus Weil6e2062b2011-02-18 11:04:30 +010013321 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013322 && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type "
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013323 "and cannot be a dummy argument"
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013324 " of %qs, which is PUBLIC at %L",
Paul Thomas22c23882014-10-18 14:35:51 +000013325 arg->sym->name, sym->name,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013326 &sym->declared_at))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013327 {
Paul Thomas2ed8d222006-02-13 21:22:55 +000013328 /* Stop this message from recurring. */
Janus Weilbc21d312009-08-13 21:46:46 +020013329 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013330 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013331 }
13332 }
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013333
13334 /* PUBLIC interfaces may expose PRIVATE procedures that take types
13335 PRIVATE to the containing module. */
13336 for (iface = sym->generic; iface; iface = iface->next)
13337 {
Janus Weil4cbc9032013-01-29 22:40:51 +010013338 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013339 {
13340 if (arg->sym
13341 && arg->sym->ts.type == BT_DERIVED
Janus Weilbc21d312009-08-13 21:46:46 +020013342 && !arg->sym->ts.u.derived->attr.use_assoc
Janus Weil6e2062b2011-02-18 11:04:30 +010013343 && !gfc_check_symbol_access (arg->sym->ts.u.derived)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013344 && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in "
13345 "PUBLIC interface %qs at %L "
13346 "takes dummy arguments of %qs which "
Paul Thomas22c23882014-10-18 14:35:51 +000013347 "is PRIVATE", iface->sym->name,
13348 sym->name, &iface->sym->declared_at,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013349 gfc_typename(&arg->sym->ts)))
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013350 {
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013351 /* Stop this message from recurring. */
Janus Weilbc21d312009-08-13 21:46:46 +020013352 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013353 return false;
Daniel Franke83b2e4e2007-07-08 16:38:58 -040013354 }
13355 }
13356 }
Paul Thomas2ed8d222006-02-13 21:22:55 +000013357 }
13358
Janus Weil8fb74da2008-07-02 21:53:37 +020013359 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
13360 && !sym->attr.proc_pointer)
Daniel Frankef8faa852007-07-12 18:15:11 -040013361 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013362 gfc_error ("Function %qs at %L cannot have an initializer",
Daniel Frankef8faa852007-07-12 18:15:11 -040013363 sym->name, &sym->declared_at);
Thomas Koenig83fad922018-11-18 09:16:19 +000013364
13365 /* Make sure no second error is issued for this. */
13366 sym->value->error = 1;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013367 return false;
Daniel Frankef8faa852007-07-12 18:15:11 -040013368 }
13369
Kazu Hiratae2ae1402006-05-28 17:56:58 +000013370 /* An external symbol may not have an initializer because it is taken to be
Janus Weil8fb74da2008-07-02 21:53:37 +020013371 a procedure. Exception: Procedure Pointers. */
13372 if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013373 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013374 gfc_error ("External object %qs at %L may not have an initializer",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013375 sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013376 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013377 }
13378
Paul Thomasd68bd5a2006-06-25 15:11:02 +000013379 /* An elemental function is required to return a scalar 12.7.1 */
Paul Thomas2b03b802018-10-06 15:14:29 +000013380 if (sym->attr.elemental && sym->attr.function
Harald Anlauf7e913ca2021-12-10 22:41:24 +010013381 && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok
13382 && CLASS_DATA (sym)->as)))
Paul Thomasd68bd5a2006-06-25 15:11:02 +000013383 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013384 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
Paul Thomasd68bd5a2006-06-25 15:11:02 +000013385 "result", sym->name, &sym->declared_at);
13386 /* Reset so that the error only occurs once. */
13387 sym->attr.elemental = 0;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013388 return false;
Paul Thomasd68bd5a2006-06-25 15:11:02 +000013389 }
13390
Tobias Burnus1ca99f72011-01-30 19:17:29 +010013391 if (sym->attr.proc == PROC_ST_FUNCTION
13392 && (sym->attr.allocatable || sym->attr.pointer))
13393 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013394 gfc_error ("Statement function %qs at %L may not have pointer or "
Tobias Burnus1ca99f72011-01-30 19:17:29 +010013395 "allocatable attribute", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013396 return false;
Tobias Burnus1ca99f72011-01-30 19:17:29 +010013397 }
13398
Paul Thomas2ed8d222006-02-13 21:22:55 +000013399 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
13400 char-len-param shall not be array-valued, pointer-valued, recursive
13401 or pure. ....snip... A character value of * may only be used in the
13402 following ways: (i) Dummy arg of procedure - dummy associates with
13403 actual length; (ii) To declare a named constant; or (iii) External
13404 function - but length must be declared in calling scoping unit. */
13405 if (sym->attr.function
Tobias Burnusdd912332012-05-12 11:53:53 +020013406 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred
Janus Weilbc21d312009-08-13 21:46:46 +020013407 && sym->ts.u.cl && sym->ts.u.cl->length == NULL)
Paul Thomas2ed8d222006-02-13 21:22:55 +000013408 {
13409 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000013410 || (sym->attr.recursive) || (sym->attr.pure))
Paul Thomas2ed8d222006-02-13 21:22:55 +000013411 {
13412 if (sym->as && sym->as->rank)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013413 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
Paul Thomas2ed8d222006-02-13 21:22:55 +000013414 "array-valued", sym->name, &sym->declared_at);
13415
13416 if (sym->attr.pointer)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013417 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
Paul Thomas2ed8d222006-02-13 21:22:55 +000013418 "pointer-valued", sym->name, &sym->declared_at);
13419
13420 if (sym->attr.pure)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013421 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
Paul Thomas2ed8d222006-02-13 21:22:55 +000013422 "pure", sym->name, &sym->declared_at);
13423
13424 if (sym->attr.recursive)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013425 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
Paul Thomas2ed8d222006-02-13 21:22:55 +000013426 "recursive", sym->name, &sym->declared_at);
13427
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013428 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000013429 }
13430
13431 /* Appendix B.2 of the standard. Contained functions give an
Francois-Xavier Coudert63a496d2014-10-04 10:18:07 +000013432 error anyway. Deferred character length is an F2003 feature.
13433 Don't warn on intrinsic conversion functions, which start
13434 with two underscores. */
13435 if (!sym->attr.contained && !sym->ts.deferred
13436 && (sym->name[0] != '_' || sym->name[1] != '_'))
Janus Weil9717f7a2012-07-17 23:51:20 +020013437 gfc_notify_std (GFC_STD_F95_OBS,
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013438 "CHARACTER(*) function %qs at %L",
Paul Thomas2ed8d222006-02-13 21:22:55 +000013439 sym->name, &sym->declared_at);
13440 }
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013441
Tobias Burnus019c0e52013-12-08 22:34:18 +010013442 /* F2008, C1218. */
13443 if (sym->attr.elemental)
13444 {
13445 if (sym->attr.proc_pointer)
13446 {
Mark Egglestoneb069ae2020-05-07 08:02:02 +010013447 const char* name = (sym->attr.result ? sym->ns->proc_name->name
13448 : sym->name);
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013449 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
Mark Egglestoneb069ae2020-05-07 08:02:02 +010013450 name, &sym->declared_at);
Tobias Burnus019c0e52013-12-08 22:34:18 +010013451 return false;
13452 }
13453 if (sym->attr.dummy)
13454 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013455 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
Tobias Burnus019c0e52013-12-08 22:34:18 +010013456 sym->name, &sym->declared_at);
13457 return false;
13458 }
13459 }
13460
Steven G. Kargl1813c972018-03-11 21:39:15 +000013461 /* F2018, C15100: "The result of an elemental function shall be scalar,
13462 and shall not have the POINTER or ALLOCATABLE attribute." The scalar
13463 pointer is tested and caught elsewhere. */
Paul Thomas29a52982021-02-23 19:29:04 +000013464 if (sym->result)
13465 allocatable_or_pointer = sym->result->ts.type == BT_CLASS
13466 && CLASS_DATA (sym->result) ?
13467 (CLASS_DATA (sym->result)->attr.allocatable
13468 || CLASS_DATA (sym->result)->attr.pointer) :
13469 (sym->result->attr.allocatable
13470 || sym->result->attr.pointer);
13471
Steven G. Kargl1813c972018-03-11 21:39:15 +000013472 if (sym->attr.elemental && sym->result
Paul Thomas29a52982021-02-23 19:29:04 +000013473 && allocatable_or_pointer)
Steven G. Kargl1813c972018-03-11 21:39:15 +000013474 {
13475 gfc_error ("Function result variable %qs at %L of elemental "
13476 "function %qs shall not have an ALLOCATABLE or POINTER "
13477 "attribute", sym->result->name,
13478 &sym->result->declared_at, sym->name);
13479 return false;
13480 }
13481
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013482 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
13483 {
13484 gfc_formal_arglist *curr_arg;
Christopher D. Rickettaa5e22f2007-07-12 19:52:03 +000013485 int has_non_interop_arg = 0;
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013486
Paul Thomas22c23882014-10-18 14:35:51 +000013487 if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013488 sym->common_block))
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013489 {
13490 /* Clear these to prevent looking at them again if there was an
13491 error. */
13492 sym->attr.is_bind_c = 0;
13493 sym->attr.is_c_interop = 0;
13494 sym->ts.is_c_interop = 0;
13495 }
13496 else
13497 {
13498 /* So far, no errors have been found. */
13499 sym->attr.is_c_interop = 1;
13500 sym->ts.is_c_interop = 1;
13501 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000013502
Janus Weil4cbc9032013-01-29 22:40:51 +010013503 curr_arg = gfc_sym_get_dummy_args (sym);
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013504 while (curr_arg != NULL)
13505 {
13506 /* Skip implicitly typed dummy args here. */
Steven G. Kargl67b8d502018-05-24 23:28:35 +000013507 if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013508 if (!gfc_verify_c_interop_param (curr_arg->sym))
Christopher D. Rickettaa5e22f2007-07-12 19:52:03 +000013509 /* If something is found to fail, record the fact so we
13510 can mark the symbol for the procedure as not being
13511 BIND(C) to try and prevent multiple errors being
13512 reported. */
13513 has_non_interop_arg = 1;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000013514
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013515 curr_arg = curr_arg->next;
13516 }
Christopher D. Rickettaa5e22f2007-07-12 19:52:03 +000013517
13518 /* See if any of the arguments were not interoperable and if so, clear
13519 the procedure symbol to prevent duplicate error messages. */
13520 if (has_non_interop_arg != 0)
13521 {
13522 sym->attr.is_c_interop = 0;
13523 sym->ts.is_c_interop = 0;
13524 sym->attr.is_bind_c = 0;
13525 }
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000013526 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000013527
Janus Weil3070bab2009-04-09 11:39:09 +020013528 if (!sym->attr.proc_pointer)
Janus Weilbeb4bd62008-08-14 23:15:59 +020013529 {
Janus Weil3070bab2009-04-09 11:39:09 +020013530 if (sym->attr.save == SAVE_EXPLICIT)
13531 {
13532 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013533 "in %qs at %L", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013534 return false;
Janus Weil3070bab2009-04-09 11:39:09 +020013535 }
13536 if (sym->attr.intent)
13537 {
13538 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013539 "in %qs at %L", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013540 return false;
Janus Weil3070bab2009-04-09 11:39:09 +020013541 }
13542 if (sym->attr.subroutine && sym->attr.result)
13543 {
13544 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
Mark Egglestoneb069ae2020-05-07 08:02:02 +010013545 "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013546 return false;
Janus Weil3070bab2009-04-09 11:39:09 +020013547 }
Paul Thomas70112e22016-03-12 13:59:10 +000013548 if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure
Janus Weil3070bab2009-04-09 11:39:09 +020013549 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
13550 || sym->attr.contained))
13551 {
13552 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013553 "in %qs at %L", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013554 return false;
Janus Weil3070bab2009-04-09 11:39:09 +020013555 }
13556 if (strcmp ("ppr@", sym->name) == 0)
13557 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013558 gfc_error ("Procedure pointer result %qs at %L "
Janus Weil3070bab2009-04-09 11:39:09 +020013559 "is missing the pointer attribute",
13560 sym->ns->proc_name->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013561 return false;
Janus Weil3070bab2009-04-09 11:39:09 +020013562 }
Janus Weilbeb4bd62008-08-14 23:15:59 +020013563 }
13564
Paul Thomas30c931d2015-03-23 07:53:31 +000013565 /* Assume that a procedure whose body is not known has references
13566 to external arrays. */
13567 if (sym->attr.if_source != IFSRC_DECL)
13568 sym->attr.array_outer_dependency = 1;
13569
Paul Thomas4668d6f2015-07-02 20:39:56 +000013570 /* Compare the characteristics of a module procedure with the
13571 interface declaration. Ideally this would be done with
13572 gfc_compare_interfaces but, at present, the formal interface
13573 cannot be copied to the ts.interface. */
13574 if (sym->attr.module_procedure
13575 && sym->attr.if_source == IFSRC_DECL)
13576 {
13577 gfc_symbol *iface;
Paul Thomas4f283c42015-09-26 17:52:24 +000013578 char name[2*GFC_MAX_SYMBOL_LEN + 1];
13579 char *module_name;
13580 char *submodule_name;
13581 strcpy (name, sym->ns->proc_name->name);
13582 module_name = strtok (name, ".");
13583 submodule_name = strtok (NULL, ".");
Paul Thomas4668d6f2015-07-02 20:39:56 +000013584
Paul Thomasc0643742016-12-09 22:25:26 +000013585 iface = sym->tlink;
13586 sym->tlink = NULL;
Paul Thomas4668d6f2015-07-02 20:39:56 +000013587
Paul Thomas88b89712016-08-24 19:33:14 +000013588 /* Make sure that the result uses the correct charlen for deferred
13589 length results. */
13590 if (iface && sym->result
13591 && iface->ts.type == BT_CHARACTER
13592 && iface->ts.deferred)
13593 sym->result->ts.u.cl = iface->ts.u.cl;
13594
Paul Thomas4668d6f2015-07-02 20:39:56 +000013595 if (iface == NULL)
13596 goto check_formal;
13597
13598 /* Check the procedure characteristics. */
Paul Thomas6442a6f432016-06-01 14:30:00 +000013599 if (sym->attr.elemental != iface->attr.elemental)
Paul Thomas4668d6f2015-07-02 20:39:56 +000013600 {
Paul Thomas6442a6f432016-06-01 14:30:00 +000013601 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
Paul Thomas4668d6f2015-07-02 20:39:56 +000013602 "PROCEDURE at %L and its interface in %s",
Paul Thomas4f283c42015-09-26 17:52:24 +000013603 &sym->declared_at, module_name);
Paul Thomas4668d6f2015-07-02 20:39:56 +000013604 return false;
13605 }
13606
Paul Thomas6442a6f432016-06-01 14:30:00 +000013607 if (sym->attr.pure != iface->attr.pure)
Paul Thomas4668d6f2015-07-02 20:39:56 +000013608 {
Paul Thomas6442a6f432016-06-01 14:30:00 +000013609 gfc_error ("Mismatch in PURE attribute between MODULE "
Paul Thomas4668d6f2015-07-02 20:39:56 +000013610 "PROCEDURE at %L and its interface in %s",
Paul Thomas4f283c42015-09-26 17:52:24 +000013611 &sym->declared_at, module_name);
Paul Thomas4668d6f2015-07-02 20:39:56 +000013612 return false;
13613 }
13614
13615 if (sym->attr.recursive != iface->attr.recursive)
13616 {
13617 gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
13618 "PROCEDURE at %L and its interface in %s",
Paul Thomas4f283c42015-09-26 17:52:24 +000013619 &sym->declared_at, module_name);
Paul Thomas4668d6f2015-07-02 20:39:56 +000013620 return false;
13621 }
13622
13623 /* Check the result characteristics. */
13624 if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
13625 {
13626 gfc_error ("%s between the MODULE PROCEDURE declaration "
Dominique d'Humieres2f029c02017-03-22 17:29:30 +010013627 "in MODULE %qs and the declaration at %L in "
13628 "(SUB)MODULE %qs",
Paul Thomas753721a2017-02-28 19:32:02 +000013629 errmsg, module_name, &sym->declared_at,
13630 submodule_name ? submodule_name : module_name);
Paul Thomas4668d6f2015-07-02 20:39:56 +000013631 return false;
13632 }
13633
13634check_formal:
Paul Thomasc0643742016-12-09 22:25:26 +000013635 /* Check the characteristics of the formal arguments. */
Paul Thomas4668d6f2015-07-02 20:39:56 +000013636 if (sym->formal && sym->formal_ns)
13637 {
13638 for (arg = sym->formal; arg && arg->sym; arg = arg->next)
13639 {
13640 new_formal = arg;
13641 gfc_traverse_ns (sym->formal_ns, compare_fsyms);
13642 }
13643 }
Paul Thomas4668d6f2015-07-02 20:39:56 +000013644 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013645 return true;
Tobias Schlüter110eec22005-12-22 12:37:03 +010013646}
13647
13648
Daniel Kraft34523522008-06-02 22:03:03 +020013649/* Resolve a list of finalizer procedures. That is, after they have hopefully
13650 been defined and we now know their defined arguments, check that they fulfill
13651 the requirements of the standard for procedures used as finalizers. */
13652
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013653static bool
Tobias Burnuscb414902014-04-12 00:35:47 +020013654gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
Daniel Kraft34523522008-06-02 22:03:03 +020013655{
13656 gfc_finalizer* list;
13657 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013658 bool result = true;
Daniel Kraft34523522008-06-02 22:03:03 +020013659 bool seen_scalar = false;
Tobias Burnuscb414902014-04-12 00:35:47 +020013660 gfc_symbol *vtab;
13661 gfc_component *c;
Tobias Burnus19fe9652014-08-17 18:42:19 +020013662 gfc_symbol *parent = gfc_get_derived_super_type (derived);
13663
13664 if (parent)
13665 gfc_resolve_finalizers (parent, finalizable);
Daniel Kraft34523522008-06-02 22:03:03 +020013666
Janus Weil5285d5d2017-05-09 22:55:38 +020013667 /* Ensure that derived-type components have a their finalizers resolved. */
13668 bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
13669 for (c = derived->components; c; c = c->next)
13670 if (c->ts.type == BT_DERIVED
13671 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
13672 {
13673 bool has_final2 = false;
13674 if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
13675 return false; /* Error. */
13676 has_final = has_final || has_final2;
13677 }
13678 /* Return early if not finalizable. */
13679 if (!has_final)
Tobias Burnuscb414902014-04-12 00:35:47 +020013680 {
Janus Weil5285d5d2017-05-09 22:55:38 +020013681 if (finalizable)
13682 *finalizable = false;
13683 return true;
Tobias Burnuscb414902014-04-12 00:35:47 +020013684 }
Daniel Kraft34523522008-06-02 22:03:03 +020013685
13686 /* Walk over the list of finalizer-procedures, check them, and if any one
13687 does not fit in with the standard's definition, print an error and remove
13688 it from the list. */
13689 prev_link = &derived->f2k_derived->finalizers;
13690 for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
13691 {
Janus Weil4cbc9032013-01-29 22:40:51 +010013692 gfc_formal_arglist *dummy_args;
Daniel Kraft34523522008-06-02 22:03:03 +020013693 gfc_symbol* arg;
13694 gfc_finalizer* i;
13695 int my_rank;
13696
Daniel Kraftf6fad282008-08-08 20:19:46 +020013697 /* Skip this finalizer if we already resolved it. */
13698 if (list->proc_tree)
13699 {
Janus Weilc0fe5a22016-11-29 15:15:29 +010013700 if (list->proc_tree->n.sym->formal->sym->as == NULL
13701 || list->proc_tree->n.sym->formal->sym->as->rank == 0)
13702 seen_scalar = true;
Daniel Kraftf6fad282008-08-08 20:19:46 +020013703 prev_link = &(list->next);
13704 continue;
13705 }
13706
Daniel Kraft34523522008-06-02 22:03:03 +020013707 /* Check this exists and is a SUBROUTINE. */
Daniel Kraftf6fad282008-08-08 20:19:46 +020013708 if (!list->proc_sym->attr.subroutine)
Daniel Kraft34523522008-06-02 22:03:03 +020013709 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013710 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
Daniel Kraftf6fad282008-08-08 20:19:46 +020013711 list->proc_sym->name, &list->where);
Daniel Kraft34523522008-06-02 22:03:03 +020013712 goto error;
13713 }
13714
13715 /* We should have exactly one argument. */
Janus Weil4cbc9032013-01-29 22:40:51 +010013716 dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
13717 if (!dummy_args || dummy_args->next)
Daniel Kraft34523522008-06-02 22:03:03 +020013718 {
13719 gfc_error ("FINAL procedure at %L must have exactly one argument",
13720 &list->where);
13721 goto error;
13722 }
Janus Weil4cbc9032013-01-29 22:40:51 +010013723 arg = dummy_args->sym;
Daniel Kraft34523522008-06-02 22:03:03 +020013724
13725 /* This argument must be of our type. */
Janus Weilbc21d312009-08-13 21:46:46 +020013726 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
Daniel Kraft34523522008-06-02 22:03:03 +020013727 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013728 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
Daniel Kraft34523522008-06-02 22:03:03 +020013729 &arg->declared_at, derived->name);
13730 goto error;
13731 }
13732
13733 /* It must neither be a pointer nor allocatable nor optional. */
13734 if (arg->attr.pointer)
13735 {
13736 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
13737 &arg->declared_at);
13738 goto error;
13739 }
13740 if (arg->attr.allocatable)
13741 {
13742 gfc_error ("Argument of FINAL procedure at %L must not be"
13743 " ALLOCATABLE", &arg->declared_at);
13744 goto error;
13745 }
13746 if (arg->attr.optional)
13747 {
13748 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
13749 &arg->declared_at);
13750 goto error;
13751 }
13752
13753 /* It must not be INTENT(OUT). */
13754 if (arg->attr.intent == INTENT_OUT)
13755 {
13756 gfc_error ("Argument of FINAL procedure at %L must not be"
13757 " INTENT(OUT)", &arg->declared_at);
13758 goto error;
13759 }
13760
13761 /* Warn if the procedure is non-scalar and not assumed shape. */
Tobias Burnus73e42ee2014-11-30 09:33:25 +010013762 if (warn_surprising && arg->as && arg->as->rank != 0
Daniel Kraft34523522008-06-02 22:03:03 +020013763 && arg->as->type != AS_ASSUMED_SHAPE)
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +000013764 gfc_warning (OPT_Wsurprising,
13765 "Non-scalar FINAL procedure at %L should have assumed"
Daniel Kraft34523522008-06-02 22:03:03 +020013766 " shape argument", &arg->declared_at);
13767
13768 /* Check that it does not match in kind and rank with a FINAL procedure
13769 defined earlier. To really loop over the *earlier* declarations,
13770 we need to walk the tail of the list as new ones were pushed at the
13771 front. */
13772 /* TODO: Handle kind parameters once they are implemented. */
13773 my_rank = (arg->as ? arg->as->rank : 0);
13774 for (i = list->next; i; i = i->next)
13775 {
Janus Weil4cbc9032013-01-29 22:40:51 +010013776 gfc_formal_arglist *dummy_args;
13777
Daniel Kraft34523522008-06-02 22:03:03 +020013778 /* Argument list might be empty; that is an error signalled earlier,
13779 but we nevertheless continued resolving. */
Janus Weil4cbc9032013-01-29 22:40:51 +010013780 dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
13781 if (dummy_args)
Daniel Kraft34523522008-06-02 22:03:03 +020013782 {
Janus Weil4cbc9032013-01-29 22:40:51 +010013783 gfc_symbol* i_arg = dummy_args->sym;
Daniel Kraft34523522008-06-02 22:03:03 +020013784 const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
13785 if (i_rank == my_rank)
13786 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013787 gfc_error ("FINAL procedure %qs declared at %L has the same"
13788 " rank (%d) as %qs",
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000013789 list->proc_sym->name, &list->where, my_rank,
Daniel Kraftf6fad282008-08-08 20:19:46 +020013790 i->proc_sym->name);
Daniel Kraft34523522008-06-02 22:03:03 +020013791 goto error;
13792 }
13793 }
13794 }
13795
13796 /* Is this the/a scalar finalizer procedure? */
Janus Weilc0fe5a22016-11-29 15:15:29 +010013797 if (my_rank == 0)
Daniel Kraft34523522008-06-02 22:03:03 +020013798 seen_scalar = true;
13799
Daniel Kraftf6fad282008-08-08 20:19:46 +020013800 /* Find the symtree for this procedure. */
13801 gcc_assert (!list->proc_tree);
13802 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
13803
Daniel Kraft34523522008-06-02 22:03:03 +020013804 prev_link = &list->next;
13805 continue;
13806
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +000013807 /* Remove wrong nodes immediately from the list so we don't risk any
Daniel Kraft34523522008-06-02 22:03:03 +020013808 troubles in the future when they might fail later expectations. */
13809error:
Daniel Kraft34523522008-06-02 22:03:03 +020013810 i = list;
13811 *prev_link = list->next;
13812 gfc_free_finalizer (i);
Tobias Burnuscb414902014-04-12 00:35:47 +020013813 result = false;
Daniel Kraft34523522008-06-02 22:03:03 +020013814 }
13815
Tobias Burnuscb414902014-04-12 00:35:47 +020013816 if (result == false)
13817 return false;
13818
Daniel Kraft34523522008-06-02 22:03:03 +020013819 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
13820 were nodes in the list, must have been for arrays. It is surely a good
13821 idea to have a scalar version there if there's something to finalize. */
Janus Weil802583a2016-12-03 10:32:27 +010013822 if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
Manuel López-Ibáñez48749db2014-12-03 17:50:06 +000013823 gfc_warning (OPT_Wsurprising,
13824 "Only array FINAL procedures declared for derived type %qs"
Daniel Kraft34523522008-06-02 22:03:03 +020013825 " defined at %L, suggest also scalar one",
13826 derived->name, &derived->declared_at);
13827
Tobias Burnuscb414902014-04-12 00:35:47 +020013828 vtab = gfc_find_derived_vtab (derived);
13829 c = vtab->ts.u.derived->components->next->next->next->next->next;
13830 gfc_set_sym_referenced (c->initializer->symtree->n.sym);
13831
13832 if (finalizable)
13833 *finalizable = true;
13834
13835 return true;
Daniel Kraft34523522008-06-02 22:03:03 +020013836}
13837
13838
Daniel Krafte157f7362008-08-31 12:00:30 +020013839/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
13840
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013841static bool
Daniel Krafte157f7362008-08-31 12:00:30 +020013842check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
13843 const char* generic_name, locus where)
13844{
Janus Weil6f3ab302012-06-22 23:05:51 +020013845 gfc_symbol *sym1, *sym2;
13846 const char *pass1, *pass2;
Janus Weil2a144f62014-02-18 08:45:39 +010013847 gfc_formal_arglist *dummy_args;
Daniel Krafte157f7362008-08-31 12:00:30 +020013848
13849 gcc_assert (t1->specific && t2->specific);
13850 gcc_assert (!t1->specific->is_generic);
13851 gcc_assert (!t2->specific->is_generic);
Tobias Burnus218e1222012-01-31 19:41:47 +010013852 gcc_assert (t1->is_operator == t2->is_operator);
Daniel Krafte157f7362008-08-31 12:00:30 +020013853
13854 sym1 = t1->specific->u.specific->n.sym;
13855 sym2 = t2->specific->u.specific->n.sym;
13856
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020013857 if (sym1 == sym2)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013858 return true;
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020013859
Daniel Krafte157f7362008-08-31 12:00:30 +020013860 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
13861 if (sym1->attr.subroutine != sym2->attr.subroutine
13862 || sym1->attr.function != sym2->attr.function)
13863 {
Martin Liska1fe61ad2019-03-12 16:11:42 +010013864 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for"
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013865 " GENERIC %qs at %L",
Daniel Krafte157f7362008-08-31 12:00:30 +020013866 sym1->name, sym2->name, generic_name, &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013867 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013868 }
13869
Janus Weil2a144f62014-02-18 08:45:39 +010013870 /* Determine PASS arguments. */
Janus Weil6f3ab302012-06-22 23:05:51 +020013871 if (t1->specific->nopass)
13872 pass1 = NULL;
13873 else if (t1->specific->pass_arg)
13874 pass1 = t1->specific->pass_arg;
13875 else
Janus Weil2a144f62014-02-18 08:45:39 +010013876 {
13877 dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym);
13878 if (dummy_args)
13879 pass1 = dummy_args->sym->name;
13880 else
13881 pass1 = NULL;
13882 }
Janus Weil6f3ab302012-06-22 23:05:51 +020013883 if (t2->specific->nopass)
13884 pass2 = NULL;
13885 else if (t2->specific->pass_arg)
13886 pass2 = t2->specific->pass_arg;
13887 else
Janus Weil2a144f62014-02-18 08:45:39 +010013888 {
13889 dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym);
13890 if (dummy_args)
13891 pass2 = dummy_args->sym->name;
13892 else
13893 pass2 = NULL;
13894 }
13895
13896 /* Compare the interfaces. */
Tobias Burnus218e1222012-01-31 19:41:47 +010013897 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
Janus Weil6f3ab302012-06-22 23:05:51 +020013898 NULL, 0, pass1, pass2))
Daniel Krafte157f7362008-08-31 12:00:30 +020013899 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013900 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
Daniel Krafte157f7362008-08-31 12:00:30 +020013901 sym1->name, sym2->name, generic_name, &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013902 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013903 }
13904
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013905 return true;
Daniel Krafte157f7362008-08-31 12:00:30 +020013906}
13907
13908
Daniel Kraft94747282009-08-10 12:51:46 +020013909/* Worker function for resolving a generic procedure binding; this is used to
13910 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
13911
13912 The difference between those cases is finding possible inherited bindings
13913 that are overridden, as one has to look for them in tb_sym_root,
13914 tb_uop_root or tb_op, respectively. Thus the caller must already find
13915 the super-type and set p->overridden correctly. */
Daniel Krafte157f7362008-08-31 12:00:30 +020013916
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013917static bool
Daniel Kraft94747282009-08-10 12:51:46 +020013918resolve_tb_generic_targets (gfc_symbol* super_type,
13919 gfc_typebound_proc* p, const char* name)
Daniel Krafte157f7362008-08-31 12:00:30 +020013920{
13921 gfc_tbp_generic* target;
13922 gfc_symtree* first_target;
Daniel Krafte157f7362008-08-31 12:00:30 +020013923 gfc_symtree* inherited;
Daniel Krafte157f7362008-08-31 12:00:30 +020013924
Daniel Kraft94747282009-08-10 12:51:46 +020013925 gcc_assert (p && p->is_generic);
Daniel Krafte157f7362008-08-31 12:00:30 +020013926
13927 /* Try to find the specific bindings for the symtrees in our target-list. */
Daniel Kraft94747282009-08-10 12:51:46 +020013928 gcc_assert (p->u.generic);
13929 for (target = p->u.generic; target; target = target->next)
Daniel Krafte157f7362008-08-31 12:00:30 +020013930 if (!target->specific)
13931 {
13932 gfc_typebound_proc* overridden_tbp;
13933 gfc_tbp_generic* g;
13934 const char* target_name;
13935
13936 target_name = target->specific_st->name;
13937
13938 /* Defined for this type directly. */
Janus Weilaea18e92010-08-03 13:08:50 +020013939 if (target->specific_st->n.tb && !target->specific_st->n.tb->error)
Daniel Krafte157f7362008-08-31 12:00:30 +020013940 {
Daniel Krafte34ccb42009-04-24 17:20:23 +020013941 target->specific = target->specific_st->n.tb;
Daniel Krafte157f7362008-08-31 12:00:30 +020013942 goto specific_found;
13943 }
13944
13945 /* Look for an inherited specific binding. */
13946 if (super_type)
13947 {
Daniel Kraft4a44a722009-08-27 13:42:56 +020013948 inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
13949 true, NULL);
Daniel Krafte157f7362008-08-31 12:00:30 +020013950
13951 if (inherited)
13952 {
Daniel Krafte34ccb42009-04-24 17:20:23 +020013953 gcc_assert (inherited->n.tb);
13954 target->specific = inherited->n.tb;
Daniel Krafte157f7362008-08-31 12:00:30 +020013955 goto specific_found;
13956 }
13957 }
13958
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013959 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
Daniel Kraft94747282009-08-10 12:51:46 +020013960 " at %L", target_name, name, &p->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013961 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013962
13963 /* Once we've found the specific binding, check it is not ambiguous with
13964 other specifics already found or inherited for the same GENERIC. */
13965specific_found:
13966 gcc_assert (target->specific);
13967
13968 /* This must really be a specific binding! */
13969 if (target->specific->is_generic)
13970 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010013971 gfc_error ("GENERIC %qs at %L must target a specific binding,"
13972 " %qs is GENERIC, too", name, &p->where, target_name);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013973 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013974 }
13975
13976 /* Check those already resolved on this type directly. */
Daniel Kraft94747282009-08-10 12:51:46 +020013977 for (g = p->u.generic; g; g = g->next)
Daniel Krafte157f7362008-08-31 12:00:30 +020013978 if (g != target && g->specific
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013979 && !check_generic_tbp_ambiguity (target, g, name, p->where))
13980 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013981
13982 /* Check for ambiguity with inherited specific targets. */
Daniel Kraft94747282009-08-10 12:51:46 +020013983 for (overridden_tbp = p->overridden; overridden_tbp;
Daniel Krafte157f7362008-08-31 12:00:30 +020013984 overridden_tbp = overridden_tbp->overridden)
13985 if (overridden_tbp->is_generic)
13986 {
13987 for (g = overridden_tbp->u.generic; g; g = g->next)
13988 {
13989 gcc_assert (g->specific);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030013990 if (!check_generic_tbp_ambiguity (target, g, name, p->where))
13991 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020013992 }
13993 }
13994 }
13995
13996 /* If we attempt to "overwrite" a specific binding, this is an error. */
Daniel Kraft94747282009-08-10 12:51:46 +020013997 if (p->overridden && !p->overridden->is_generic)
Daniel Krafte157f7362008-08-31 12:00:30 +020013998 {
Martin Liska1fe61ad2019-03-12 16:11:42 +010013999 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with"
Daniel Kraft94747282009-08-10 12:51:46 +020014000 " the same name", name, &p->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014001 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020014002 }
14003
14004 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
14005 all must have the same attributes here. */
Daniel Kraft94747282009-08-10 12:51:46 +020014006 first_target = p->u.generic->specific->u.specific;
Daniel Krafte34ccb42009-04-24 17:20:23 +020014007 gcc_assert (first_target);
Daniel Kraft94747282009-08-10 12:51:46 +020014008 p->subroutine = first_target->n.sym->attr.subroutine;
14009 p->function = first_target->n.sym->attr.function;
Daniel Krafte157f7362008-08-31 12:00:30 +020014010
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014011 return true;
Daniel Krafte157f7362008-08-31 12:00:30 +020014012}
14013
14014
Daniel Kraft94747282009-08-10 12:51:46 +020014015/* Resolve a GENERIC procedure binding for a derived type. */
14016
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014017static bool
Daniel Kraft94747282009-08-10 12:51:46 +020014018resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
14019{
14020 gfc_symbol* super_type;
14021
14022 /* Find the overridden binding if any. */
14023 st->n.tb->overridden = NULL;
14024 super_type = gfc_get_derived_super_type (derived);
14025 if (super_type)
14026 {
14027 gfc_symtree* overridden;
Daniel Kraft4a44a722009-08-27 13:42:56 +020014028 overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
14029 true, NULL);
Daniel Kraft94747282009-08-10 12:51:46 +020014030
14031 if (overridden && overridden->n.tb)
14032 st->n.tb->overridden = overridden->n.tb;
14033 }
14034
14035 /* Resolve using worker function. */
14036 return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
14037}
14038
14039
Daniel Kraftb325faf2009-08-17 20:55:30 +020014040/* Retrieve the target-procedure of an operator binding and do some checks in
14041 common for intrinsic and user-defined type-bound operators. */
14042
14043static gfc_symbol*
14044get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
14045{
14046 gfc_symbol* target_proc;
14047
14048 gcc_assert (target->specific && !target->specific->is_generic);
14049 target_proc = target->specific->u.specific->n.sym;
14050 gcc_assert (target_proc);
14051
Janus Weil2e33ad22012-09-17 00:04:26 +020014052 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
Daniel Kraftb325faf2009-08-17 20:55:30 +020014053 if (target->specific->nopass)
14054 {
Martin Liska1fe61ad2019-03-12 16:11:42 +010014055 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where);
Daniel Kraftb325faf2009-08-17 20:55:30 +020014056 return NULL;
14057 }
14058
14059 return target_proc;
14060}
14061
14062
Daniel Kraft94747282009-08-10 12:51:46 +020014063/* Resolve a type-bound intrinsic operator. */
14064
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014065static bool
Daniel Kraft94747282009-08-10 12:51:46 +020014066resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
14067 gfc_typebound_proc* p)
14068{
14069 gfc_symbol* super_type;
14070 gfc_tbp_generic* target;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014071
Daniel Kraft94747282009-08-10 12:51:46 +020014072 /* If there's already an error here, do nothing (but don't fail again). */
14073 if (p->error)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014074 return true;
Daniel Kraft94747282009-08-10 12:51:46 +020014075
14076 /* Operators should always be GENERIC bindings. */
14077 gcc_assert (p->is_generic);
14078
14079 /* Look for an overridden binding. */
14080 super_type = gfc_get_derived_super_type (derived);
14081 if (super_type && super_type->f2k_derived)
14082 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
Daniel Kraft4a44a722009-08-27 13:42:56 +020014083 op, true, NULL);
Daniel Kraft94747282009-08-10 12:51:46 +020014084 else
14085 p->overridden = NULL;
14086
14087 /* Resolve general GENERIC properties using worker function. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014088 if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op)))
Daniel Kraft94747282009-08-10 12:51:46 +020014089 goto error;
14090
14091 /* Check the targets to be procedures of correct interface. */
14092 for (target = p->u.generic; target; target = target->next)
14093 {
14094 gfc_symbol* target_proc;
14095
Daniel Kraftb325faf2009-08-17 20:55:30 +020014096 target_proc = get_checked_tb_operator_target (target, p->where);
14097 if (!target_proc)
Daniel Kraft4a44a722009-08-27 13:42:56 +020014098 goto error;
Daniel Kraft94747282009-08-10 12:51:46 +020014099
14100 if (!gfc_check_operator_interface (target_proc, op, p->where))
Daniel Kraft4a44a722009-08-27 13:42:56 +020014101 goto error;
Janus Weil362aa472012-06-27 19:38:00 +020014102
14103 /* Add target to non-typebound operator list. */
14104 if (!target->specific->deferred && !derived->attr.use_assoc
Paul Thomas474d4862012-12-02 15:23:30 +000014105 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
Janus Weil362aa472012-06-27 19:38:00 +020014106 {
14107 gfc_interface *head, *intr;
Paul Thomascd612e82016-10-26 14:48:02 +000014108
14109 /* Preempt 'gfc_check_new_interface' for submodules, where the
14110 mechanism for handling module procedures winds up resolving
14111 operator interfaces twice and would otherwise cause an error. */
14112 for (intr = derived->ns->op[op]; intr; intr = intr->next)
14113 if (intr->sym == target_proc
14114 && target_proc->attr.used_in_submodule)
14115 return true;
14116
14117 if (!gfc_check_new_interface (derived->ns->op[op],
14118 target_proc, p->where))
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014119 return false;
Janus Weil362aa472012-06-27 19:38:00 +020014120 head = derived->ns->op[op];
14121 intr = gfc_get_interface ();
14122 intr->sym = target_proc;
14123 intr->where = p->where;
14124 intr->next = head;
14125 derived->ns->op[op] = intr;
14126 }
Daniel Kraft94747282009-08-10 12:51:46 +020014127 }
14128
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014129 return true;
Daniel Kraft94747282009-08-10 12:51:46 +020014130
14131error:
14132 p->error = 1;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014133 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020014134}
14135
14136
14137/* Resolve a type-bound user operator (tree-walker callback). */
Daniel Kraft30b608e2008-08-24 18:15:27 +020014138
14139static gfc_symbol* resolve_bindings_derived;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014140static bool resolve_bindings_result;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014141
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014142static bool check_uop_procedure (gfc_symbol* sym, locus where);
Daniel Kraft94747282009-08-10 12:51:46 +020014143
14144static void
14145resolve_typebound_user_op (gfc_symtree* stree)
14146{
14147 gfc_symbol* super_type;
14148 gfc_tbp_generic* target;
14149
14150 gcc_assert (stree && stree->n.tb);
14151
14152 if (stree->n.tb->error)
14153 return;
14154
14155 /* Operators should always be GENERIC bindings. */
14156 gcc_assert (stree->n.tb->is_generic);
14157
14158 /* Find overridden procedure, if any. */
14159 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14160 if (super_type && super_type->f2k_derived)
14161 {
14162 gfc_symtree* overridden;
14163 overridden = gfc_find_typebound_user_op (super_type, NULL,
Daniel Kraft4a44a722009-08-27 13:42:56 +020014164 stree->name, true, NULL);
Daniel Kraft94747282009-08-10 12:51:46 +020014165
14166 if (overridden && overridden->n.tb)
14167 stree->n.tb->overridden = overridden->n.tb;
14168 }
14169 else
14170 stree->n.tb->overridden = NULL;
14171
14172 /* Resolve basically using worker function. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014173 if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name))
Daniel Kraft94747282009-08-10 12:51:46 +020014174 goto error;
14175
14176 /* Check the targets to be functions of correct interface. */
14177 for (target = stree->n.tb->u.generic; target; target = target->next)
14178 {
14179 gfc_symbol* target_proc;
14180
Daniel Kraftb325faf2009-08-17 20:55:30 +020014181 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
14182 if (!target_proc)
14183 goto error;
Daniel Kraft94747282009-08-10 12:51:46 +020014184
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014185 if (!check_uop_procedure (target_proc, stree->n.tb->where))
Daniel Kraft94747282009-08-10 12:51:46 +020014186 goto error;
14187 }
14188
14189 return;
14190
14191error:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014192 resolve_bindings_result = false;
Daniel Kraft94747282009-08-10 12:51:46 +020014193 stree->n.tb->error = 1;
14194}
14195
14196
14197/* Resolve the type-bound procedures for a derived type. */
14198
Daniel Kraft30b608e2008-08-24 18:15:27 +020014199static void
14200resolve_typebound_procedure (gfc_symtree* stree)
14201{
14202 gfc_symbol* proc;
14203 locus where;
14204 gfc_symbol* me_arg;
14205 gfc_symbol* super_type;
Daniel Kraft9d1210f2008-08-25 19:58:53 +020014206 gfc_component* comp;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014207
Daniel Krafte34ccb42009-04-24 17:20:23 +020014208 gcc_assert (stree);
14209
14210 /* Undefined specific symbol from GENERIC target definition. */
14211 if (!stree->n.tb)
14212 return;
14213
14214 if (stree->n.tb->error)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014215 return;
14216
Daniel Krafte157f7362008-08-31 12:00:30 +020014217 /* If this is a GENERIC binding, use that routine. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014218 if (stree->n.tb->is_generic)
Daniel Krafte157f7362008-08-31 12:00:30 +020014219 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014220 if (!resolve_typebound_generic (resolve_bindings_derived, stree))
Daniel Krafte157f7362008-08-31 12:00:30 +020014221 goto error;
14222 return;
14223 }
14224
Daniel Kraft30b608e2008-08-24 18:15:27 +020014225 /* Get the target-procedure to check it. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014226 gcc_assert (!stree->n.tb->is_generic);
14227 gcc_assert (stree->n.tb->u.specific);
14228 proc = stree->n.tb->u.specific->n.sym;
14229 where = stree->n.tb->where;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014230
14231 /* Default access should already be resolved from the parser. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014232 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
Daniel Kraft30b608e2008-08-24 18:15:27 +020014233
Janus Weilb6a45602012-08-02 10:57:58 +020014234 if (stree->n.tb->deferred)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014235 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014236 if (!check_proc_interface (proc, &where))
Janus Weilb6a45602012-08-02 10:57:58 +020014237 goto error;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014238 }
Janus Weilb6a45602012-08-02 10:57:58 +020014239 else
14240 {
Paul Thomas70570ec2019-09-01 12:53:02 +000014241 /* If proc has not been resolved at this point, proc->name may
Steven G. Kargleabd9d92019-08-13 18:35:33 +000014242 actually be a USE associated entity. See PR fortran/89647. */
Mark Egglestondbeaa7a2020-04-23 10:33:14 +010014243 if (!proc->resolve_symbol_called
Steven G. Kargleabd9d92019-08-13 18:35:33 +000014244 && proc->attr.function == 0 && proc->attr.subroutine == 0)
14245 {
14246 gfc_symbol *tmp;
14247 gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp);
14248 if (tmp && tmp->attr.use_assoc)
14249 {
14250 proc->module = tmp->module;
14251 proc->attr.proc = tmp->attr.proc;
14252 proc->attr.function = tmp->attr.function;
14253 proc->attr.subroutine = tmp->attr.subroutine;
14254 proc->attr.use_assoc = tmp->attr.use_assoc;
14255 proc->ts = tmp->ts;
14256 proc->result = tmp->result;
14257 }
14258 }
14259
Janus Weilb6a45602012-08-02 10:57:58 +020014260 /* Check for F08:C465. */
14261 if ((!proc->attr.subroutine && !proc->attr.function)
14262 || (proc->attr.proc != PROC_MODULE
Paul Thomaseaf88372021-01-21 10:00:00 +000014263 && proc->attr.if_source != IFSRC_IFBODY
14264 && !proc->attr.module_procedure)
Janus Weilb6a45602012-08-02 10:57:58 +020014265 || proc->attr.abstract)
14266 {
Steven G. Kargleabd9d92019-08-13 18:35:33 +000014267 gfc_error ("%qs must be a module procedure or an external "
14268 "procedure with an explicit interface at %L",
14269 proc->name, &where);
Janus Weilb6a45602012-08-02 10:57:58 +020014270 goto error;
14271 }
14272 }
14273
Daniel Krafte34ccb42009-04-24 17:20:23 +020014274 stree->n.tb->subroutine = proc->attr.subroutine;
14275 stree->n.tb->function = proc->attr.function;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014276
14277 /* Find the super-type of the current derived type. We could do this once and
14278 store in a global if speed is needed, but as long as not I believe this is
14279 more readable and clearer. */
14280 super_type = gfc_get_derived_super_type (resolve_bindings_derived);
14281
Daniel Krafte157f7362008-08-31 12:00:30 +020014282 /* If PASS, resolve and check arguments if not already resolved / loaded
14283 from a .mod file. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014284 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014285 {
Janus Weil4cbc9032013-01-29 22:40:51 +010014286 gfc_formal_arglist *dummy_args;
14287
14288 dummy_args = gfc_sym_get_dummy_args (proc);
Daniel Krafte34ccb42009-04-24 17:20:23 +020014289 if (stree->n.tb->pass_arg)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014290 {
Janus Weil4cbc9032013-01-29 22:40:51 +010014291 gfc_formal_arglist *i;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014292
14293 /* If an explicit passing argument name is given, walk the arg-list
14294 and look for it. */
14295
14296 me_arg = NULL;
Daniel Krafte34ccb42009-04-24 17:20:23 +020014297 stree->n.tb->pass_arg_num = 1;
Janus Weil4cbc9032013-01-29 22:40:51 +010014298 for (i = dummy_args; i; i = i->next)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014299 {
Daniel Krafte34ccb42009-04-24 17:20:23 +020014300 if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
Daniel Kraft30b608e2008-08-24 18:15:27 +020014301 {
14302 me_arg = i->sym;
14303 break;
14304 }
Daniel Krafte34ccb42009-04-24 17:20:23 +020014305 ++stree->n.tb->pass_arg_num;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014306 }
14307
14308 if (!me_arg)
14309 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014310 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
14311 " argument %qs",
Daniel Krafte34ccb42009-04-24 17:20:23 +020014312 proc->name, stree->n.tb->pass_arg, &where,
14313 stree->n.tb->pass_arg);
Daniel Kraft30b608e2008-08-24 18:15:27 +020014314 goto error;
14315 }
14316 }
14317 else
14318 {
14319 /* Otherwise, take the first one; there should in fact be at least
14320 one. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014321 stree->n.tb->pass_arg_num = 1;
Janus Weil4cbc9032013-01-29 22:40:51 +010014322 if (!dummy_args)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014323 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014324 gfc_error ("Procedure %qs with PASS at %L must have at"
Daniel Kraft30b608e2008-08-24 18:15:27 +020014325 " least one argument", proc->name, &where);
14326 goto error;
14327 }
Janus Weil4cbc9032013-01-29 22:40:51 +010014328 me_arg = dummy_args->sym;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014329 }
14330
Daniel Kraft41a394b2009-12-08 12:39:20 +010014331 /* Now check that the argument-type matches and the passed-object
14332 dummy argument is generally fine. */
14333
Daniel Kraft30b608e2008-08-24 18:15:27 +020014334 gcc_assert (me_arg);
Daniel Kraft41a394b2009-12-08 12:39:20 +010014335
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020014336 if (me_arg->ts.type != BT_CLASS)
14337 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014338 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020014339 " at %L", proc->name, &where);
14340 goto error;
14341 }
14342
Janus Weil7a08eda12010-05-30 23:56:11 +020014343 if (CLASS_DATA (me_arg)->ts.u.derived
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020014344 != resolve_bindings_derived)
Daniel Kraft30b608e2008-08-24 18:15:27 +020014345 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014346 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14347 " the derived-type %qs", me_arg->name, proc->name,
Daniel Kraft30b608e2008-08-24 18:15:27 +020014348 me_arg->name, &where, resolve_bindings_derived->name);
14349 goto error;
14350 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014351
Daniel Kraft41a394b2009-12-08 12:39:20 +010014352 gcc_assert (me_arg->ts.type == BT_CLASS);
Tobias Burnusc62c6622012-07-20 07:56:37 +020014353 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
Daniel Kraft41a394b2009-12-08 12:39:20 +010014354 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014355 gfc_error ("Passed-object dummy argument of %qs at %L must be"
Daniel Kraft41a394b2009-12-08 12:39:20 +010014356 " scalar", proc->name, &where);
14357 goto error;
14358 }
Janus Weil7a08eda12010-05-30 23:56:11 +020014359 if (CLASS_DATA (me_arg)->attr.allocatable)
Daniel Kraft41a394b2009-12-08 12:39:20 +010014360 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014361 gfc_error ("Passed-object dummy argument of %qs at %L must not"
Daniel Kraft41a394b2009-12-08 12:39:20 +010014362 " be ALLOCATABLE", proc->name, &where);
14363 goto error;
14364 }
Janus Weil7a08eda12010-05-30 23:56:11 +020014365 if (CLASS_DATA (me_arg)->attr.class_pointer)
Daniel Kraft41a394b2009-12-08 12:39:20 +010014366 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014367 gfc_error ("Passed-object dummy argument of %qs at %L must not"
Daniel Kraft41a394b2009-12-08 12:39:20 +010014368 " be POINTER", proc->name, &where);
14369 goto error;
14370 }
Daniel Kraft30b608e2008-08-24 18:15:27 +020014371 }
14372
14373 /* If we are extending some type, check that we don't override a procedure
14374 flagged NON_OVERRIDABLE. */
Daniel Krafte34ccb42009-04-24 17:20:23 +020014375 stree->n.tb->overridden = NULL;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014376 if (super_type)
14377 {
14378 gfc_symtree* overridden;
Daniel Kraft8e1f7522008-08-28 20:03:02 +020014379 overridden = gfc_find_typebound_proc (super_type, NULL,
Daniel Kraft4a44a722009-08-27 13:42:56 +020014380 stree->name, true, NULL);
Daniel Kraft30b608e2008-08-24 18:15:27 +020014381
Janus Weil99fc1b92011-08-07 12:12:09 +020014382 if (overridden)
14383 {
14384 if (overridden->n.tb)
14385 stree->n.tb->overridden = overridden->n.tb;
Daniel Krafte157f7362008-08-31 12:00:30 +020014386
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014387 if (!gfc_check_typebound_override (stree, overridden))
Janus Weil99fc1b92011-08-07 12:12:09 +020014388 goto error;
14389 }
Daniel Kraft30b608e2008-08-24 18:15:27 +020014390 }
14391
Daniel Kraft9d1210f2008-08-25 19:58:53 +020014392 /* See if there's a name collision with a component directly in this type. */
14393 for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
14394 if (!strcmp (comp->name, stree->name))
14395 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014396 gfc_error ("Procedure %qs at %L has the same name as a component of"
14397 " %qs",
Daniel Kraft9d1210f2008-08-25 19:58:53 +020014398 stree->name, &where, resolve_bindings_derived->name);
14399 goto error;
14400 }
14401
14402 /* Try to find a name collision with an inherited component. */
Fritz Reesef6288c22016-05-07 23:16:23 +000014403 if (super_type && gfc_find_component (super_type, stree->name, true, true,
14404 NULL))
Daniel Kraft9d1210f2008-08-25 19:58:53 +020014405 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014406 gfc_error ("Procedure %qs at %L has the same name as an inherited"
14407 " component of %qs",
Daniel Kraft9d1210f2008-08-25 19:58:53 +020014408 stree->name, &where, resolve_bindings_derived->name);
14409 goto error;
14410 }
14411
Daniel Krafte34ccb42009-04-24 17:20:23 +020014412 stree->n.tb->error = 0;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014413 return;
14414
14415error:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014416 resolve_bindings_result = false;
Daniel Krafte34ccb42009-04-24 17:20:23 +020014417 stree->n.tb->error = 1;
Daniel Kraft30b608e2008-08-24 18:15:27 +020014418}
14419
Janus Weilbd48f1232010-08-29 23:29:38 +020014420
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014421static bool
Daniel Kraft30b608e2008-08-24 18:15:27 +020014422resolve_typebound_procedures (gfc_symbol* derived)
14423{
Daniel Kraft94747282009-08-10 12:51:46 +020014424 int op;
Janus Weil0291fa22011-07-31 12:25:07 +020014425 gfc_symbol* super_type;
Daniel Kraft94747282009-08-10 12:51:46 +020014426
Daniel Krafte34ccb42009-04-24 17:20:23 +020014427 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014428 return true;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014429
Janus Weil0291fa22011-07-31 12:25:07 +020014430 super_type = gfc_get_derived_super_type (derived);
14431 if (super_type)
Mikael Morin49c8d792013-02-04 19:06:06 +000014432 resolve_symbol (super_type);
Daniel Kraft30b608e2008-08-24 18:15:27 +020014433
14434 resolve_bindings_derived = derived;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014435 resolve_bindings_result = true;
Daniel Kraft94747282009-08-10 12:51:46 +020014436
14437 if (derived->f2k_derived->tb_sym_root)
14438 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
14439 &resolve_typebound_procedure);
14440
Daniel Kraft94747282009-08-10 12:51:46 +020014441 if (derived->f2k_derived->tb_uop_root)
14442 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
14443 &resolve_typebound_user_op);
14444
14445 for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
14446 {
14447 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
Paul Thomas22c23882014-10-18 14:35:51 +000014448 if (p && !resolve_typebound_intrinsic_op (derived,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014449 (gfc_intrinsic_op)op, p))
14450 resolve_bindings_result = false;
Daniel Kraft94747282009-08-10 12:51:46 +020014451 }
Daniel Kraft30b608e2008-08-24 18:15:27 +020014452
14453 return resolve_bindings_result;
14454}
14455
14456
Martin Liskae53b6e52022-01-14 16:57:02 +010014457/* Add a derived type to the dt_list. The dt_list is used in trans-types.cc
Paul Thomas9d5c21c2008-06-17 18:08:24 +000014458 to give all identical derived types the same backend_decl. */
14459static void
14460add_dt_to_dt_list (gfc_symbol *derived)
14461{
Andrew Benson20e8cea2018-07-20 20:00:42 +000014462 if (!derived->dt_next)
14463 {
14464 if (gfc_derived_types)
14465 {
14466 derived->dt_next = gfc_derived_types->dt_next;
14467 gfc_derived_types->dt_next = derived;
14468 }
14469 else
14470 {
14471 derived->dt_next = derived;
14472 }
14473 gfc_derived_types = derived;
14474 }
Paul Thomas9d5c21c2008-06-17 18:08:24 +000014475}
14476
14477
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014478/* Ensure that a derived-type is really not abstract, meaning that every
14479 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
14480
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014481static bool
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014482ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
14483{
14484 if (!st)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014485 return true;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014486
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014487 if (!ensure_not_abstract_walker (sub, st->left))
14488 return false;
14489 if (!ensure_not_abstract_walker (sub, st->right))
14490 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014491
Daniel Krafte34ccb42009-04-24 17:20:23 +020014492 if (st->n.tb && st->n.tb->deferred)
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014493 {
14494 gfc_symtree* overriding;
Daniel Kraft4a44a722009-08-27 13:42:56 +020014495 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
Paul Thomas9c4174d2010-04-20 19:07:14 +000014496 if (!overriding)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014497 return false;
Paul Thomas9c4174d2010-04-20 19:07:14 +000014498 gcc_assert (overriding->n.tb);
Daniel Krafte34ccb42009-04-24 17:20:23 +020014499 if (overriding->n.tb->deferred)
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014500 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010014501 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
14502 " %qs is DEFERRED and not overridden",
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014503 sub->name, &sub->declared_at, st->name);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014504 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014505 }
14506 }
14507
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014508 return true;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014509}
14510
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014511static bool
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014512ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
14513{
14514 /* The algorithm used here is to recursively travel up the ancestry of sub
14515 and for each ancestor-type, check all bindings. If any of them is
14516 DEFERRED, look it up starting from sub and see if the found (overriding)
14517 binding is not DEFERRED.
14518 This is not the most efficient way to do this, but it should be ok and is
14519 clearer than something sophisticated. */
14520
Janus Weil7c9b8fb2010-05-22 12:21:32 +020014521 gcc_assert (ancestor && !sub->attr.abstract);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014522
Janus Weil7c9b8fb2010-05-22 12:21:32 +020014523 if (!ancestor->attr.abstract)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014524 return true;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014525
14526 /* Walk bindings of this ancestor. */
14527 if (ancestor->f2k_derived)
14528 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014529 bool t;
Daniel Krafte34ccb42009-04-24 17:20:23 +020014530 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014531 if (!t)
14532 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014533 }
14534
14535 /* Find next ancestor type and recurse on it. */
14536 ancestor = gfc_get_derived_super_type (ancestor);
14537 if (ancestor)
14538 return ensure_not_abstract (sub, ancestor);
14539
Janne Blomqvist524af0d2013-04-11 00:36:58 +030014540 return true;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020014541}
14542
14543
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014544/* This check for typebound defined assignments is done recursively
14545 since the order in which derived types are resolved is not always in
14546 order of the declarations. */
14547
14548static void
14549check_defined_assignments (gfc_symbol *derived)
14550{
14551 gfc_component *c;
14552
14553 for (c = derived->components; c; c = c->next)
14554 {
Fritz Reesef6288c22016-05-07 23:16:23 +000014555 if (!gfc_bt_struct (c->ts.type)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000014556 || c->attr.pointer
14557 || c->attr.allocatable
14558 || c->attr.proc_pointer_comp
14559 || c->attr.class_pointer
14560 || c->attr.proc_pointer)
14561 continue;
14562
14563 if (c->ts.u.derived->attr.defined_assign_comp
14564 || (c->ts.u.derived->f2k_derived
14565 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
14566 {
14567 derived->attr.defined_assign_comp = 1;
14568 return;
14569 }
14570
14571 check_defined_assignments (c->ts.u.derived);
14572 if (c->ts.u.derived->attr.defined_assign_comp)
14573 {
14574 derived->attr.defined_assign_comp = 1;
14575 return;
14576 }
14577 }
14578}
14579
14580
Fritz Reesef6288c22016-05-07 23:16:23 +000014581/* Resolve a single component of a derived type or structure. */
14582
14583static bool
14584resolve_component (gfc_component *c, gfc_symbol *sym)
14585{
14586 gfc_symbol *super_type;
Thomas Koenig1bd83e02019-01-31 22:21:28 +000014587 symbol_attribute *attr;
Fritz Reesef6288c22016-05-07 23:16:23 +000014588
14589 if (c->attr.artificial)
14590 return true;
14591
Paul Thomasa964d4b2017-11-28 15:13:42 +000014592 /* Do not allow vtype components to be resolved in nameless namespaces
14593 such as block data because the procedure pointers will cause ICEs
14594 and vtables are not needed in these contexts. */
14595 if (sym->attr.vtype && sym->attr.use_assoc
14596 && sym->ns->proc_name == NULL)
Paul Thomasaea5e932017-11-05 12:38:42 +000014597 return true;
14598
Fritz Reesef6288c22016-05-07 23:16:23 +000014599 /* F2008, C442. */
14600 if ((!sym->attr.is_class || c != sym->components)
14601 && c->attr.codimension
14602 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
14603 {
14604 gfc_error ("Coarray component %qs at %L must be allocatable with "
14605 "deferred shape", c->name, &c->loc);
14606 return false;
14607 }
14608
14609 /* F2008, C443. */
14610 if (c->attr.codimension && c->ts.type == BT_DERIVED
14611 && c->ts.u.derived->ts.is_iso_c)
14612 {
14613 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
14614 "shall not be a coarray", c->name, &c->loc);
14615 return false;
14616 }
14617
14618 /* F2008, C444. */
14619 if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
14620 && (c->attr.codimension || c->attr.pointer || c->attr.dimension
14621 || c->attr.allocatable))
14622 {
14623 gfc_error ("Component %qs at %L with coarray component "
14624 "shall be a nonpointer, nonallocatable scalar",
14625 c->name, &c->loc);
14626 return false;
14627 }
14628
14629 /* F2008, C448. */
Thomas Koenig1bd83e02019-01-31 22:21:28 +000014630 if (c->ts.type == BT_CLASS)
14631 {
Harald Anlauf8b6f1e82021-01-06 19:37:11 +010014632 if (c->attr.class_ok && CLASS_DATA (c))
Thomas Koenig1bd83e02019-01-31 22:21:28 +000014633 {
14634 attr = &(CLASS_DATA (c)->attr);
14635
14636 /* Fix up contiguous attribute. */
14637 if (c->attr.contiguous)
14638 attr->contiguous = 1;
14639 }
14640 else
14641 attr = NULL;
14642 }
14643 else
14644 attr = &c->attr;
14645
14646 if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
Fritz Reesef6288c22016-05-07 23:16:23 +000014647 {
14648 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
14649 "is not an array pointer", c->name, &c->loc);
14650 return false;
14651 }
14652
Thomas Koenig3be34c02018-01-29 07:11:16 +000014653 /* F2003, 15.2.1 - length has to be one. */
14654 if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER
14655 && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL
14656 || !gfc_is_constant_expr (c->ts.u.cl->length)
14657 || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0))
14658 {
14659 gfc_error ("Component %qs of BIND(C) type at %L must have length one",
14660 c->name, &c->loc);
14661 return false;
14662 }
14663
Fritz Reesef6288c22016-05-07 23:16:23 +000014664 if (c->attr.proc_pointer && c->ts.interface)
14665 {
14666 gfc_symbol *ifc = c->ts.interface;
14667
14668 if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
14669 {
14670 c->tb->error = 1;
14671 return false;
14672 }
14673
14674 if (ifc->attr.if_source || ifc->attr.intrinsic)
14675 {
14676 /* Resolve interface and copy attributes. */
14677 if (ifc->formal && !ifc->formal_ns)
14678 resolve_symbol (ifc);
14679 if (ifc->attr.intrinsic)
14680 gfc_resolve_intrinsic (ifc, &ifc->declared_at);
14681
14682 if (ifc->result)
14683 {
14684 c->ts = ifc->result->ts;
14685 c->attr.allocatable = ifc->result->attr.allocatable;
14686 c->attr.pointer = ifc->result->attr.pointer;
14687 c->attr.dimension = ifc->result->attr.dimension;
14688 c->as = gfc_copy_array_spec (ifc->result->as);
14689 c->attr.class_ok = ifc->result->attr.class_ok;
14690 }
14691 else
14692 {
14693 c->ts = ifc->ts;
14694 c->attr.allocatable = ifc->attr.allocatable;
14695 c->attr.pointer = ifc->attr.pointer;
14696 c->attr.dimension = ifc->attr.dimension;
14697 c->as = gfc_copy_array_spec (ifc->as);
14698 c->attr.class_ok = ifc->attr.class_ok;
14699 }
14700 c->ts.interface = ifc;
14701 c->attr.function = ifc->attr.function;
14702 c->attr.subroutine = ifc->attr.subroutine;
14703
14704 c->attr.pure = ifc->attr.pure;
14705 c->attr.elemental = ifc->attr.elemental;
14706 c->attr.recursive = ifc->attr.recursive;
14707 c->attr.always_explicit = ifc->attr.always_explicit;
14708 c->attr.ext_attr |= ifc->attr.ext_attr;
14709 /* Copy char length. */
14710 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
14711 {
14712 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
14713 if (cl->length && !cl->resolved
14714 && !gfc_resolve_expr (cl->length))
14715 {
14716 c->tb->error = 1;
14717 return false;
14718 }
14719 c->ts.u.cl = cl;
14720 }
14721 }
14722 }
14723 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
14724 {
14725 /* Since PPCs are not implicitly typed, a PPC without an explicit
14726 interface must be a subroutine. */
14727 gfc_add_subroutine (&c->attr, c->name, &c->loc);
14728 }
14729
14730 /* Procedure pointer components: Check PASS arg. */
14731 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
14732 && !sym->attr.vtype)
14733 {
14734 gfc_symbol* me_arg;
14735
14736 if (c->tb->pass_arg)
14737 {
14738 gfc_formal_arglist* i;
14739
14740 /* If an explicit passing argument name is given, walk the arg-list
14741 and look for it. */
14742
14743 me_arg = NULL;
14744 c->tb->pass_arg_num = 1;
14745 for (i = c->ts.interface->formal; i; i = i->next)
14746 {
14747 if (!strcmp (i->sym->name, c->tb->pass_arg))
14748 {
14749 me_arg = i->sym;
14750 break;
14751 }
14752 c->tb->pass_arg_num++;
14753 }
14754
14755 if (!me_arg)
14756 {
14757 gfc_error ("Procedure pointer component %qs with PASS(%s) "
14758 "at %L has no argument %qs", c->name,
14759 c->tb->pass_arg, &c->loc, c->tb->pass_arg);
14760 c->tb->error = 1;
14761 return false;
14762 }
14763 }
14764 else
14765 {
14766 /* Otherwise, take the first one; there should in fact be at least
14767 one. */
14768 c->tb->pass_arg_num = 1;
14769 if (!c->ts.interface->formal)
14770 {
14771 gfc_error ("Procedure pointer component %qs with PASS at %L "
14772 "must have at least one argument",
14773 c->name, &c->loc);
14774 c->tb->error = 1;
14775 return false;
14776 }
14777 me_arg = c->ts.interface->formal->sym;
14778 }
14779
14780 /* Now check that the argument-type matches. */
14781 gcc_assert (me_arg);
14782 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
14783 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
14784 || (me_arg->ts.type == BT_CLASS
14785 && CLASS_DATA (me_arg)->ts.u.derived != sym))
14786 {
14787 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
14788 " the derived type %qs", me_arg->name, c->name,
14789 me_arg->name, &c->loc, sym->name);
14790 c->tb->error = 1;
14791 return false;
14792 }
14793
Janus Weil24abcc42018-02-12 18:11:58 +010014794 /* Check for F03:C453. */
14795 if (CLASS_DATA (me_arg)->attr.dimension)
Fritz Reesef6288c22016-05-07 23:16:23 +000014796 {
14797 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14798 "must be scalar", me_arg->name, c->name, me_arg->name,
14799 &c->loc);
14800 c->tb->error = 1;
14801 return false;
14802 }
14803
Janus Weil24abcc42018-02-12 18:11:58 +010014804 if (CLASS_DATA (me_arg)->attr.class_pointer)
Fritz Reesef6288c22016-05-07 23:16:23 +000014805 {
14806 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14807 "may not have the POINTER attribute", me_arg->name,
14808 c->name, me_arg->name, &c->loc);
14809 c->tb->error = 1;
14810 return false;
14811 }
14812
Janus Weil24abcc42018-02-12 18:11:58 +010014813 if (CLASS_DATA (me_arg)->attr.allocatable)
Fritz Reesef6288c22016-05-07 23:16:23 +000014814 {
14815 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
14816 "may not be ALLOCATABLE", me_arg->name, c->name,
14817 me_arg->name, &c->loc);
14818 c->tb->error = 1;
14819 return false;
14820 }
14821
14822 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
14823 {
14824 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
14825 " at %L", c->name, &c->loc);
14826 return false;
14827 }
14828
14829 }
14830
14831 /* Check type-spec if this is not the parent-type component. */
14832 if (((sym->attr.is_class
14833 && (!sym->components->ts.u.derived->attr.extension
14834 || c != sym->components->ts.u.derived->components))
14835 || (!sym->attr.is_class
14836 && (!sym->attr.extension || c != sym->components)))
14837 && !sym->attr.vtype
14838 && !resolve_typespec_used (&c->ts, &c->loc, c->name))
14839 return false;
14840
14841 super_type = gfc_get_derived_super_type (sym);
14842
14843 /* If this type is an extension, set the accessibility of the parent
14844 component. */
14845 if (super_type
14846 && ((sym->attr.is_class
14847 && c == sym->components->ts.u.derived->components)
14848 || (!sym->attr.is_class && c == sym->components))
14849 && strcmp (super_type->name, c->name) == 0)
14850 c->attr.access = super_type->attr.access;
14851
14852 /* If this type is an extension, see if this component has the same name
14853 as an inherited type-bound procedure. */
14854 if (super_type && !sym->attr.is_class
14855 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
14856 {
14857 gfc_error ("Component %qs of %qs at %L has the same name as an"
14858 " inherited type-bound procedure",
14859 c->name, sym->name, &c->loc);
14860 return false;
14861 }
14862
14863 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
14864 && !c->ts.deferred)
14865 {
14866 if (c->ts.u.cl->length == NULL
14867 || (!resolve_charlen(c->ts.u.cl))
14868 || !gfc_is_constant_expr (c->ts.u.cl->length))
14869 {
14870 gfc_error ("Character length of component %qs needs to "
14871 "be a constant specification expression at %L",
14872 c->name,
14873 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
14874 return false;
14875 }
14876 }
14877
14878 if (c->ts.type == BT_CHARACTER && c->ts.deferred
14879 && !c->attr.pointer && !c->attr.allocatable)
14880 {
14881 gfc_error ("Character component %qs of %qs at %L with deferred "
14882 "length must be a POINTER or ALLOCATABLE",
14883 c->name, sym->name, &c->loc);
14884 return false;
14885 }
14886
14887 /* Add the hidden deferred length field. */
Paul Thomas5bab4c92017-09-09 11:10:42 +000014888 if (c->ts.type == BT_CHARACTER
14889 && (c->ts.deferred || c->attr.pdt_string)
14890 && !c->attr.function
Fritz Reesef6288c22016-05-07 23:16:23 +000014891 && !sym->attr.is_class)
14892 {
14893 char name[GFC_MAX_SYMBOL_LEN+9];
14894 gfc_component *strlen;
14895 sprintf (name, "_%s_length", c->name);
14896 strlen = gfc_find_component (sym, name, true, true, NULL);
14897 if (strlen == NULL)
14898 {
14899 if (!gfc_add_component (sym, name, &strlen))
14900 return false;
14901 strlen->ts.type = BT_INTEGER;
14902 strlen->ts.kind = gfc_charlen_int_kind;
14903 strlen->attr.access = ACCESS_PRIVATE;
14904 strlen->attr.artificial = 1;
14905 }
14906 }
14907
14908 if (c->ts.type == BT_DERIVED
14909 && sym->component_access != ACCESS_PRIVATE
14910 && gfc_check_symbol_access (sym)
14911 && !is_sym_host_assoc (c->ts.u.derived, sym->ns)
14912 && !c->ts.u.derived->attr.use_assoc
14913 && !gfc_check_symbol_access (c->ts.u.derived)
14914 && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a "
14915 "PRIVATE type and cannot be a component of "
14916 "%qs, which is PUBLIC at %L", c->name,
14917 sym->name, &sym->declared_at))
14918 return false;
14919
14920 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
14921 {
14922 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
14923 "type %s", c->name, &c->loc, sym->name);
14924 return false;
14925 }
14926
14927 if (sym->attr.sequence)
14928 {
14929 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
14930 {
14931 gfc_error ("Component %s of SEQUENCE type declared at %L does "
14932 "not have the SEQUENCE attribute",
14933 c->ts.u.derived->name, &sym->declared_at);
14934 return false;
14935 }
14936 }
14937
14938 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
14939 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
14940 else if (c->ts.type == BT_CLASS && c->attr.class_ok
14941 && CLASS_DATA (c)->ts.u.derived->attr.generic)
14942 CLASS_DATA (c)->ts.u.derived
14943 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
14944
Paul Thomasbf9f15e2016-10-25 20:37:05 +000014945 /* If an allocatable component derived type is of the same type as
14946 the enclosing derived type, we need a vtable generating so that
14947 the __deallocate procedure is created. */
14948 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
14949 && c->ts.u.derived == sym && c->attr.allocatable == 1)
14950 gfc_find_vtab (&c->ts);
14951
Fritz Reesef6288c22016-05-07 23:16:23 +000014952 /* Ensure that all the derived type components are put on the
14953 derived type list; even in formal namespaces, where derived type
14954 pointer components might not have been declared. */
14955 if (c->ts.type == BT_DERIVED
14956 && c->ts.u.derived
14957 && c->ts.u.derived->components
14958 && c->attr.pointer
14959 && sym != c->ts.u.derived)
14960 add_dt_to_dt_list (c->ts.u.derived);
14961
Harald Anlauf9e1e6e62021-01-14 19:21:05 +010014962 if (c->as && c->as->type != AS_DEFERRED
14963 && (c->attr.pointer || c->attr.allocatable))
14964 return false;
14965
Fritz Reesef6288c22016-05-07 23:16:23 +000014966 if (!gfc_resolve_array_spec (c->as,
14967 !(c->attr.pointer || c->attr.proc_pointer
14968 || c->attr.allocatable)))
14969 return false;
14970
14971 if (c->initializer && !sym->attr.vtype
Paul Thomas5bab4c92017-09-09 11:10:42 +000014972 && !c->attr.pdt_kind && !c->attr.pdt_len
Fritz Reesef6288c22016-05-07 23:16:23 +000014973 && !gfc_check_assign_symbol (sym, c, c->initializer))
14974 return false;
14975
14976 return true;
14977}
14978
14979
14980/* Be nice about the locus for a structure expression - show the locus of the
14981 first non-null sub-expression if we can. */
14982
14983static locus *
14984cons_where (gfc_expr *struct_expr)
14985{
14986 gfc_constructor *cons;
14987
14988 gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE);
14989
14990 cons = gfc_constructor_first (struct_expr->value.constructor);
14991 for (; cons; cons = gfc_constructor_next (cons))
14992 {
14993 if (cons->expr && cons->expr->expr_type != EXPR_NULL)
14994 return &cons->expr->where;
14995 }
14996
14997 return &struct_expr->where;
14998}
14999
15000/* Resolve the components of a structure type. Much less work than derived
15001 types. */
15002
15003static bool
15004resolve_fl_struct (gfc_symbol *sym)
15005{
15006 gfc_component *c;
15007 gfc_expr *init = NULL;
15008 bool success;
15009
15010 /* Make sure UNIONs do not have overlapping initializers. */
15011 if (sym->attr.flavor == FL_UNION)
15012 {
15013 for (c = sym->components; c; c = c->next)
15014 {
15015 if (init && c->initializer)
15016 {
15017 gfc_error ("Conflicting initializers in union at %L and %L",
15018 cons_where (init), cons_where (c->initializer));
15019 gfc_free_expr (c->initializer);
15020 c->initializer = NULL;
15021 }
15022 if (init == NULL)
15023 init = c->initializer;
15024 }
15025 }
15026
15027 success = true;
15028 for (c = sym->components; c; c = c->next)
15029 if (!resolve_component (c, sym))
15030 success = false;
15031
15032 if (!success)
15033 return false;
15034
15035 if (sym->components)
15036 add_dt_to_dt_list (sym);
15037
15038 return true;
15039}
15040
15041
Janus Weil0291fa22011-07-31 12:25:07 +020015042/* Resolve the components of a derived type. This does not have to wait until
15043 resolution stage, but can be done as soon as the dt declaration has been
15044 parsed. */
Tobias Schlüter110eec22005-12-22 12:37:03 +010015045
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015046static bool
Janus Weil0291fa22011-07-31 12:25:07 +020015047resolve_fl_derived0 (gfc_symbol *sym)
Tobias Schlüter110eec22005-12-22 12:37:03 +010015048{
Daniel Kraft9d1210f2008-08-25 19:58:53 +020015049 gfc_symbol* super_type;
Tobias Schlüter110eec22005-12-22 12:37:03 +010015050 gfc_component *c;
Paul Thomasde624be2017-10-21 09:02:17 +000015051 gfc_formal_arglist *f;
Fritz Reesef6288c22016-05-07 23:16:23 +000015052 bool success;
Tobias Schlüter110eec22005-12-22 12:37:03 +010015053
Paul Thomas8b704312012-12-20 00:15:00 +000015054 if (sym->attr.unlimited_polymorphic)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015055 return true;
Paul Thomas8b704312012-12-20 00:15:00 +000015056
Daniel Kraft9d1210f2008-08-25 19:58:53 +020015057 super_type = gfc_get_derived_super_type (sym);
15058
Joost VandeVondele1cc0e192014-09-20 11:48:00 +000015059 /* F2008, C432. */
Tobias Burnusbe59db22010-04-06 20:16:13 +020015060 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
15061 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015062 gfc_error ("As extending type %qs at %L has a coarray component, "
15063 "parent type %qs shall also have one", sym->name,
Tobias Burnusbe59db22010-04-06 20:16:13 +020015064 &sym->declared_at, super_type->name);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015065 return false;
Tobias Burnusbe59db22010-04-06 20:16:13 +020015066 }
15067
Daniel Krafte157f7362008-08-31 12:00:30 +020015068 /* Ensure the extended type gets resolved before we do. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015069 if (super_type && !resolve_fl_derived0 (super_type))
15070 return false;
Daniel Krafte157f7362008-08-31 12:00:30 +020015071
Daniel Kraft52f49932008-09-02 10:13:21 +020015072 /* An ABSTRACT type must be extensible. */
Tobias Burnuscf2b3c22009-09-30 21:55:45 +020015073 if (sym->attr.abstract && !gfc_type_is_extensible (sym))
Daniel Kraft52f49932008-09-02 10:13:21 +020015074 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015075 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
Daniel Kraft52f49932008-09-02 10:13:21 +020015076 sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015077 return false;
Daniel Kraft52f49932008-09-02 10:13:21 +020015078 }
15079
Tobias Burnusfac665b2011-12-19 09:15:47 +010015080 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components
15081 : sym->components;
15082
Fritz Reesef6288c22016-05-07 23:16:23 +000015083 success = true;
Tobias Burnusfac665b2011-12-19 09:15:47 +010015084 for ( ; c != NULL; c = c->next)
Fritz Reesef6288c22016-05-07 23:16:23 +000015085 if (!resolve_component (c, sym))
15086 success = false;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020015087
Janus Weilcab283f2015-01-15 19:28:02 +010015088 if (!success)
15089 return false;
15090
Paul Thomasf549bfb2018-01-01 17:36:41 +000015091 /* Now add the caf token field, where needed. */
15092 if (flag_coarray != GFC_FCOARRAY_NONE
15093 && !sym->attr.is_class && !sym->attr.vtype)
15094 {
15095 for (c = sym->components; c; c = c->next)
15096 if (!c->attr.dimension && !c->attr.codimension
15097 && (c->attr.allocatable || c->attr.pointer))
15098 {
15099 char name[GFC_MAX_SYMBOL_LEN+9];
15100 gfc_component *token;
15101 sprintf (name, "_caf_%s", c->name);
15102 token = gfc_find_component (sym, name, true, true, NULL);
15103 if (token == NULL)
15104 {
15105 if (!gfc_add_component (sym, name, &token))
15106 return false;
15107 token->ts.type = BT_VOID;
15108 token->ts.kind = gfc_default_integer_kind;
15109 token->attr.access = ACCESS_PRIVATE;
15110 token->attr.artificial = 1;
15111 token->attr.caf_token = 1;
15112 }
15113 }
15114 }
15115
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015116 check_defined_assignments (sym);
15117
15118 if (!sym->attr.defined_assign_comp && super_type)
15119 sym->attr.defined_assign_comp
15120 = super_type->attr.defined_assign_comp;
15121
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020015122 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
15123 all DEFERRED bindings are overridden. */
15124 if (super_type && super_type->attr.abstract && !sym->attr.abstract
Janus Weil5cd2f812010-06-22 19:07:06 +020015125 && !sym->attr.is_class
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015126 && !ensure_not_abstract (sym, super_type))
15127 return false;
Daniel Kraftb0e5fa92009-03-29 19:47:00 +020015128
Paul Thomasde624be2017-10-21 09:02:17 +000015129 /* Check that there is a component for every PDT parameter. */
15130 if (sym->attr.pdt_template)
15131 {
15132 for (f = sym->formal; f; f = f->next)
15133 {
Paul Thomas276515e2017-12-01 15:05:55 +000015134 if (!f->sym)
15135 continue;
Paul Thomasde624be2017-10-21 09:02:17 +000015136 c = gfc_find_component (sym, f->sym->name, true, true, NULL);
15137 if (c == NULL)
15138 {
15139 gfc_error ("Parameterized type %qs does not have a component "
15140 "corresponding to parameter %qs at %L", sym->name,
15141 f->sym->name, &sym->declared_at);
15142 break;
15143 }
15144 }
15145 }
15146
Paul Thomas6b887792006-09-05 04:26:10 +000015147 /* Add derived type to the derived type list. */
Paul Thomas9d5c21c2008-06-17 18:08:24 +000015148 add_dt_to_dt_list (sym);
Paul Thomas6b887792006-09-05 04:26:10 +000015149
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015150 return true;
Tobias Schlüter110eec22005-12-22 12:37:03 +010015151}
15152
Paul Thomas2ed8d222006-02-13 21:22:55 +000015153
Janus Weil0291fa22011-07-31 12:25:07 +020015154/* The following procedure does the full resolution of a derived type,
15155 including resolution of all type-bound procedures (if present). In contrast
15156 to 'resolve_fl_derived0' this can only be done after the module has been
15157 parsed completely. */
15158
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015159static bool
Janus Weil0291fa22011-07-31 12:25:07 +020015160resolve_fl_derived (gfc_symbol *sym)
15161{
Tobias Burnusc3f34952011-11-16 22:37:43 +010015162 gfc_symbol *gen_dt = NULL;
15163
Paul Thomas8b704312012-12-20 00:15:00 +000015164 if (sym->attr.unlimited_polymorphic)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015165 return true;
Paul Thomas8b704312012-12-20 00:15:00 +000015166
Tobias Burnusc3f34952011-11-16 22:37:43 +010015167 if (!sym->attr.is_class)
15168 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
15169 if (gen_dt && gen_dt->generic && gen_dt->generic->next
Tobias Burnus6ba84c32012-05-04 20:53:17 +020015170 && (!gen_dt->generic->sym->attr.use_assoc
15171 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
Manuel López-Ibáñez2a2703a2015-05-16 12:31:00 +000015172 && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function "
15173 "%qs at %L being the same name as derived "
Paul Thomas22c23882014-10-18 14:35:51 +000015174 "type at %L", sym->name,
15175 gen_dt->generic->sym == sym
15176 ? gen_dt->generic->next->sym->name
15177 : gen_dt->generic->sym->name,
15178 gen_dt->generic->sym == sym
15179 ? &gen_dt->generic->next->sym->declared_at
15180 : &gen_dt->generic->sym->declared_at,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015181 &sym->declared_at))
15182 return false;
Tobias Burnusc3f34952011-11-16 22:37:43 +010015183
Janus Weil0e4cb162018-09-11 19:44:04 +020015184 if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc)
Janus Weil00cad172018-08-22 19:10:00 +020015185 {
15186 gfc_error ("Derived type %qs at %L has not been declared",
15187 sym->name, &sym->declared_at);
15188 return false;
15189 }
15190
Tobias Burnus8e54f132012-09-03 08:35:59 +020015191 /* Resolve the finalizer procedures. */
Tobias Burnuscb414902014-04-12 00:35:47 +020015192 if (!gfc_resolve_finalizers (sym, NULL))
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015193 return false;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015194
Janus Weil0291fa22011-07-31 12:25:07 +020015195 if (sym->attr.is_class && sym->ts.u.derived == NULL)
15196 {
15197 /* Fix up incomplete CLASS symbols. */
Fritz Reesef6288c22016-05-07 23:16:23 +000015198 gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL);
15199 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL);
Paul Thomas8b704312012-12-20 00:15:00 +000015200
15201 /* Nothing more to do for unlimited polymorphic entities. */
15202 if (data->ts.u.derived->attr.unlimited_polymorphic)
Mikael Morinfa5cd712022-04-24 15:05:41 +020015203 {
15204 add_dt_to_dt_list (sym);
15205 return true;
15206 }
Paul Thomas8b704312012-12-20 00:15:00 +000015207 else if (vptr->ts.u.derived == NULL)
Janus Weil0291fa22011-07-31 12:25:07 +020015208 {
15209 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
15210 gcc_assert (vtab);
15211 vptr->ts.u.derived = vtab->ts.u.derived;
Janus Weil477f1452017-05-22 19:08:24 +020015212 if (!resolve_fl_derived0 (vptr->ts.u.derived))
15213 return false;
Janus Weil0291fa22011-07-31 12:25:07 +020015214 }
15215 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015216
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015217 if (!resolve_fl_derived0 (sym))
15218 return false;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015219
Janus Weil0291fa22011-07-31 12:25:07 +020015220 /* Resolve the type-bound procedures. */
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015221 if (!resolve_typebound_procedures (sym))
15222 return false;
Janus Weil0291fa22011-07-31 12:25:07 +020015223
Paul Thomasaea5e932017-11-05 12:38:42 +000015224 /* Generate module vtables subject to their accessibility and their not
15225 being vtables or pdt templates. If this is not done class declarations
15226 in external procedures wind up with their own version and so SELECT TYPE
15227 fails because the vptrs do not have the same address. */
15228 if (gfc_option.allow_std & GFC_STD_F2003
15229 && sym->ns->proc_name
15230 && sym->ns->proc_name->attr.flavor == FL_MODULE
15231 && sym->attr.access != ACCESS_PRIVATE
15232 && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template))
15233 {
15234 gfc_symbol *vtab = gfc_find_derived_vtab (sym);
15235 gfc_set_sym_referenced (vtab);
15236 }
15237
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015238 return true;
Janus Weil0291fa22011-07-31 12:25:07 +020015239}
15240
15241
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015242static bool
Paul Thomas3e1cf502006-02-19 15:24:26 +000015243resolve_fl_namelist (gfc_symbol *sym)
15244{
15245 gfc_namelist *nl;
15246 gfc_symbol *nlsym;
15247
Tobias Burnuse0608472010-09-04 19:47:02 +020015248 for (nl = sym->namelist; nl; nl = nl->next)
15249 {
Tobias Burnus19d36102011-01-26 11:12:47 +010015250 /* Check again, the check in match only works if NAMELIST comes
15251 after the decl. */
15252 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
15253 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015254 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
Tobias Burnus19d36102011-01-26 11:12:47 +010015255 "allowed", nl->sym->name, sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015256 return false;
Tobias Burnus19d36102011-01-26 11:12:47 +010015257 }
15258
Tobias Burnuse0608472010-09-04 19:47:02 +020015259 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015260 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
15261 "with assumed shape in namelist %qs at %L",
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015262 nl->sym->name, sym->name, &sym->declared_at))
15263 return false;
Tobias Burnus19d36102011-01-26 11:12:47 +010015264
15265 if (is_non_constant_shape_array (nl->sym)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015266 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs "
15267 "with nonconstant shape in namelist %qs at %L",
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015268 nl->sym->name, sym->name, &sym->declared_at))
15269 return false;
Tobias Burnus19d36102011-01-26 11:12:47 +010015270
15271 if (nl->sym->ts.type == BT_CHARACTER
15272 && (nl->sym->ts.u.cl->length == NULL
15273 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015274 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with "
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015275 "nonconstant character length in "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015276 "namelist %qs at %L", nl->sym->name,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015277 sym->name, &sym->declared_at))
15278 return false;
Tobias Burnus19d36102011-01-26 11:12:47 +010015279
Tobias Burnuse0608472010-09-04 19:47:02 +020015280 }
15281
Paul Thomas3e1cf502006-02-19 15:24:26 +000015282 /* Reject PRIVATE objects in a PUBLIC namelist. */
Janus Weil6e2062b2011-02-18 11:04:30 +010015283 if (gfc_check_symbol_access (sym))
Paul Thomas3e1cf502006-02-19 15:24:26 +000015284 {
15285 for (nl = sym->namelist; nl; nl = nl->next)
15286 {
Daniel Franke3dbf6532007-08-06 16:53:19 -040015287 if (!nl->sym->attr.use_assoc
Paul Thomasc867b7b2009-04-20 21:55:26 +000015288 && !is_sym_host_assoc (nl->sym, sym->ns)
Janus Weil6e2062b2011-02-18 11:04:30 +010015289 && !gfc_check_symbol_access (nl->sym))
Paul Thomas3e1cf502006-02-19 15:24:26 +000015290 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015291 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
15292 "cannot be member of PUBLIC namelist %qs at %L",
Daniel Franke5cca3202007-07-28 04:51:06 -040015293 nl->sym->name, sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015294 return false;
Daniel Franke5cca3202007-07-28 04:51:06 -040015295 }
15296
Jerry DeLisle628c06d2017-05-11 20:40:49 +000015297 if (nl->sym->ts.type == BT_DERIVED
15298 && (nl->sym->ts.u.derived->attr.alloc_comp
15299 || nl->sym->ts.u.derived->attr.pointer_comp))
15300 {
15301 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
15302 "namelist %qs at %L with ALLOCATABLE "
15303 "or POINTER components", nl->sym->name,
15304 sym->name, &sym->declared_at))
15305 return false;
15306 return true;
15307 }
Paul Thomase73d3ca2016-08-31 05:36:22 +000015308
Daniel Franke3dbf6532007-08-06 16:53:19 -040015309 /* Types with private components that came here by USE-association. */
Daniel Franke5cca3202007-07-28 04:51:06 -040015310 if (nl->sym->ts.type == BT_DERIVED
Janus Weilbc21d312009-08-13 21:46:46 +020015311 && derived_inaccessible (nl->sym->ts.u.derived))
Daniel Franke3dbf6532007-08-06 16:53:19 -040015312 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015313 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
15314 "components and cannot be member of namelist %qs at %L",
Daniel Franke3dbf6532007-08-06 16:53:19 -040015315 nl->sym->name, sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015316 return false;
Daniel Franke3dbf6532007-08-06 16:53:19 -040015317 }
15318
15319 /* Types with private components that are defined in the same module. */
15320 if (nl->sym->ts.type == BT_DERIVED
Janus Weilbc21d312009-08-13 21:46:46 +020015321 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns)
Janus Weil6e2062b2011-02-18 11:04:30 +010015322 && nl->sym->ts.u.derived->attr.private_comp)
Daniel Franke5cca3202007-07-28 04:51:06 -040015323 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015324 gfc_error ("NAMELIST object %qs has PRIVATE components and "
15325 "cannot be a member of PUBLIC namelist %qs at %L",
Daniel Franke5cca3202007-07-28 04:51:06 -040015326 nl->sym->name, sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015327 return false;
Paul Thomas3e1cf502006-02-19 15:24:26 +000015328 }
15329 }
15330 }
15331
Paul Thomas3e1cf502006-02-19 15:24:26 +000015332
15333 /* 14.1.2 A module or internal procedure represent local entities
Paul Thomas847b0532007-05-11 11:42:56 +000015334 of the same type as a namelist member and so are not allowed. */
Paul Thomas3e1cf502006-02-19 15:24:26 +000015335 for (nl = sym->namelist; nl; nl = nl->next)
15336 {
Paul Thomas982186b2006-10-13 12:51:07 +000015337 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
15338 continue;
Paul Thomas847b0532007-05-11 11:42:56 +000015339
15340 if (nl->sym->attr.function && nl->sym == nl->sym->result)
15341 if ((nl->sym == sym->ns->proc_name)
15342 ||
15343 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
15344 continue;
15345
Paul Thomas3e1cf502006-02-19 15:24:26 +000015346 nlsym = NULL;
Tobias Burnus99c25a82012-09-23 08:48:48 +020015347 if (nl->sym->name)
Paul Thomas847b0532007-05-11 11:42:56 +000015348 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
Paul Thomas982186b2006-10-13 12:51:07 +000015349 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
15350 {
15351 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015352 "attribute in %qs at %L", nlsym->name,
Paul Thomas982186b2006-10-13 12:51:07 +000015353 &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015354 return false;
Paul Thomas982186b2006-10-13 12:51:07 +000015355 }
Paul Thomas3e1cf502006-02-19 15:24:26 +000015356 }
15357
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015358 return true;
Paul Thomas3e1cf502006-02-19 15:24:26 +000015359}
15360
15361
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015362static bool
Paul Thomas2ed8d222006-02-13 21:22:55 +000015363resolve_fl_parameter (gfc_symbol *sym)
15364{
15365 /* A parameter array's shape needs to be constant. */
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015366 if (sym->as != NULL
Daniel Frankec317bc42007-07-29 10:17:59 -040015367 && (sym->as->type == AS_DEFERRED
15368 || is_non_constant_shape_array (sym)))
Paul Thomas2ed8d222006-02-13 21:22:55 +000015369 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015370 gfc_error ("Parameter array %qs at %L cannot be automatic "
Daniel Frankec317bc42007-07-29 10:17:59 -040015371 "or of deferred shape", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015372 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000015373 }
15374
Steven G. Karglf2bc4e42016-09-04 20:00:48 +000015375 /* Constraints on deferred type parameter. */
15376 if (!deferred_requirements (sym))
15377 return false;
15378
Paul Thomas2ed8d222006-02-13 21:22:55 +000015379 /* Make sure a parameter that has been implicitly typed still
15380 matches the implicit type, since PARAMETER statements can precede
15381 IMPLICIT statements. */
15382 if (sym->attr.implicit_type
Janus Weil713485c2009-05-06 23:17:16 +020015383 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
15384 sym->ns)))
Paul Thomas2ed8d222006-02-13 21:22:55 +000015385 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015386 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
Paul Thomas2ed8d222006-02-13 21:22:55 +000015387 "later IMPLICIT type", sym->name, &sym->declared_at);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015388 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000015389 }
15390
15391 /* Make sure the types of derived parameters are consistent. This
15392 type checking is deferred until resolution because the type may
15393 refer to a derived type from the host. */
Tobias Burnus22c30bc2012-01-16 20:50:11 +010015394 if (sym->ts.type == BT_DERIVED
Steven G. Kargledf1eac2007-01-20 22:01:41 +000015395 && !gfc_compare_types (&sym->ts, &sym->value->ts))
Paul Thomas2ed8d222006-02-13 21:22:55 +000015396 {
15397 gfc_error ("Incompatible derived type in PARAMETER at %L",
15398 &sym->value->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015399 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000015400 }
Janus Weil103c4f72016-11-08 23:07:21 +010015401
15402 /* F03:C509,C514. */
15403 if (sym->ts.type == BT_CLASS)
15404 {
15405 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute",
15406 sym->name, &sym->declared_at);
15407 return false;
15408 }
15409
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015410 return true;
Paul Thomas2ed8d222006-02-13 21:22:55 +000015411}
15412
15413
Paul Thomas276515e2017-12-01 15:05:55 +000015414/* Called by resolve_symbol to check PDTs. */
Paul Thomas62d3c072017-09-17 18:24:37 +000015415
15416static void
15417resolve_pdt (gfc_symbol* sym)
15418{
15419 gfc_symbol *derived = NULL;
15420 gfc_actual_arglist *param;
15421 gfc_component *c;
15422 bool const_len_exprs = true;
15423 bool assumed_len_exprs = false;
Paul Thomas276515e2017-12-01 15:05:55 +000015424 symbol_attribute *attr;
Paul Thomas62d3c072017-09-17 18:24:37 +000015425
15426 if (sym->ts.type == BT_DERIVED)
Paul Thomas276515e2017-12-01 15:05:55 +000015427 {
15428 derived = sym->ts.u.derived;
15429 attr = &(sym->attr);
15430 }
Paul Thomas62d3c072017-09-17 18:24:37 +000015431 else if (sym->ts.type == BT_CLASS)
Paul Thomas276515e2017-12-01 15:05:55 +000015432 {
15433 derived = CLASS_DATA (sym)->ts.u.derived;
15434 attr = &(CLASS_DATA (sym)->attr);
15435 }
Paul Thomas62d3c072017-09-17 18:24:37 +000015436 else
15437 gcc_unreachable ();
15438
15439 gcc_assert (derived->attr.pdt_type);
15440
15441 for (param = sym->param_list; param; param = param->next)
15442 {
15443 c = gfc_find_component (derived, param->name, false, true, NULL);
15444 gcc_assert (c);
15445 if (c->attr.pdt_kind)
15446 continue;
15447
15448 if (param->expr && !gfc_is_constant_expr (param->expr)
15449 && c->attr.pdt_len)
15450 const_len_exprs = false;
15451 else if (param->spec_type == SPEC_ASSUMED)
15452 assumed_len_exprs = true;
Paul Thomas276515e2017-12-01 15:05:55 +000015453
15454 if (param->spec_type == SPEC_DEFERRED
15455 && !attr->allocatable && !attr->pointer)
15456 gfc_error ("The object %qs at %L has a deferred LEN "
15457 "parameter %qs and is neither allocatable "
15458 "nor a pointer", sym->name, &sym->declared_at,
15459 param->name);
15460
Paul Thomas62d3c072017-09-17 18:24:37 +000015461 }
15462
15463 if (!const_len_exprs
15464 && (sym->ns->proc_name->attr.is_main_program
15465 || sym->ns->proc_name->attr.flavor == FL_MODULE
15466 || sym->attr.save != SAVE_NONE))
15467 gfc_error ("The AUTOMATIC object %qs at %L must not have the "
15468 "SAVE attribute or be a variable declared in the "
15469 "main program, a module or a submodule(F08/C513)",
15470 sym->name, &sym->declared_at);
15471
15472 if (assumed_len_exprs && !(sym->attr.dummy
15473 || sym->attr.select_type_temporary || sym->attr.associate_var))
15474 gfc_error ("The object %qs at %L with ASSUMED type parameters "
15475 "must be a dummy or a SELECT TYPE selector(F08/4.2)",
15476 sym->name, &sym->declared_at);
15477}
15478
15479
Diego Novillo6de9cd92004-05-13 02:41:07 -040015480/* Do anything necessary to resolve a symbol. Right now, we just
15481 assume that an otherwise unknown symbol is a variable. This sort
15482 of thing commonly happens for symbols in module. */
15483
15484static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000015485resolve_symbol (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -040015486{
Paul Thomasa34437a2007-05-08 14:40:58 +000015487 int check_constant, mp_flag;
Steven G. Kargl219fa8c2006-02-03 19:11:27 +000015488 gfc_symtree *symtree;
15489 gfc_symtree *this_symtree;
15490 gfc_namespace *ns;
15491 gfc_component *c;
Tobias Burnusfac665b2011-12-19 09:15:47 +010015492 symbol_attribute class_attr;
15493 gfc_array_spec *as;
Tobias Burnusfd061182012-10-18 19:09:13 +020015494 bool saved_specification_expr;
Diego Novillo6de9cd92004-05-13 02:41:07 -040015495
Mark Egglestondbeaa7a2020-04-23 10:33:14 +010015496 if (sym->resolve_symbol_called >= 1)
Mikael Morin4af8d042013-02-04 18:34:30 +000015497 return;
Mark Egglestondbeaa7a2020-04-23 10:33:14 +010015498 sym->resolve_symbol_called = 1;
Mikael Morin4af8d042013-02-04 18:34:30 +000015499
Fritz Reesef6288c22016-05-07 23:16:23 +000015500 /* No symbol will ever have union type; only components can be unions.
15501 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION
15502 (just like derived type declaration symbols have flavor FL_DERIVED). */
15503 gcc_assert (sym->ts.type != BT_UNION);
15504
Andre Vehreschild6fd9c6f2016-10-14 10:52:10 +020015505 /* Coarrayed polymorphic objects with allocatable or pointer components are
15506 yet unsupported for -fcoarray=lib. */
15507 if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
15508 && sym->ts.u.derived && CLASS_DATA (sym)
15509 && CLASS_DATA (sym)->attr.codimension
Harald Anlauf3cbc0fb2020-06-27 14:56:33 +020015510 && CLASS_DATA (sym)->ts.u.derived
Andre Vehreschild6479f452016-12-13 17:47:48 +010015511 && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
15512 || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
Andre Vehreschild6fd9c6f2016-10-14 10:52:10 +020015513 {
15514 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) "
15515 "type coarrays at %L are unsupported", &sym->declared_at);
15516 return;
15517 }
15518
Tobias Burnus8e54f132012-09-03 08:35:59 +020015519 if (sym->attr.artificial)
15520 return;
15521
Paul Thomas8b704312012-12-20 00:15:00 +000015522 if (sym->attr.unlimited_polymorphic)
15523 return;
15524
Tobias Burnus4f94c382022-05-17 11:01:04 +020015525 if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0))
15526 {
15527 gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
15528 "the OpenMP DEPEND clause", &sym->declared_at);
15529 return;
15530 }
15531
Tobias Burnus60fa3932012-04-11 15:08:32 +020015532 if (sym->attr.flavor == FL_UNKNOWN
15533 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
15534 && !sym->attr.generic && !sym->attr.external
Janus Weil6bd59682013-12-30 18:33:21 +010015535 && sym->attr.if_source == IFSRC_UNKNOWN
15536 && sym->ts.type == BT_UNKNOWN))
Diego Novillo6de9cd92004-05-13 02:41:07 -040015537 {
Paul Thomas24d36d22005-07-19 20:13:53 +000015538
15539 /* If we find that a flavorless symbol is an interface in one of the
15540 parent namespaces, find its symtree in this namespace, free the
15541 symbol and set the symtree to point to the interface symbol. */
15542 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
15543 {
15544 symtree = gfc_find_symtree (ns->sym_root, sym->name);
Janus Weil7ca17032010-12-17 13:31:54 +010015545 if (symtree && (symtree->n.sym->generic ||
15546 (symtree->n.sym->attr.flavor == FL_PROCEDURE
15547 && sym->ns->construct_entities)))
Paul Thomas24d36d22005-07-19 20:13:53 +000015548 {
15549 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
15550 sym->name);
Mikael Morin511820a2015-03-08 11:52:51 +000015551 if (this_symtree->n.sym == sym)
15552 {
15553 symtree->n.sym->refs++;
15554 gfc_release_symbol (sym);
15555 this_symtree->n.sym = symtree->n.sym;
15556 return;
15557 }
Paul Thomas24d36d22005-07-19 20:13:53 +000015558 }
15559 }
15560
15561 /* Otherwise give it a flavor according to such attributes as
15562 it has. */
Tobias Burnus60fa3932012-04-11 15:08:32 +020015563 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0
15564 && sym->attr.intrinsic == 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -040015565 sym->attr.flavor = FL_VARIABLE;
Tobias Burnus60fa3932012-04-11 15:08:32 +020015566 else if (sym->attr.flavor == FL_UNKNOWN)
Diego Novillo6de9cd92004-05-13 02:41:07 -040015567 {
15568 sym->attr.flavor = FL_PROCEDURE;
15569 if (sym->attr.dimension)
15570 sym->attr.function = 1;
15571 }
15572 }
15573
Janus Weilc73b6472009-04-22 11:05:58 +020015574 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function)
15575 gfc_add_function (&sym->attr, sym->name, &sym->declared_at);
15576
Janus Weil0e8d8542012-07-31 20:32:41 +020015577 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015578 && !resolve_procedure_interface (sym))
Janus Weil2fcac972010-08-23 14:26:42 +020015579 return;
Janus Weil69773742007-09-04 13:50:35 +000015580
Tobias Burnusc064bf12010-06-08 08:37:32 +020015581 if (sym->attr.is_protected && !sym->attr.proc_pointer
15582 && (sym->attr.procedure || sym->attr.external))
15583 {
15584 if (sym->attr.external)
15585 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
15586 "at %L", &sym->declared_at);
15587 else
15588 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
15589 "at %L", &sym->declared_at);
15590
15591 return;
15592 }
15593
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015594 if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym))
Tobias Schlüter110eec22005-12-22 12:37:03 +010015595 return;
15596
Fritz Reesef6288c22016-05-07 23:16:23 +000015597 else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
15598 && !resolve_fl_struct (sym))
15599 return;
15600
Diego Novillo6de9cd92004-05-13 02:41:07 -040015601 /* Symbols that are module procedures with results (functions) have
15602 the types and array specification copied for type checking in
15603 procedures that call them, as well as for saving to a module
15604 file. These symbols can't stand the scrutiny that their results
15605 can. */
15606 mp_flag = (sym->result != NULL && sym->result != sym);
15607
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015608 /* Make sure that the intrinsic is consistent with its internal
15609 representation. This needs to be done before assigning a default
Daniel Frankeeb2c5982007-06-30 12:26:55 -040015610 type to avoid spurious warnings. */
Janus Weilf6038132009-08-13 13:16:16 +020015611 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015612 && !gfc_resolve_intrinsic (sym, &sym->declared_at))
Janus Weilf6038132009-08-13 13:16:16 +020015613 return;
Daniel Frankeeb2c5982007-06-30 12:26:55 -040015614
Daniel Kraft3e782382010-08-26 21:48:43 +020015615 /* Resolve associate names. */
Daniel Kraft03af1e42010-06-10 16:47:49 +020015616 if (sym->assoc)
Daniel Kraft3e782382010-08-26 21:48:43 +020015617 resolve_assoc_var (sym, true);
Daniel Kraft03af1e42010-06-10 16:47:49 +020015618
Diego Novillo6de9cd92004-05-13 02:41:07 -040015619 /* Assign default type to symbols that need one and don't have one. */
15620 if (sym->ts.type == BT_UNKNOWN)
15621 {
15622 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
Tobias Burnusfac665b2011-12-19 09:15:47 +010015623 {
15624 gfc_set_default_type (sym, 1, NULL);
15625 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040015626
Janus Weilfc9c6e52009-06-27 00:11:15 +020015627 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
15628 && !sym->attr.function && !sym->attr.subroutine
15629 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN)
15630 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at);
15631
Diego Novillo6de9cd92004-05-13 02:41:07 -040015632 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
15633 {
Paul Thomas53096252005-11-01 05:53:29 +000015634 /* The specific case of an external procedure should emit an error
15635 in the case that there is no implicit type. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040015636 if (!mp_flag)
Louis Krupp6e48e772016-10-05 18:00:30 +000015637 {
15638 if (!sym->attr.mixed_entry_master)
15639 gfc_set_default_type (sym, sym->attr.external, NULL);
15640 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040015641 else
15642 {
Steven G. Kargledf1eac2007-01-20 22:01:41 +000015643 /* Result may be in another namespace. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040015644 resolve_symbol (sym->result);
15645
Janus Weil3070bab2009-04-09 11:39:09 +020015646 if (!sym->result->attr.proc_pointer)
15647 {
15648 sym->ts = sym->result->ts;
15649 sym->as = gfc_copy_array_spec (sym->result->as);
15650 sym->attr.dimension = sym->result->attr.dimension;
15651 sym->attr.pointer = sym->result->attr.pointer;
15652 sym->attr.allocatable = sym->result->attr.allocatable;
Tobias Burnusfe4e5252010-06-21 16:15:56 +020015653 sym->attr.contiguous = sym->result->attr.contiguous;
Janus Weil3070bab2009-04-09 11:39:09 +020015654 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040015655 }
15656 }
15657 }
Mikael Morine3d748d2011-07-07 22:58:16 +020015658 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
Tobias Burnusfd061182012-10-18 19:09:13 +020015659 {
15660 bool saved_specification_expr = specification_expr;
Paul Thomas7ae210d2020-12-05 14:14:19 +000015661 bool saved_formal_arg_flag = formal_arg_flag;
15662
Tobias Burnusfd061182012-10-18 19:09:13 +020015663 specification_expr = true;
Paul Thomas7ae210d2020-12-05 14:14:19 +000015664 formal_arg_flag = true;
Tobias Burnusfd061182012-10-18 19:09:13 +020015665 gfc_resolve_array_spec (sym->result->as, false);
Paul Thomas7ae210d2020-12-05 14:14:19 +000015666 formal_arg_flag = saved_formal_arg_flag;
Tobias Burnusfd061182012-10-18 19:09:13 +020015667 specification_expr = saved_specification_expr;
15668 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040015669
Harald Anlauf70c884a2020-07-10 21:35:35 +020015670 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
Tobias Burnusfac665b2011-12-19 09:15:47 +010015671 {
15672 as = CLASS_DATA (sym)->as;
15673 class_attr = CLASS_DATA (sym)->attr;
15674 class_attr.pointer = class_attr.class_pointer;
15675 }
15676 else
15677 {
15678 class_attr = sym->attr;
15679 as = sym->as;
15680 }
15681
Joost VandeVondele1cc0e192014-09-20 11:48:00 +000015682 /* F2008, C530. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010015683 if (sym->attr.contiguous
15684 && (!class_attr.dimension
Tobias Burnus8e54f132012-09-03 08:35:59 +020015685 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
15686 && !class_attr.pointer)))
Tobias Burnusfac665b2011-12-19 09:15:47 +010015687 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015688 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
Tobias Burnus8e54f132012-09-03 08:35:59 +020015689 "array pointer or an assumed-shape or assumed-rank array",
15690 sym->name, &sym->declared_at);
Tobias Burnusfac665b2011-12-19 09:15:47 +010015691 return;
15692 }
15693
Tobias Schlüterf5e440e2004-06-21 19:23:52 +020015694 /* Assumed size arrays and assumed shape arrays must be dummy
Daniel Kraftf5ca06e2010-08-13 09:26:05 +020015695 arguments. Array-spec's of implied-shape should have been resolved to
15696 AS_EXPLICIT already. */
Tobias Schlüterf5e440e2004-06-21 19:23:52 +020015697
Tobias Burnusfac665b2011-12-19 09:15:47 +010015698 if (as)
Diego Novillo6de9cd92004-05-13 02:41:07 -040015699 {
Thomas Koenigb04bebd2017-10-18 20:32:34 +000015700 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad
15701 specification expression. */
15702 if (as->type == AS_IMPLIED_SHAPE)
15703 {
15704 int i;
15705 for (i=0; i<as->rank; i++)
15706 {
15707 if (as->lower[i] != NULL && as->upper[i] == NULL)
15708 {
15709 gfc_error ("Bad specification for assumed size array at %L",
15710 &as->lower[i]->where);
15711 return;
15712 }
15713 }
15714 gcc_unreachable();
15715 }
15716
Tobias Burnusfac665b2011-12-19 09:15:47 +010015717 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
15718 || as->type == AS_ASSUMED_SHAPE)
Paul Thomas4cc70462012-12-21 14:29:34 +000015719 && !sym->attr.dummy && !sym->attr.select_type_temporary)
Daniel Kraftf5ca06e2010-08-13 09:26:05 +020015720 {
Tobias Burnusfac665b2011-12-19 09:15:47 +010015721 if (as->type == AS_ASSUMED_SIZE)
Daniel Kraftf5ca06e2010-08-13 09:26:05 +020015722 gfc_error ("Assumed size array at %L must be a dummy argument",
15723 &sym->declared_at);
15724 else
15725 gfc_error ("Assumed shape array at %L must be a dummy argument",
15726 &sym->declared_at);
15727 return;
15728 }
Tobias Burnusc62c6622012-07-20 07:56:37 +020015729 /* TS 29113, C535a. */
Paul Thomas4cc70462012-12-21 14:29:34 +000015730 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
Paul Thomas70570ec2019-09-01 12:53:02 +000015731 && !sym->attr.select_type_temporary
15732 && !(cs_base && cs_base->current
15733 && cs_base->current->op == EXEC_SELECT_RANK))
Tobias Burnusc62c6622012-07-20 07:56:37 +020015734 {
15735 gfc_error ("Assumed-rank array at %L must be a dummy argument",
15736 &sym->declared_at);
15737 return;
15738 }
15739 if (as->type == AS_ASSUMED_RANK
15740 && (sym->attr.codimension || sym->attr.value))
15741 {
15742 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
15743 "CODIMENSION attribute", &sym->declared_at);
15744 return;
15745 }
Tobias Schlütera4ac5dd2004-06-09 14:35:39 +020015746 }
15747
Diego Novillo6de9cd92004-05-13 02:41:07 -040015748 /* Make sure symbols with known intent or optional are really dummy
15749 variable. Because of ENTRY statement, this has to be deferred
15750 until resolution time. */
15751
Paul Thomas2ed8d222006-02-13 21:22:55 +000015752 if (!sym->attr.dummy
Steven G. Kargledf1eac2007-01-20 22:01:41 +000015753 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
Diego Novillo6de9cd92004-05-13 02:41:07 -040015754 {
15755 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
15756 return;
15757 }
15758
Paul Thomas06469ef2006-12-03 07:18:22 +000015759 if (sym->attr.value && !sym->attr.dummy)
15760 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015761 gfc_error ("%qs at %L cannot have the VALUE attribute because "
Tobias Burnus1084b6b2007-02-20 10:16:58 +010015762 "it is not a dummy argument", sym->name, &sym->declared_at);
Paul Thomas06469ef2006-12-03 07:18:22 +000015763 return;
15764 }
15765
Tobias Burnus1084b6b2007-02-20 10:16:58 +010015766 if (sym->attr.value && sym->ts.type == BT_CHARACTER)
15767 {
Janus Weilbc21d312009-08-13 21:46:46 +020015768 gfc_charlen *cl = sym->ts.u.cl;
Tobias Burnus1084b6b2007-02-20 10:16:58 +010015769 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
15770 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015771 gfc_error ("Character dummy variable %qs at %L with VALUE "
Tobias Burnus1084b6b2007-02-20 10:16:58 +010015772 "attribute must have constant length",
15773 sym->name, &sym->declared_at);
15774 return;
15775 }
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015776
15777 if (sym->ts.is_c_interop
15778 && mpz_cmp_si (cl->length->value.integer, 1) != 0)
15779 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015780 gfc_error ("C interoperable character dummy variable %qs at %L "
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015781 "with VALUE attribute must have length one",
15782 sym->name, &sym->declared_at);
15783 return;
15784 }
15785 }
15786
Tobias Burnusc3f34952011-11-16 22:37:43 +010015787 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
15788 && sym->ts.u.derived->attr.generic)
15789 {
15790 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
15791 if (!sym->ts.u.derived)
15792 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015793 gfc_error ("The derived type %qs at %L is of type %qs, "
Tobias Burnusc3f34952011-11-16 22:37:43 +010015794 "which has not been defined", sym->name,
15795 &sym->declared_at, sym->ts.u.derived->name);
15796 sym->ts.type = BT_UNKNOWN;
15797 return;
15798 }
15799 }
15800
Tobias Burnuse7ac6a72013-04-16 22:54:21 +020015801 /* Use the same constraints as TYPE(*), except for the type check
15802 and that only scalars and assumed-size arrays are permitted. */
15803 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
15804 {
15805 if (!sym->attr.dummy)
15806 {
15807 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15808 "a dummy argument", sym->name, &sym->declared_at);
15809 return;
15810 }
15811
15812 if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER
15813 && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL
15814 && sym->ts.type != BT_COMPLEX)
15815 {
15816 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
15817 "of type TYPE(*) or of an numeric intrinsic type",
15818 sym->name, &sym->declared_at);
15819 return;
15820 }
15821
15822 if (sym->attr.allocatable || sym->attr.codimension
15823 || sym->attr.pointer || sym->attr.value)
15824 {
15825 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15826 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
15827 "attribute", sym->name, &sym->declared_at);
15828 return;
15829 }
15830
15831 if (sym->attr.intent == INTENT_OUT)
15832 {
15833 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
15834 "have the INTENT(OUT) attribute",
15835 sym->name, &sym->declared_at);
15836 return;
15837 }
15838 if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE)
15839 {
15840 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
15841 "either be a scalar or an assumed-size array",
15842 sym->name, &sym->declared_at);
15843 return;
15844 }
15845
15846 /* Set the type to TYPE(*) and add a dimension(*) to ensure
15847 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
15848 packing. */
15849 sym->ts.type = BT_ASSUMED;
15850 sym->as = gfc_get_array_spec ();
15851 sym->as->type = AS_ASSUMED_SIZE;
15852 sym->as->rank = 1;
15853 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
15854 }
15855 else if (sym->ts.type == BT_ASSUMED)
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015856 {
Tobias Burnus45a69322012-03-03 09:40:24 +010015857 /* TS 29113, C407a. */
15858 if (!sym->attr.dummy)
15859 {
15860 gfc_error ("Assumed type of variable %s at %L is only permitted "
15861 "for dummy variables", sym->name, &sym->declared_at);
15862 return;
15863 }
15864 if (sym->attr.allocatable || sym->attr.codimension
15865 || sym->attr.pointer || sym->attr.value)
15866 {
15867 gfc_error ("Assumed-type variable %s at %L may not have the "
15868 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
15869 sym->name, &sym->declared_at);
15870 return;
15871 }
Tobias Burnusc62c6622012-07-20 07:56:37 +020015872 if (sym->attr.intent == INTENT_OUT)
15873 {
15874 gfc_error ("Assumed-type variable %s at %L may not have the "
15875 "INTENT(OUT) attribute",
15876 sym->name, &sym->declared_at);
15877 return;
15878 }
Tobias Burnus45a69322012-03-03 09:40:24 +010015879 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
15880 {
15881 gfc_error ("Assumed-type variable %s at %L shall not be an "
15882 "explicit-shape array", sym->name, &sym->declared_at);
15883 return;
15884 }
15885 }
15886
Thomas Koenigc4fa8982017-08-11 17:45:36 +000015887 /* If the symbol is marked as bind(c), that it is declared at module level
15888 scope and verify its type and kind. Do not do the latter for symbols
15889 that are implicitly typed because that is handled in
15890 gfc_set_default_type. Handle dummy arguments and procedure definitions
15891 separately. Also, anything that is use associated is not handled here
15892 but instead is handled in the module it is declared in. Finally, derived
15893 type definitions are allowed to be BIND(C) since that only implies that
15894 they're interoperable, and they are checked fully for interoperability
15895 when a variable is declared of that type. */
15896 if (sym->attr.is_bind_c && sym->attr.use_assoc == 0
15897 && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE
15898 && sym->attr.flavor != FL_DERIVED)
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015899 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015900 bool t = true;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015901
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015902 /* First, make sure the variable is declared at the
15903 module-level scope (J3/04-007, Section 15.3). */
15904 if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
15905 sym->attr.in_common == 0)
15906 {
Manuel López-Ibáñezc4100ea2014-12-11 15:13:33 +000015907 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015908 "is neither a COMMON block nor declared at the "
15909 "module level scope", sym->name, &(sym->declared_at));
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015910 t = false;
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015911 }
Thomas Koenig3be34c02018-01-29 07:11:16 +000015912 else if (sym->ts.type == BT_CHARACTER
15913 && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL
15914 || !gfc_is_constant_expr (sym->ts.u.cl->length)
15915 || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0))
15916 {
15917 gfc_error ("BIND(C) Variable %qs at %L must have length one",
15918 sym->name, &sym->declared_at);
15919 t = false;
15920 }
Thomas Koenigc4fa8982017-08-11 17:45:36 +000015921 else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015922 {
15923 t = verify_com_block_vars_c_interop (sym->common_head);
15924 }
Thomas Koenigc4fa8982017-08-11 17:45:36 +000015925 else if (sym->attr.implicit_type == 0)
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015926 {
15927 /* If type() declaration, we need to verify that the components
15928 of the given type are all C interoperable, etc. */
15929 if (sym->ts.type == BT_DERIVED &&
Janus Weilbc21d312009-08-13 21:46:46 +020015930 sym->ts.u.derived->attr.is_c_interop != 1)
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015931 {
15932 /* Make sure the user marked the derived type as BIND(C). If
15933 not, call the verify routine. This could print an error
15934 for the derived type more than once if multiple variables
15935 of that type are declared. */
Janus Weilbc21d312009-08-13 21:46:46 +020015936 if (sym->ts.u.derived->attr.is_bind_c != 1)
15937 verify_bind_c_derived_type (sym->ts.u.derived);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015938 t = false;
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015939 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000015940
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015941 /* Verify the variable itself as C interoperable if it
15942 is BIND(C). It is not possible for this to succeed if
15943 the verify_bind_c_derived_type failed, so don't have to handle
15944 any error returned by verify_bind_c_derived_type. */
15945 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
15946 sym->common_block);
15947 }
15948
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015949 if (!t)
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000015950 {
15951 /* clear the is_bind_c flag to prevent reporting errors more than
15952 once if something failed. */
15953 sym->attr.is_bind_c = 0;
15954 return;
15955 }
Tobias Burnus1084b6b2007-02-20 10:16:58 +010015956 }
15957
Paul Thomas976e21f2005-10-26 05:20:19 +000015958 /* If a derived type symbol has reached this point, without its
15959 type being declared, we have an error. Notice that most
15960 conditions that produce undefined derived types have already
15961 been dealt with. However, the likes of:
15962 implicit type(t) (t) ..... call foo (t) will get us here if
15963 the type is not declared in the scope of the implicit
15964 statement. Change the type to BT_UNKNOWN, both because it is so
15965 and to prevent an ICE. */
Tobias Burnusc3f34952011-11-16 22:37:43 +010015966 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
15967 && sym->ts.u.derived->components == NULL
Janus Weilbc21d312009-08-13 21:46:46 +020015968 && !sym->ts.u.derived->attr.zero_comp)
Paul Thomas976e21f2005-10-26 05:20:19 +000015969 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015970 gfc_error ("The derived type %qs at %L is of type %qs, "
Brooks Mosese25a0da2006-11-16 03:05:28 +000015971 "which has not been defined", sym->name,
Janus Weilbc21d312009-08-13 21:46:46 +020015972 &sym->declared_at, sym->ts.u.derived->name);
Paul Thomas976e21f2005-10-26 05:20:19 +000015973 sym->ts.type = BT_UNKNOWN;
15974 return;
15975 }
15976
Paul Thomasc1203a72008-03-24 19:11:24 +000015977 /* Make sure that the derived type has been resolved and that the
15978 derived type is visible in the symbol's namespace, if it is a
15979 module function and is not PRIVATE. */
15980 if (sym->ts.type == BT_DERIVED
Janus Weilbc21d312009-08-13 21:46:46 +020015981 && sym->ts.u.derived->attr.use_assoc
Thomas Koenig96ffc6c2009-01-05 10:43:39 +000015982 && sym->ns->proc_name
Tobias Burnusc3f34952011-11-16 22:37:43 +010015983 && sym->ns->proc_name->attr.flavor == FL_MODULE
Janne Blomqvist524af0d2013-04-11 00:36:58 +030015984 && !resolve_fl_derived (sym->ts.u.derived))
Tobias Burnusc3f34952011-11-16 22:37:43 +010015985 return;
Paul Thomasc1203a72008-03-24 19:11:24 +000015986
Tobias Burnusa08a5752007-09-17 17:55:22 +020015987 /* Unless the derived-type declaration is use associated, Fortran 95
15988 does not allow public entries of private derived types.
15989 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
15990 161 in 95-006r3. */
15991 if (sym->ts.type == BT_DERIVED
Tobias Burnus72052232007-12-14 16:14:29 +010015992 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE
Janus Weilbc21d312009-08-13 21:46:46 +020015993 && !sym->ts.u.derived->attr.use_assoc
Janus Weil6e2062b2011-02-18 11:04:30 +010015994 && gfc_check_symbol_access (sym)
15995 && !gfc_check_symbol_access (sym->ts.u.derived)
Tobias Burnusa4d9b222014-12-13 00:12:06 +010015996 && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE "
15997 "derived type %qs",
Paul Thomas22c23882014-10-18 14:35:51 +000015998 (sym->attr.flavor == FL_PARAMETER)
15999 ? "parameter" : "variable",
16000 sym->name, &sym->declared_at,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016001 sym->ts.u.derived->name))
Tobias Burnusa08a5752007-09-17 17:55:22 +020016002 return;
16003
Tobias Burnusfea54932011-06-20 23:12:39 +020016004 /* F2008, C1302. */
16005 if (sym->ts.type == BT_DERIVED
Tobias Burnus3b6fa7a2011-08-18 17:10:25 +020016006 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16007 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
16008 || sym->ts.u.derived->attr.lock_comp)
16009 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
Tobias Burnusfea54932011-06-20 23:12:39 +020016010 {
Tobias Burnus3b6fa7a2011-08-18 17:10:25 +020016011 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
16012 "type LOCK_TYPE must be a coarray", sym->name,
16013 &sym->declared_at);
Tobias Burnusfea54932011-06-20 23:12:39 +020016014 return;
16015 }
16016
Tobias Burnus5df445a2015-12-02 22:59:05 +010016017 /* TS18508, C702/C703. */
16018 if (sym->ts.type == BT_DERIVED
16019 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
16020 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
16021 || sym->ts.u.derived->attr.event_comp)
16022 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
16023 {
16024 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
Dominique d'Humieres370d9752017-07-03 20:03:51 +020016025 "type EVENT_TYPE must be a coarray", sym->name,
Tobias Burnus5df445a2015-12-02 22:59:05 +010016026 &sym->declared_at);
16027 return;
16028 }
16029
Paul Thomas4213f932005-10-17 20:52:37 +000016030 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
16031 default initialization is defined (5.1.2.4.4). */
16032 if (sym->ts.type == BT_DERIVED
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016033 && sym->attr.dummy
16034 && sym->attr.intent == INTENT_OUT
16035 && sym->as
16036 && sym->as->type == AS_ASSUMED_SIZE)
Paul Thomas4213f932005-10-17 20:52:37 +000016037 {
Janus Weilbc21d312009-08-13 21:46:46 +020016038 for (c = sym->ts.u.derived->components; c; c = c->next)
Paul Thomas4213f932005-10-17 20:52:37 +000016039 {
16040 if (c->initializer)
16041 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016042 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
Paul Thomas4213f932005-10-17 20:52:37 +000016043 "ASSUMED SIZE and so cannot have a default initializer",
16044 sym->name, &sym->declared_at);
16045 return;
16046 }
16047 }
16048 }
16049
Tobias Burnusfea54932011-06-20 23:12:39 +020016050 /* F2008, C542. */
16051 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16052 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016053 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016054 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016055 "INTENT(OUT)", sym->name, &sym->declared_at);
16056 return;
16057 }
Tobias Burnusfea54932011-06-20 23:12:39 +020016058
Tobias Burnus5df445a2015-12-02 22:59:05 +010016059 /* TS18508. */
16060 if (sym->ts.type == BT_DERIVED && sym->attr.dummy
16061 && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
16062 {
16063 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
16064 "INTENT(OUT)", sym->name, &sym->declared_at);
16065 return;
16066 }
16067
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016068 /* F2008, C525. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010016069 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16070 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +020016071 && sym->ts.u.derived && CLASS_DATA (sym)
Tobias Burnusfac665b2011-12-19 09:15:47 +010016072 && CLASS_DATA (sym)->attr.coarray_comp))
16073 || class_attr.codimension)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016074 && (sym->attr.result || sym->result == sym))
16075 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016076 gfc_error ("Function result %qs at %L shall not be a coarray or have "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016077 "a coarray component", sym->name, &sym->declared_at);
16078 return;
16079 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016080
16081 /* F2008, C524. */
16082 if (sym->attr.codimension && sym->ts.type == BT_DERIVED
16083 && sym->ts.u.derived->ts.is_iso_c)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016084 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016085 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016086 "shall not be a coarray", sym->name, &sym->declared_at);
16087 return;
16088 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016089
16090 /* F2008, C525. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010016091 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16092 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +020016093 && sym->ts.u.derived && CLASS_DATA (sym)
Tobias Burnusfac665b2011-12-19 09:15:47 +010016094 && CLASS_DATA (sym)->attr.coarray_comp))
16095 && (class_attr.codimension || class_attr.pointer || class_attr.dimension
16096 || class_attr.allocatable))
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016097 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016098 gfc_error ("Variable %qs at %L with coarray component shall be a "
Tobias Burnusabc2d802013-07-15 10:25:48 +020016099 "nonpointer, nonallocatable scalar, which is not a coarray",
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016100 sym->name, &sym->declared_at);
16101 return;
16102 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016103
16104 /* F2008, C526. The function-result case was handled above. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010016105 if (class_attr.codimension
16106 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
16107 || sym->attr.select_type_temporary
Paul Thomasb89a63b2017-09-21 18:40:21 +000016108 || sym->attr.associate_var
Fritz Reese34d567d2016-09-23 21:06:18 +000016109 || (sym->ns->save_all && !sym->attr.automatic)
Tobias Burnusbe59db22010-04-06 20:16:13 +020016110 || sym->ns->proc_name->attr.flavor == FL_MODULE
16111 || sym->ns->proc_name->attr.is_main_program
16112 || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016113 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016114 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016115 "nor a dummy argument", sym->name, &sym->declared_at);
16116 return;
16117 }
Tobias Burnusfac665b2011-12-19 09:15:47 +010016118 /* F2008, C528. */
16119 else if (class_attr.codimension && !sym->attr.select_type_temporary
16120 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016121 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016122 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016123 "deferred shape", sym->name, &sym->declared_at);
16124 return;
16125 }
Tobias Burnusfac665b2011-12-19 09:15:47 +010016126 else if (class_attr.codimension && class_attr.allocatable && as
16127 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED))
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016128 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016129 gfc_error ("Allocatable coarray variable %qs at %L must have "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016130 "deferred shape", sym->name, &sym->declared_at);
16131 return;
16132 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016133
16134 /* F2008, C541. */
Tobias Burnusfac665b2011-12-19 09:15:47 +010016135 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
16136 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
Harald Anlauf70c884a2020-07-10 21:35:35 +020016137 && sym->ts.u.derived && CLASS_DATA (sym)
Tobias Burnusfac665b2011-12-19 09:15:47 +010016138 && CLASS_DATA (sym)->attr.coarray_comp))
16139 || (class_attr.codimension && class_attr.allocatable))
Tobias Burnusbe59db22010-04-06 20:16:13 +020016140 && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016141 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016142 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016143 "allocatable coarray or have coarray components",
16144 sym->name, &sym->declared_at);
16145 return;
16146 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016147
Tobias Burnusfac665b2011-12-19 09:15:47 +010016148 if (class_attr.codimension && sym->attr.dummy
Tobias Burnusbe59db22010-04-06 20:16:13 +020016149 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016150 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016151 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
16152 "procedure %qs", sym->name, &sym->declared_at,
Tobias Burnuse535f1b2011-08-15 22:10:51 +020016153 sym->ns->proc_name->name);
16154 return;
16155 }
Tobias Burnusbe59db22010-04-06 20:16:13 +020016156
Tobias Burnusd0841b52013-01-09 17:20:33 +010016157 if (sym->ts.type == BT_LOGICAL
16158 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
16159 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
16160 && sym->ns->proc_name->attr.is_bind_c)))
16161 {
16162 int i;
16163 for (i = 0; gfc_logical_kinds[i].kind; i++)
16164 if (gfc_logical_kinds[i].kind == sym->ts.kind)
16165 break;
16166 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016167 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016168 "%L with non-C_Bool kind in BIND(C) procedure "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016169 "%qs", sym->name, &sym->declared_at,
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016170 sym->ns->proc_name->name))
Tobias Burnusd0841b52013-01-09 17:20:33 +010016171 return;
16172 else if (!gfc_logical_kinds[i].c_bool
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016173 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable "
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016174 "%qs at %L with non-C_Bool kind in "
16175 "BIND(C) procedure %qs", sym->name,
Paul Thomas22c23882014-10-18 14:35:51 +000016176 &sym->declared_at,
16177 sym->attr.function ? sym->name
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016178 : sym->ns->proc_name->name))
Tobias Burnusd0841b52013-01-09 17:20:33 +010016179 return;
16180 }
16181
Paul Brookaf30f792005-01-22 18:23:43 +000016182 switch (sym->attr.flavor)
Paul Brook54b4ba62004-05-18 00:48:05 +000016183 {
Paul Brookaf30f792005-01-22 18:23:43 +000016184 case FL_VARIABLE:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016185 if (!resolve_fl_variable (sym, mp_flag))
Paul Thomas2ed8d222006-02-13 21:22:55 +000016186 return;
16187 break;
Paul Brook54b4ba62004-05-18 00:48:05 +000016188
Paul Thomas2ed8d222006-02-13 21:22:55 +000016189 case FL_PROCEDURE:
Jerry DeLislec0f0e352016-02-07 20:15:55 +000016190 if (sym->formal && !sym->formal_ns)
16191 {
16192 /* Check that none of the arguments are a namelist. */
16193 gfc_formal_arglist *formal = sym->formal;
16194
16195 for (; formal; formal = formal->next)
16196 if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST)
16197 {
Sandra Loosemore67914692019-01-09 16:37:45 -050016198 gfc_error ("Namelist %qs cannot be an argument to "
Jerry DeLislec0f0e352016-02-07 20:15:55 +000016199 "subroutine or function at %L",
16200 formal->sym->name, &sym->declared_at);
16201 return;
16202 }
16203 }
16204
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016205 if (!resolve_fl_procedure (sym, mp_flag))
Paul Thomas2ed8d222006-02-13 21:22:55 +000016206 return;
Paul Brookaf30f792005-01-22 18:23:43 +000016207 break;
16208
16209 case FL_NAMELIST:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016210 if (!resolve_fl_namelist (sym))
Paul Thomas3e1cf502006-02-19 15:24:26 +000016211 return;
Paul Thomas68ea3552006-01-21 09:08:54 +000016212 break;
16213
Paul Thomas2ed8d222006-02-13 21:22:55 +000016214 case FL_PARAMETER:
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016215 if (!resolve_fl_parameter (sym))
Paul Thomas2ed8d222006-02-13 21:22:55 +000016216 return;
Paul Thomase0e85e02005-12-22 07:05:22 +000016217 break;
16218
Paul Brookaf30f792005-01-22 18:23:43 +000016219 default:
16220 break;
Paul Brook54b4ba62004-05-18 00:48:05 +000016221 }
16222
Diego Novillo6de9cd92004-05-13 02:41:07 -040016223 /* Resolve array specifier. Check as well some constraints
Kazu Hirataf7b529f2004-11-08 14:56:41 +000016224 on COMMON blocks. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040016225
16226 check_constant = sym->attr.in_common && !sym->attr.pointer;
Paul Thomas98bbe5e2006-12-04 11:16:12 +000016227
16228 /* Set the formal_arg_flag so that check_conflict will not throw
16229 an error for host associated variables in the specification
16230 expression for an array_valued function. */
Steven G. Kargla81a6d52019-01-15 20:17:35 +000016231 if ((sym->attr.function || sym->attr.result) && sym->as)
Janus Weil7a283532016-12-13 19:55:20 +010016232 formal_arg_flag = true;
Paul Thomas98bbe5e2006-12-04 11:16:12 +000016233
Tobias Burnusfd061182012-10-18 19:09:13 +020016234 saved_specification_expr = specification_expr;
16235 specification_expr = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016236 gfc_resolve_array_spec (sym->as, check_constant);
Tobias Burnusfd061182012-10-18 19:09:13 +020016237 specification_expr = saved_specification_expr;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016238
Janus Weil7a283532016-12-13 19:55:20 +010016239 formal_arg_flag = false;
Paul Thomas98bbe5e2006-12-04 11:16:12 +000016240
Paul Thomasa34437a2007-05-08 14:40:58 +000016241 /* Resolve formal namespaces. */
Janus Weilf6ddbf12009-07-15 10:41:29 +020016242 if (sym->formal_ns && sym->formal_ns != gfc_current_ns
Janus Weile4c1aa12009-08-20 11:33:01 +020016243 && !sym->attr.contained && !sym->attr.intrinsic)
Paul Thomasa34437a2007-05-08 14:40:58 +000016244 gfc_resolve (sym->formal_ns);
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010016245
Janus Weilacbdc372009-07-13 15:41:37 +020016246 /* Make sure the formal namespace is present. */
16247 if (sym->formal && !sym->formal_ns)
16248 {
16249 gfc_formal_arglist *formal = sym->formal;
16250 while (formal && !formal->sym)
16251 formal = formal->next;
16252
16253 if (formal)
16254 {
16255 sym->formal_ns = formal->sym->ns;
Harald Anlaufb8874492020-07-02 20:48:16 +020016256 if (sym->formal_ns && sym->ns != formal->sym->ns)
Tobias Burnus6f79f4d2012-08-27 14:07:43 +020016257 sym->formal_ns->refs++;
Janus Weilacbdc372009-07-13 15:41:37 +020016258 }
16259 }
16260
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010016261 /* Check threadprivate restrictions. */
Tobias Burnusd0655762021-03-12 16:34:10 +010016262 if (sym->attr.threadprivate
16263 && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
Fritz Reese34d567d2016-09-23 21:06:18 +000016264 && !(sym->ns->save_all && !sym->attr.automatic)
Tobias Burnusd0655762021-03-12 16:34:10 +010016265 && sym->module == NULL
16266 && (sym->ns->proc_name == NULL
Tobias Burnus62e1bd62021-05-14 19:19:26 +020016267 || (sym->ns->proc_name->attr.flavor != FL_MODULE
16268 && !sym->ns->proc_name->attr.is_main_program)))
Jakub Jelinek6c7a4df2006-02-14 17:38:03 +010016269 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
Paul Thomas6b591ec2006-10-19 04:51:14 +000016270
Jakub Jelinekf014c652014-06-18 09:16:12 +020016271 /* Check omp declare target restrictions. */
16272 if (sym->attr.omp_declare_target
16273 && sym->attr.flavor == FL_VARIABLE
16274 && !sym->attr.save
Fritz Reese34d567d2016-09-23 21:06:18 +000016275 && !(sym->ns->save_all && !sym->attr.automatic)
Jakub Jelinekf014c652014-06-18 09:16:12 +020016276 && (!sym->attr.in_common
16277 && sym->module == NULL
16278 && (sym->ns->proc_name == NULL
Tobias Burnus62e1bd62021-05-14 19:19:26 +020016279 || (sym->ns->proc_name->attr.flavor != FL_MODULE
16280 && !sym->ns->proc_name->attr.is_main_program))))
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016281 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
Jakub Jelinekf014c652014-06-18 09:16:12 +020016282 sym->name, &sym->declared_at);
16283
Paul Thomas6b591ec2006-10-19 04:51:14 +000016284 /* If we have come this far we can apply default-initializers, as
16285 described in 14.7.5, to those variables that have not already
16286 been assigned one. */
Paul Thomas7114edc2006-11-09 18:42:28 +000016287 if (sym->ts.type == BT_DERIVED
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016288 && !sym->value
16289 && !sym->attr.allocatable
16290 && !sym->attr.alloc_comp)
Paul Thomas6b591ec2006-10-19 04:51:14 +000016291 {
16292 symbol_attribute *a = &sym->attr;
16293
16294 if ((!a->save && !a->dummy && !a->pointer
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016295 && !a->in_common && !a->use_assoc
Paul Thomase6110fa2017-10-13 18:59:34 +000016296 && a->referenced
16297 && !((a->function || a->result)
16298 && (!a->dimension
16299 || sym->ts.u.derived->attr.alloc_comp
16300 || sym->ts.u.derived->attr.pointer_comp))
16301 && !(a->function && sym != sym->result))
Tobias Burnus51d9ef72021-10-04 09:38:43 +020016302 || (a->dummy && !a->pointer && a->intent == INTENT_OUT
16303 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))
Paul Thomas6b591ec2006-10-19 04:51:14 +000016304 apply_default_init (sym);
Andre Vehreschildc16126a2015-07-06 12:26:12 +020016305 else if (a->function && sym->result && a->access != ACCESS_PRIVATE
16306 && (sym->ts.u.derived->attr.alloc_comp
16307 || sym->ts.u.derived->attr.pointer_comp))
16308 /* Mark the result symbol to be referenced, when it has allocatable
16309 components. */
16310 sym->result->attr.referenced = 1;
Paul Thomas6b591ec2006-10-19 04:51:14 +000016311 }
Daniel Kraft52f49932008-09-02 10:13:21 +020016312
Janus Weil50f30802010-09-01 22:50:46 +020016313 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
16314 && sym->attr.dummy && sym->attr.intent == INTENT_OUT
Tobias Burnus51d9ef72021-10-04 09:38:43 +020016315 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY
Janus Weilc330d182010-09-02 14:34:26 +020016316 && !CLASS_DATA (sym)->attr.class_pointer
16317 && !CLASS_DATA (sym)->attr.allocatable)
Tobias Burnus86e6a232010-09-02 12:11:39 +020016318 apply_default_init (sym);
Janus Weil50f30802010-09-01 22:50:46 +020016319
Daniel Kraft52f49932008-09-02 10:13:21 +020016320 /* If this symbol has a type-spec, check it. */
16321 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
16322 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016323 if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
Daniel Kraft52f49932008-09-02 10:13:21 +020016324 return;
Paul Thomas62d3c072017-09-17 18:24:37 +000016325
16326 if (sym->param_list)
16327 resolve_pdt (sym);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016328}
16329
16330
Diego Novillo6de9cd92004-05-13 02:41:07 -040016331/************* Resolve DATA statements *************/
16332
16333static struct
16334{
16335 gfc_data_value *vnode;
Steven G. Karglf2112862007-10-22 22:10:42 +000016336 mpz_t left;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016337}
16338values;
16339
16340
16341/* Advance the values structure to point to the next value in the data list. */
16342
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016343static bool
Diego Novillo6de9cd92004-05-13 02:41:07 -040016344next_data_value (void)
16345{
Steven G. Karglf2112862007-10-22 22:10:42 +000016346 while (mpz_cmp_ui (values.left, 0) == 0)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016347 {
Paul Thomasabeab932009-06-11 20:11:59 +000016348
Diego Novillo6de9cd92004-05-13 02:41:07 -040016349 if (values.vnode->next == NULL)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016350 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016351
16352 values.vnode = values.vnode->next;
Steven G. Karglf2112862007-10-22 22:10:42 +000016353 mpz_set (values.left, values.vnode->repeat);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016354 }
16355
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016356 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016357}
16358
16359
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016360static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016361check_data_variable (gfc_data_variable *var, locus *where)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016362{
16363 gfc_expr *e;
16364 mpz_t size;
16365 mpz_t offset;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016366 bool t;
Tobias Schlüterf5e440e2004-06-21 19:23:52 +020016367 ar_type mark = AR_UNKNOWN;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016368 int i;
16369 mpz_t section_index[GFC_MAX_DIMENSIONS];
16370 gfc_ref *ref;
16371 gfc_array_ref *ar;
Paul Thomase49be8f2009-03-31 20:05:44 +000016372 gfc_symbol *sym;
16373 int has_pointer;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016374
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016375 if (!gfc_resolve_expr (var->expr))
16376 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016377
16378 ar = NULL;
16379 mpz_init_set_si (offset, 0);
16380 e = var->expr;
16381
Tobias Burnus63617e32016-06-21 20:36:25 +020016382 if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
16383 && e->value.function.isym->id == GFC_ISYM_CAF_GET)
16384 e = e->value.function.actual->expr;
16385
Diego Novillo6de9cd92004-05-13 02:41:07 -040016386 if (e->expr_type != EXPR_VARIABLE)
Steven G. Kargl019761d2018-12-09 06:09:47 +000016387 {
16388 gfc_error ("Expecting definable entity near %L", where);
16389 return false;
16390 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016391
Paul Thomase49be8f2009-03-31 20:05:44 +000016392 sym = e->symtree->n.sym;
16393
16394 if (sym->ns->is_block_data && !sym->attr.in_common)
Paul Thomas2ed8d222006-02-13 21:22:55 +000016395 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016396 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
Paul Thomase49be8f2009-03-31 20:05:44 +000016397 sym->name, &sym->declared_at);
Steven G. Kargl019761d2018-12-09 06:09:47 +000016398 return false;
Paul Thomas2ed8d222006-02-13 21:22:55 +000016399 }
16400
Paul Thomase49be8f2009-03-31 20:05:44 +000016401 if (e->ref == NULL && sym->as)
Jerry DeLislef1607c02007-11-25 22:12:19 +000016402 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016403 gfc_error ("DATA array %qs at %L must be specified in a previous"
Paul Thomase49be8f2009-03-31 20:05:44 +000016404 " declaration", sym->name, where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016405 return false;
Jerry DeLislef1607c02007-11-25 22:12:19 +000016406 }
16407
Tobias Burnusa3935ff2011-04-04 20:35:13 +020016408 if (gfc_is_coindexed (e))
16409 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010016410 gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name,
Tobias Burnusa3935ff2011-04-04 20:35:13 +020016411 where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016412 return false;
Tobias Burnusa3935ff2011-04-04 20:35:13 +020016413 }
16414
Steven G. Karglade8fdb2019-08-14 04:22:31 +000016415 has_pointer = sym->attr.pointer;
16416
Paul Thomase49be8f2009-03-31 20:05:44 +000016417 for (ref = e->ref; ref; ref = ref->next)
16418 {
16419 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
16420 has_pointer = 1;
16421
Steven G. Karglade8fdb2019-08-14 04:22:31 +000016422 if (has_pointer)
16423 {
16424 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL)
16425 {
16426 gfc_error ("DATA element %qs at %L is a pointer and so must "
16427 "be a full array", sym->name, where);
16428 return false;
16429 }
16430
16431 if (values.vnode->expr->expr_type == EXPR_CONSTANT)
16432 {
16433 gfc_error ("DATA object near %L has the pointer attribute "
16434 "and the corresponding DATA value is not a valid "
16435 "initial-data-target", where);
16436 return false;
16437 }
16438 }
Harald Anlauf5098d352020-12-16 17:25:06 +010016439
16440 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable)
16441 {
16442 gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE "
16443 "attribute", ref->u.c.component->name, &e->where);
16444 return false;
16445 }
Paul Thomase49be8f2009-03-31 20:05:44 +000016446 }
16447
16448 if (e->rank == 0 || has_pointer)
Richard Hendersonb8502432004-08-23 14:53:14 -070016449 {
16450 mpz_init_set_ui (size, 1);
16451 ref = NULL;
16452 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016453 else
16454 {
16455 ref = e->ref;
16456
16457 /* Find the array section reference. */
16458 for (ref = e->ref; ref; ref = ref->next)
16459 {
16460 if (ref->type != REF_ARRAY)
16461 continue;
16462 if (ref->u.ar.type == AR_ELEMENT)
16463 continue;
16464 break;
16465 }
Paul Brook6e45f572004-09-08 14:33:03 +000016466 gcc_assert (ref);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016467
Kazu Hirata1f2959f2004-09-16 16:00:45 +000016468 /* Set marks according to the reference pattern. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040016469 switch (ref->u.ar.type)
16470 {
16471 case AR_FULL:
Tobias Schlüterf5e440e2004-06-21 19:23:52 +020016472 mark = AR_FULL;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016473 break;
16474
16475 case AR_SECTION:
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016476 ar = &ref->u.ar;
16477 /* Get the start position of array section. */
16478 gfc_get_section_index (ar, section_index, &offset);
16479 mark = AR_SECTION;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016480 break;
16481
16482 default:
Paul Brook6e45f572004-09-08 14:33:03 +000016483 gcc_unreachable ();
Diego Novillo6de9cd92004-05-13 02:41:07 -040016484 }
16485
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016486 if (!gfc_array_size (e, &size))
Diego Novillo6de9cd92004-05-13 02:41:07 -040016487 {
16488 gfc_error ("Nonconstant array section at %L in DATA statement",
Fritz Reese9b24c102017-11-14 01:25:26 +000016489 where);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016490 mpz_clear (offset);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016491 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016492 }
16493 }
16494
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016495 t = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016496
16497 while (mpz_cmp_ui (size, 0) > 0)
16498 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016499 if (!next_data_value ())
Diego Novillo6de9cd92004-05-13 02:41:07 -040016500 {
16501 gfc_error ("DATA statement at %L has more variables than values",
16502 where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016503 t = false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016504 break;
16505 }
16506
16507 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016508 if (!t)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016509 break;
16510
Richard Hendersonb8502432004-08-23 14:53:14 -070016511 /* If we have more than one element left in the repeat count,
16512 and we have more than one element left in the target variable,
16513 then create a range assignment. */
Steven G. Karglf2112862007-10-22 22:10:42 +000016514 /* FIXME: Only done for full arrays for now, since array sections
Richard Hendersonb8502432004-08-23 14:53:14 -070016515 seem tricky. */
16516 if (mark == AR_FULL && ref && ref->next == NULL
Steven G. Karglf2112862007-10-22 22:10:42 +000016517 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0)
Richard Hendersonb8502432004-08-23 14:53:14 -070016518 {
16519 mpz_t range;
16520
Steven G. Karglf2112862007-10-22 22:10:42 +000016521 if (mpz_cmp (size, values.left) >= 0)
Richard Hendersonb8502432004-08-23 14:53:14 -070016522 {
Steven G. Karglf2112862007-10-22 22:10:42 +000016523 mpz_init_set (range, values.left);
16524 mpz_sub (size, size, values.left);
16525 mpz_set_ui (values.left, 0);
Richard Hendersonb8502432004-08-23 14:53:14 -070016526 }
16527 else
16528 {
16529 mpz_init_set (range, size);
Steven G. Karglf2112862007-10-22 22:10:42 +000016530 mpz_sub (values.left, values.left, size);
Richard Hendersonb8502432004-08-23 14:53:14 -070016531 mpz_set_ui (size, 0);
16532 }
16533
Jakub Jelinek21ea4922011-06-30 12:25:40 +020016534 t = gfc_assign_data_value (var->expr, values.vnode->expr,
16535 offset, &range);
Richard Hendersonb8502432004-08-23 14:53:14 -070016536
16537 mpz_add (offset, offset, range);
16538 mpz_clear (range);
Daniel Frankee5880242010-05-05 14:53:23 -040016539
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016540 if (!t)
Daniel Frankee5880242010-05-05 14:53:23 -040016541 break;
Richard Hendersonb8502432004-08-23 14:53:14 -070016542 }
16543
Diego Novillo6de9cd92004-05-13 02:41:07 -040016544 /* Assign initial value to symbol. */
Richard Hendersonb8502432004-08-23 14:53:14 -070016545 else
16546 {
Steven G. Karglf2112862007-10-22 22:10:42 +000016547 mpz_sub_ui (values.left, values.left, 1);
Richard Hendersonb8502432004-08-23 14:53:14 -070016548 mpz_sub_ui (size, size, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016549
Jakub Jelinek21ea4922011-06-30 12:25:40 +020016550 t = gfc_assign_data_value (var->expr, values.vnode->expr,
16551 offset, NULL);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016552 if (!t)
Jerry DeLislea24668a2007-07-03 22:14:55 +000016553 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016554
Richard Hendersonb8502432004-08-23 14:53:14 -070016555 if (mark == AR_FULL)
16556 mpz_add_ui (offset, offset, 1);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016557
Richard Hendersonb8502432004-08-23 14:53:14 -070016558 /* Modify the array section indexes and recalculate the offset
16559 for next element. */
16560 else if (mark == AR_SECTION)
16561 gfc_advance_section (section_index, ar, &offset);
16562 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016563 }
Richard Hendersonb8502432004-08-23 14:53:14 -070016564
Tobias Schlüterf5e440e2004-06-21 19:23:52 +020016565 if (mark == AR_SECTION)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016566 {
16567 for (i = 0; i < ar->dimen; i++)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016568 mpz_clear (section_index[i]);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016569 }
16570
16571 mpz_clear (size);
16572 mpz_clear (offset);
16573
16574 return t;
16575}
16576
16577
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016578static bool traverse_data_var (gfc_data_variable *, locus *);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016579
16580/* Iterate over a list of elements in a DATA statement. */
16581
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016582static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016583traverse_data_list (gfc_data_variable *var, locus *where)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016584{
16585 mpz_t trip;
16586 iterator_stack frame;
Paul Thomas22206522007-01-05 14:45:20 +000016587 gfc_expr *e, *start, *end, *step;
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016588 bool retval = true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016589
16590 mpz_init (frame.value);
Daniel Franke147a19a2010-05-05 15:35:22 -040016591 mpz_init (trip);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016592
Paul Thomas22206522007-01-05 14:45:20 +000016593 start = gfc_copy_expr (var->iter.start);
16594 end = gfc_copy_expr (var->iter.end);
16595 step = gfc_copy_expr (var->iter.step);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016596
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016597 if (!gfc_simplify_expr (start, 1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016598 || start->expr_type != EXPR_CONSTANT)
Paul Thomas22206522007-01-05 14:45:20 +000016599 {
Daniel Franke147a19a2010-05-05 15:35:22 -040016600 gfc_error ("start of implied-do loop at %L could not be "
16601 "simplified to a constant value", &start->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016602 retval = false;
Paul Thomas22206522007-01-05 14:45:20 +000016603 goto cleanup;
16604 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016605 if (!gfc_simplify_expr (end, 1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016606 || end->expr_type != EXPR_CONSTANT)
Paul Thomas22206522007-01-05 14:45:20 +000016607 {
Daniel Franke147a19a2010-05-05 15:35:22 -040016608 gfc_error ("end of implied-do loop at %L could not be "
Harald Anlauf94172dc2020-11-25 20:20:44 +010016609 "simplified to a constant value", &end->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016610 retval = false;
Paul Thomas22206522007-01-05 14:45:20 +000016611 goto cleanup;
16612 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016613 if (!gfc_simplify_expr (step, 1)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016614 || step->expr_type != EXPR_CONSTANT)
Paul Thomas22206522007-01-05 14:45:20 +000016615 {
Daniel Franke147a19a2010-05-05 15:35:22 -040016616 gfc_error ("step of implied-do loop at %L could not be "
Harald Anlauf94172dc2020-11-25 20:20:44 +010016617 "simplified to a constant value", &step->where);
16618 retval = false;
16619 goto cleanup;
16620 }
16621 if (mpz_cmp_si (step->value.integer, 0) == 0)
16622 {
16623 gfc_error ("step of implied-do loop at %L shall not be zero",
16624 &step->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016625 retval = false;
Paul Thomas22206522007-01-05 14:45:20 +000016626 goto cleanup;
16627 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016628
Daniel Franke147a19a2010-05-05 15:35:22 -040016629 mpz_set (trip, end->value.integer);
Paul Thomas22206522007-01-05 14:45:20 +000016630 mpz_sub (trip, trip, start->value.integer);
16631 mpz_add (trip, trip, step->value.integer);
16632
16633 mpz_div (trip, trip, step->value.integer);
16634
16635 mpz_set (frame.value, start->value.integer);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016636
16637 frame.prev = iter_stack;
16638 frame.variable = var->iter.var->symtree;
16639 iter_stack = &frame;
16640
16641 while (mpz_cmp_ui (trip, 0) > 0)
16642 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016643 if (!traverse_data_var (var->list, where))
Diego Novillo6de9cd92004-05-13 02:41:07 -040016644 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016645 retval = false;
Paul Thomas22206522007-01-05 14:45:20 +000016646 goto cleanup;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016647 }
16648
16649 e = gfc_copy_expr (var->expr);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016650 if (!gfc_simplify_expr (e, 1))
Paul Thomas22206522007-01-05 14:45:20 +000016651 {
16652 gfc_free_expr (e);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016653 retval = false;
Paul Thomas22206522007-01-05 14:45:20 +000016654 goto cleanup;
16655 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016656
Paul Thomas22206522007-01-05 14:45:20 +000016657 mpz_add (frame.value, frame.value, step->value.integer);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016658
16659 mpz_sub_ui (trip, trip, 1);
16660 }
16661
Paul Thomas22206522007-01-05 14:45:20 +000016662cleanup:
Diego Novillo6de9cd92004-05-13 02:41:07 -040016663 mpz_clear (frame.value);
Daniel Franke147a19a2010-05-05 15:35:22 -040016664 mpz_clear (trip);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016665
Paul Thomas22206522007-01-05 14:45:20 +000016666 gfc_free_expr (start);
16667 gfc_free_expr (end);
16668 gfc_free_expr (step);
16669
Diego Novillo6de9cd92004-05-13 02:41:07 -040016670 iter_stack = frame.prev;
Paul Thomas22206522007-01-05 14:45:20 +000016671 return retval;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016672}
16673
16674
16675/* Type resolve variables in the variable list of a DATA statement. */
16676
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016677static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016678traverse_data_var (gfc_data_variable *var, locus *where)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016679{
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016680 bool t;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016681
16682 for (; var; var = var->next)
16683 {
16684 if (var->expr == NULL)
16685 t = traverse_data_list (var, where);
16686 else
16687 t = check_data_variable (var, where);
16688
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016689 if (!t)
16690 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016691 }
16692
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016693 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016694}
16695
16696
16697/* Resolve the expressions and iterators associated with a data statement.
16698 This is separate from the assignment checking because data lists should
16699 only be resolved once. */
16700
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016701static bool
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016702resolve_data_variables (gfc_data_variable *d)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016703{
Diego Novillo6de9cd92004-05-13 02:41:07 -040016704 for (; d; d = d->next)
16705 {
16706 if (d->list == NULL)
16707 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016708 if (!gfc_resolve_expr (d->expr))
16709 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016710 }
16711 else
16712 {
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016713 if (!gfc_resolve_iterator (&d->iter, false, true))
16714 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016715
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016716 if (!resolve_data_variables (d->list))
16717 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016718 }
16719 }
16720
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016721 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016722}
16723
16724
16725/* Resolve a single DATA statement. We implement this by storing a pointer to
16726 the value list into static variables, and then recursively traversing the
16727 variables list, expanding iterators and such. */
16728
16729static void
Steven G. Karglf2112862007-10-22 22:10:42 +000016730resolve_data (gfc_data *d)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016731{
Steven G. Karglf2112862007-10-22 22:10:42 +000016732
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016733 if (!resolve_data_variables (d->var))
Diego Novillo6de9cd92004-05-13 02:41:07 -040016734 return;
16735
16736 values.vnode = d->value;
Steven G. Karglf2112862007-10-22 22:10:42 +000016737 if (d->value == NULL)
16738 mpz_set_ui (values.left, 0);
16739 else
16740 mpz_set (values.left, d->value->repeat);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016741
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016742 if (!traverse_data_var (d->var, &d->where))
Diego Novillo6de9cd92004-05-13 02:41:07 -040016743 return;
16744
16745 /* At this point, we better not have any values left. */
16746
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016747 if (next_data_value ())
Diego Novillo6de9cd92004-05-13 02:41:07 -040016748 gfc_error ("DATA statement at %L has more values than variables",
16749 &d->where);
16750}
16751
16752
Paul Thomasd2088bb2007-06-18 23:04:28 +000016753/* 12.6 Constraint: In a pure subprogram any variable which is in common or
16754 accessed by host or use association, is a dummy argument to a pure function,
16755 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
16756 is storage associated with any such variable, shall not be used in the
16757 following contexts: (clients of this function). */
16758
Ralf Wildenhuesdf2fba92008-07-21 19:17:08 +000016759/* Determines if a variable is not 'pure', i.e., not assignable within a pure
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016760 procedure. Returns zero if assignment is OK, nonzero if there is a
16761 problem. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040016762int
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016763gfc_impure_variable (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016764{
Paul Thomasd2088bb2007-06-18 23:04:28 +000016765 gfc_symbol *proc;
Janus Weild1039122010-03-03 16:12:40 +010016766 gfc_namespace *ns;
Paul Thomasd2088bb2007-06-18 23:04:28 +000016767
Diego Novillo6de9cd92004-05-13 02:41:07 -040016768 if (sym->attr.use_assoc || sym->attr.in_common)
16769 return 1;
16770
Janus Weild1039122010-03-03 16:12:40 +010016771 /* Check if the symbol's ns is inside the pure procedure. */
16772 for (ns = gfc_current_ns; ns; ns = ns->parent)
16773 {
16774 if (ns == sym->ns)
16775 break;
16776 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
16777 return 1;
16778 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016779
Paul Thomasd2088bb2007-06-18 23:04:28 +000016780 proc = sym->ns->proc_name;
Tobias Burnusc915f8b2012-09-13 16:57:38 +020016781 if (sym->attr.dummy
Harald Anlaufa764c402020-10-27 20:25:23 +010016782 && !sym->attr.value
Tobias Burnusc915f8b2012-09-13 16:57:38 +020016783 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
16784 || proc->attr.function))
Paul Thomasd2088bb2007-06-18 23:04:28 +000016785 return 1;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016786
Paul Thomasd2088bb2007-06-18 23:04:28 +000016787 /* TODO: Sort out what can be storage associated, if anything, and include
16788 it here. In principle equivalences should be scanned but it does not
16789 seem to be possible to storage associate an impure variable this way. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040016790 return 0;
16791}
16792
16793
Janus Weild1039122010-03-03 16:12:40 +010016794/* Test whether a symbol is pure or not. For a NULL pointer, checks if the
16795 current namespace is inside a pure procedure. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040016796
16797int
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016798gfc_pure (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016799{
16800 symbol_attribute attr;
Janus Weild1039122010-03-03 16:12:40 +010016801 gfc_namespace *ns;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016802
16803 if (sym == NULL)
Janus Weild1039122010-03-03 16:12:40 +010016804 {
16805 /* Check if the current namespace or one of its parents
16806 belongs to a pure procedure. */
16807 for (ns = gfc_current_ns; ns; ns = ns->parent)
16808 {
16809 sym = ns->proc_name;
16810 if (sym == NULL)
16811 return 0;
16812 attr = sym->attr;
Daniel Krafte6c14892010-08-15 17:28:10 +020016813 if (attr.flavor == FL_PROCEDURE && attr.pure)
Janus Weild1039122010-03-03 16:12:40 +010016814 return 1;
16815 }
16816 return 0;
16817 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040016818
16819 attr = sym->attr;
16820
Daniel Krafte6c14892010-08-15 17:28:10 +020016821 return attr.flavor == FL_PROCEDURE && attr.pure;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016822}
16823
16824
Paul Thomasf1f39032011-01-08 19:17:03 +000016825/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
16826 checks if the current namespace is implicitly pure. Note that this
16827 function returns false for a PURE procedure. */
16828
16829int
16830gfc_implicit_pure (gfc_symbol *sym)
16831{
Thomas Koenigf29041d2011-12-31 08:18:52 +000016832 gfc_namespace *ns;
Paul Thomasf1f39032011-01-08 19:17:03 +000016833
16834 if (sym == NULL)
16835 {
Thomas Koenigf29041d2011-12-31 08:18:52 +000016836 /* Check if the current procedure is implicit_pure. Walk up
16837 the procedure list until we find a procedure. */
16838 for (ns = gfc_current_ns; ns; ns = ns->parent)
16839 {
16840 sym = ns->proc_name;
16841 if (sym == NULL)
16842 return 0;
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000016843
Thomas Koenigf29041d2011-12-31 08:18:52 +000016844 if (sym->attr.flavor == FL_PROCEDURE)
16845 break;
16846 }
Paul Thomasf1f39032011-01-08 19:17:03 +000016847 }
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000016848
Thomas Koenigf29041d2011-12-31 08:18:52 +000016849 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure
16850 && !sym->attr.pure;
Paul Thomasf1f39032011-01-08 19:17:03 +000016851}
16852
16853
Tobias Burnusccd77512014-03-19 22:03:14 +010016854void
16855gfc_unset_implicit_pure (gfc_symbol *sym)
16856{
16857 gfc_namespace *ns;
16858
16859 if (sym == NULL)
16860 {
16861 /* Check if the current procedure is implicit_pure. Walk up
16862 the procedure list until we find a procedure. */
16863 for (ns = gfc_current_ns; ns; ns = ns->parent)
16864 {
16865 sym = ns->proc_name;
16866 if (sym == NULL)
16867 return;
16868
16869 if (sym->attr.flavor == FL_PROCEDURE)
16870 break;
16871 }
16872 }
16873
16874 if (sym->attr.flavor == FL_PROCEDURE)
16875 sym->attr.implicit_pure = 0;
16876 else
16877 sym->attr.pure = 0;
16878}
16879
16880
Diego Novillo6de9cd92004-05-13 02:41:07 -040016881/* Test whether the current procedure is elemental or not. */
16882
16883int
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016884gfc_elemental (gfc_symbol *sym)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016885{
16886 symbol_attribute attr;
16887
16888 if (sym == NULL)
16889 sym = gfc_current_ns->proc_name;
16890 if (sym == NULL)
16891 return 0;
16892 attr = sym->attr;
16893
16894 return attr.flavor == FL_PROCEDURE && attr.elemental;
16895}
16896
16897
16898/* Warn about unused labels. */
16899
16900static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016901warn_unused_fortran_label (gfc_st_label *label)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016902{
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016903 if (label == NULL)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016904 return;
16905
Steven G. Kargl994c1cc2006-08-06 01:38:46 +000016906 warn_unused_fortran_label (label->left);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016907
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016908 if (label->defined == ST_LABEL_UNKNOWN)
16909 return;
16910
16911 switch (label->referenced)
Diego Novillo6de9cd92004-05-13 02:41:07 -040016912 {
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016913 case ST_LABEL_UNKNOWN:
Janus Weil28ce22e2016-11-05 11:35:23 +010016914 gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used",
16915 label->value, &label->where);
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016916 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016917
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016918 case ST_LABEL_BAD_TARGET:
Janus Weil28ce22e2016-11-05 11:35:23 +010016919 gfc_warning (OPT_Wunused_label,
16920 "Label %d at %L defined but cannot be used",
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016921 label->value, &label->where);
16922 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016923
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016924 default:
16925 break;
Diego Novillo6de9cd92004-05-13 02:41:07 -040016926 }
Tobias Schlüter5cf54582006-01-18 21:54:49 +010016927
Steven G. Kargl994c1cc2006-08-06 01:38:46 +000016928 warn_unused_fortran_label (label->right);
Diego Novillo6de9cd92004-05-13 02:41:07 -040016929}
16930
16931
Paul Thomase8ec07e2005-10-01 07:39:08 +000016932/* Returns the sequence type of a symbol or sequence. */
16933
16934static seq_type
16935sequence_type (gfc_typespec ts)
16936{
16937 seq_type result;
16938 gfc_component *c;
16939
16940 switch (ts.type)
16941 {
16942 case BT_DERIVED:
16943
Janus Weilbc21d312009-08-13 21:46:46 +020016944 if (ts.u.derived->components == NULL)
Paul Thomase8ec07e2005-10-01 07:39:08 +000016945 return SEQ_NONDEFAULT;
16946
Janus Weilbc21d312009-08-13 21:46:46 +020016947 result = sequence_type (ts.u.derived->components->ts);
16948 for (c = ts.u.derived->components->next; c; c = c->next)
Paul Thomase8ec07e2005-10-01 07:39:08 +000016949 if (sequence_type (c->ts) != result)
16950 return SEQ_MIXED;
16951
16952 return result;
16953
16954 case BT_CHARACTER:
16955 if (ts.kind != gfc_default_character_kind)
16956 return SEQ_NONDEFAULT;
16957
16958 return SEQ_CHARACTER;
16959
16960 case BT_INTEGER:
16961 if (ts.kind != gfc_default_integer_kind)
16962 return SEQ_NONDEFAULT;
16963
16964 return SEQ_NUMERIC;
16965
16966 case BT_REAL:
16967 if (!(ts.kind == gfc_default_real_kind
Steven G. Kargledf1eac2007-01-20 22:01:41 +000016968 || ts.kind == gfc_default_double_kind))
Paul Thomase8ec07e2005-10-01 07:39:08 +000016969 return SEQ_NONDEFAULT;
16970
16971 return SEQ_NUMERIC;
16972
16973 case BT_COMPLEX:
16974 if (ts.kind != gfc_default_complex_kind)
16975 return SEQ_NONDEFAULT;
16976
16977 return SEQ_NUMERIC;
16978
16979 case BT_LOGICAL:
16980 if (ts.kind != gfc_default_logical_kind)
16981 return SEQ_NONDEFAULT;
16982
16983 return SEQ_NUMERIC;
16984
16985 default:
16986 return SEQ_NONDEFAULT;
16987 }
16988}
16989
16990
Diego Novillo6de9cd92004-05-13 02:41:07 -040016991/* Resolve derived type EQUIVALENCE object. */
16992
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016993static bool
Diego Novillo6de9cd92004-05-13 02:41:07 -040016994resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
16995{
Diego Novillo6de9cd92004-05-13 02:41:07 -040016996 gfc_component *c = derived->components;
16997
16998 if (!derived)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030016999 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017000
17001 /* Shall not be an object of nonsequence derived type. */
17002 if (!derived->attr.sequence)
17003 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017004 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017005 "attribute to be an EQUIVALENCE object", sym->name,
17006 &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017007 return false;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017008 }
17009
Steven G. Kargl66e4ab32007-06-07 18:10:31 +000017010 /* Shall not have allocatable components. */
Paul Thomas5046aff2006-10-08 16:21:55 +000017011 if (derived->attr.alloc_comp)
17012 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017013 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017014 "components to be an EQUIVALENCE object",sym->name,
17015 &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017016 return false;
Paul Thomas5046aff2006-10-08 16:21:55 +000017017 }
17018
Daniel Franke16e520b2010-05-19 09:07:25 -040017019 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived))
Tobias Burnuscddcf0d2008-01-06 19:07:52 +010017020 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017021 gfc_error ("Derived type variable %qs at %L with default "
Tobias Burnuscddcf0d2008-01-06 19:07:52 +010017022 "initialization cannot be in EQUIVALENCE with a variable "
17023 "in COMMON", sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017024 return false;
Tobias Burnuscddcf0d2008-01-06 19:07:52 +010017025 }
17026
Diego Novillo6de9cd92004-05-13 02:41:07 -040017027 for (; c ; c = c->next)
17028 {
Fritz Reesef6288c22016-05-07 23:16:23 +000017029 if (gfc_bt_struct (c->ts.type)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017030 && (!resolve_equivalence_derived(c->ts.u.derived, sym, e)))
17031 return false;
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020017032
Diego Novillo6de9cd92004-05-13 02:41:07 -040017033 /* Shall not be an object of sequence derived type containing a pointer
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017034 in the structure. */
Janus Weild4b7d0f2008-08-23 23:04:01 +020017035 if (c->attr.pointer)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017036 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017037 gfc_error ("Derived type variable %qs at %L with pointer "
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017038 "component(s) cannot be an EQUIVALENCE object",
17039 sym->name, &e->where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017040 return false;
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017041 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040017042 }
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017043 return true;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017044}
17045
17046
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000017047/* Resolve equivalence object.
Paul Thomase8ec07e2005-10-01 07:39:08 +000017048 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
17049 an allocatable array, an object of nonsequence derived type, an object of
Diego Novillo6de9cd92004-05-13 02:41:07 -040017050 sequence derived type containing a pointer at any level of component
17051 selection, an automatic object, a function name, an entry name, a result
17052 name, a named constant, a structure component, or a subobject of any of
Paul Thomase8ec07e2005-10-01 07:39:08 +000017053 the preceding objects. A substring shall not have length zero. A
17054 derived type shall not have components with default initialization nor
17055 shall two objects of an equivalence group be initialized.
Tobias Burnusee7e6772006-12-10 20:53:07 +010017056 Either all or none of the objects shall have an protected attribute.
Martin Liskae53b6e52022-01-14 16:57:02 +010017057 The simple constraints are done in symbol.cc(check_conflict) and the rest
Paul Thomase8ec07e2005-10-01 07:39:08 +000017058 are implemented here. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040017059
17060static void
17061resolve_equivalence (gfc_equiv *eq)
17062{
17063 gfc_symbol *sym;
Paul Thomase8ec07e2005-10-01 07:39:08 +000017064 gfc_symbol *first_sym;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017065 gfc_expr *e;
17066 gfc_ref *r;
Paul Thomase8ec07e2005-10-01 07:39:08 +000017067 locus *last_where = NULL;
17068 seq_type eq_type, last_eq_type;
17069 gfc_typespec *last_ts;
Tobias Burnusee7e6772006-12-10 20:53:07 +010017070 int object, cnt_protected;
Paul Thomase8ec07e2005-10-01 07:39:08 +000017071 const char *msg;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017072
Paul Thomase8ec07e2005-10-01 07:39:08 +000017073 last_ts = &eq->expr->symtree->n.sym->ts;
17074
17075 first_sym = eq->expr->symtree->n.sym;
17076
Tobias Burnusee7e6772006-12-10 20:53:07 +010017077 cnt_protected = 0;
17078
Paul Thomase8ec07e2005-10-01 07:39:08 +000017079 for (object = 1; eq; eq = eq->eq, object++)
Diego Novillo6de9cd92004-05-13 02:41:07 -040017080 {
17081 e = eq->expr;
Jakub Jelineka8006d02005-08-06 12:00:53 +020017082
17083 e->ts = e->symtree->n.sym->ts;
17084 /* match_varspec might not know yet if it is seeing
17085 array reference or substring reference, as it doesn't
17086 know the types. */
17087 if (e->ref && e->ref->type == REF_ARRAY)
17088 {
17089 gfc_ref *ref = e->ref;
17090 sym = e->symtree->n.sym;
17091
17092 if (sym->attr.dimension)
17093 {
17094 ref->u.ar.as = sym->as;
17095 ref = ref->next;
17096 }
17097
17098 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
17099 if (e->ts.type == BT_CHARACTER
17100 && ref
17101 && ref->type == REF_ARRAY
17102 && ref->u.ar.dimen == 1
17103 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
17104 && ref->u.ar.stride[0] == NULL)
17105 {
17106 gfc_expr *start = ref->u.ar.start[0];
17107 gfc_expr *end = ref->u.ar.end[0];
17108 void *mem = NULL;
17109
17110 /* Optimize away the (:) reference. */
17111 if (start == NULL && end == NULL)
17112 {
17113 if (e->ref == ref)
17114 e->ref = ref->next;
17115 else
17116 e->ref->next = ref->next;
17117 mem = ref;
17118 }
17119 else
17120 {
17121 ref->type = REF_SUBSTRING;
17122 if (start == NULL)
Janne Blomqvistf6222212018-01-05 21:01:12 +020017123 start = gfc_get_int_expr (gfc_charlen_int_kind,
Jerry DeLisleb7e75772010-04-13 01:59:35 +000017124 NULL, 1);
Jakub Jelineka8006d02005-08-06 12:00:53 +020017125 ref->u.ss.start = start;
Janus Weilbc21d312009-08-13 21:46:46 +020017126 if (end == NULL && e->ts.u.cl)
17127 end = gfc_copy_expr (e->ts.u.cl->length);
Jakub Jelineka8006d02005-08-06 12:00:53 +020017128 ref->u.ss.end = end;
Janus Weilbc21d312009-08-13 21:46:46 +020017129 ref->u.ss.length = e->ts.u.cl;
17130 e->ts.u.cl = NULL;
Jakub Jelineka8006d02005-08-06 12:00:53 +020017131 }
17132 ref = ref->next;
Jim Meyeringcede9502011-04-18 19:20:53 +000017133 free (mem);
Jakub Jelineka8006d02005-08-06 12:00:53 +020017134 }
17135
17136 /* Any further ref is an error. */
17137 if (ref)
17138 {
17139 gcc_assert (ref->type == REF_ARRAY);
17140 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
17141 &ref->u.ar.where);
17142 continue;
17143 }
17144 }
17145
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017146 if (!gfc_resolve_expr (e))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017147 continue;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017148
17149 sym = e->symtree->n.sym;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017150
Kaveh R. Ghazi9aa433c2008-07-19 16:19:27 +000017151 if (sym->attr.is_protected)
Tobias Burnusee7e6772006-12-10 20:53:07 +010017152 cnt_protected++;
17153 if (cnt_protected > 0 && cnt_protected != object)
17154 {
17155 gfc_error ("Either all or none of the objects in the "
17156 "EQUIVALENCE set at %L shall have the "
17157 "PROTECTED attribute",
17158 &e->where);
17159 break;
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017160 }
Tobias Burnusee7e6772006-12-10 20:53:07 +010017161
Paul Thomase8ec07e2005-10-01 07:39:08 +000017162 /* Shall not equivalence common block variables in a PURE procedure. */
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020017163 if (sym->ns->proc_name
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017164 && sym->ns->proc_name->attr.pure
17165 && sym->attr.in_common)
17166 {
Steven G. Kargl9cfdd482017-11-04 00:34:40 +000017167 /* Need to check for symbols that may have entered the pure
17168 procedure via a USE statement. */
17169 bool saw_sym = false;
17170 if (sym->ns->use_stmts)
17171 {
17172 gfc_use_rename *r;
17173 for (r = sym->ns->use_stmts->rename; r; r = r->next)
Paul Thomasaea5e932017-11-05 12:38:42 +000017174 if (strcmp(r->use_name, sym->name) == 0) saw_sym = true;
Steven G. Kargl9cfdd482017-11-04 00:34:40 +000017175 }
17176 else
17177 saw_sym = true;
17178
17179 if (saw_sym)
17180 gfc_error ("COMMON block member %qs at %L cannot be an "
17181 "EQUIVALENCE object in the pure procedure %qs",
17182 sym->name, &e->where, sym->ns->proc_name->name);
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017183 break;
17184 }
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020017185
17186 /* Shall not be a named constant. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040017187 if (e->expr_type == EXPR_CONSTANT)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017188 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017189 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017190 "object", sym->name, &e->where);
17191 continue;
17192 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040017193
Janus Weilbc21d312009-08-13 21:46:46 +020017194 if (e->ts.type == BT_DERIVED
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017195 && !resolve_equivalence_derived (e->ts.u.derived, sym, e))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017196 continue;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017197
Paul Thomase8ec07e2005-10-01 07:39:08 +000017198 /* Check that the types correspond correctly:
17199 Note 5.28:
17200 A numeric sequence structure may be equivalenced to another sequence
17201 structure, an object of default integer type, default real type, double
17202 precision real type, default logical type such that components of the
17203 structure ultimately only become associated to objects of the same
17204 kind. A character sequence structure may be equivalenced to an object
17205 of default character kind or another character sequence structure.
17206 Other objects may be equivalenced only to objects of the same type and
17207 kind parameters. */
17208
17209 /* Identical types are unconditionally OK. */
17210 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
17211 goto identical_types;
17212
17213 last_eq_type = sequence_type (*last_ts);
17214 eq_type = sequence_type (sym->ts);
17215
17216 /* Since the pair of objects is not of the same type, mixed or
17217 non-default sequences can be rejected. */
17218
17219 msg = "Sequence %s with mixed components in EQUIVALENCE "
17220 "statement at %L with different type objects";
17221 if ((object ==2
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017222 && last_eq_type == SEQ_MIXED
Harald Anlaufe505f742022-11-09 21:05:28 +010017223 && last_where
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017224 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017225 || (eq_type == SEQ_MIXED
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017226 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
Paul Thomase8ec07e2005-10-01 07:39:08 +000017227 continue;
17228
17229 msg = "Non-default type object or sequence %s in EQUIVALENCE "
17230 "statement at %L with objects of different type";
17231 if ((object ==2
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017232 && last_eq_type == SEQ_NONDEFAULT
Harald Anlaufe505f742022-11-09 21:05:28 +010017233 && last_where
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017234 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017235 || (eq_type == SEQ_NONDEFAULT
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017236 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)))
Paul Thomase8ec07e2005-10-01 07:39:08 +000017237 continue;
17238
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017239 msg ="Non-CHARACTER object %qs in default CHARACTER "
Paul Thomase8ec07e2005-10-01 07:39:08 +000017240 "EQUIVALENCE statement at %L";
17241 if (last_eq_type == SEQ_CHARACTER
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017242 && eq_type != SEQ_CHARACTER
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017243 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
Paul Thomase8ec07e2005-10-01 07:39:08 +000017244 continue;
17245
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017246 msg ="Non-NUMERIC object %qs in default NUMERIC "
Paul Thomase8ec07e2005-10-01 07:39:08 +000017247 "EQUIVALENCE statement at %L";
17248 if (last_eq_type == SEQ_NUMERIC
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017249 && eq_type != SEQ_NUMERIC
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017250 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))
Paul Thomase8ec07e2005-10-01 07:39:08 +000017251 continue;
17252
Mark Egglestonbf1f6d82020-04-02 07:18:52 +010017253identical_types:
17254
Paul Thomase8ec07e2005-10-01 07:39:08 +000017255 last_ts =&sym->ts;
17256 last_where = &e->where;
17257
Diego Novillo6de9cd92004-05-13 02:41:07 -040017258 if (!e->ref)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017259 continue;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017260
17261 /* Shall not be an automatic array. */
Mark Egglestonbf1f6d82020-04-02 07:18:52 +010017262 if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym))
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017263 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017264 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017265 "an EQUIVALENCE object", sym->name, &e->where);
17266 continue;
17267 }
Diego Novillo6de9cd92004-05-13 02:41:07 -040017268
Diego Novillo6de9cd92004-05-13 02:41:07 -040017269 r = e->ref;
17270 while (r)
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017271 {
Jakub Jelineka8006d02005-08-06 12:00:53 +020017272 /* Shall not be a structure component. */
17273 if (r->type == REF_COMPONENT)
17274 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017275 gfc_error ("Structure component %qs at %L cannot be an "
Jakub Jelineka8006d02005-08-06 12:00:53 +020017276 "EQUIVALENCE object",
17277 r->u.c.component->name, &e->where);
17278 break;
17279 }
17280
17281 /* A substring shall not have length zero. */
17282 if (r->type == REF_SUBSTRING)
17283 {
17284 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
17285 {
17286 gfc_error ("Substring at %L has length zero",
17287 &r->u.ss.start->where);
17288 break;
17289 }
17290 }
17291 r = r->next;
17292 }
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020017293 }
17294}
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017295
17296
Paul Thomasa9b64a62019-10-27 15:00:54 +000017297/* Function called by resolve_fntype to flag other symbols used in the
17298 length type parameter specification of function results. */
Paul Thomas345bd7e2016-12-09 11:55:27 +000017299
17300static bool
17301flag_fn_result_spec (gfc_expr *expr,
Paul Thomas9ad8aaf2018-05-20 10:08:24 +000017302 gfc_symbol *sym,
Paul Thomas345bd7e2016-12-09 11:55:27 +000017303 int *f ATTRIBUTE_UNUSED)
17304{
17305 gfc_namespace *ns;
17306 gfc_symbol *s;
17307
17308 if (expr->expr_type == EXPR_VARIABLE)
17309 {
17310 s = expr->symtree->n.sym;
17311 for (ns = s->ns; ns; ns = ns->parent)
17312 if (!ns->parent)
17313 break;
17314
Paul Thomas9ad8aaf2018-05-20 10:08:24 +000017315 if (sym == s)
17316 {
17317 gfc_error ("Self reference in character length expression "
17318 "for %qs at %L", sym->name, &expr->where);
17319 return true;
17320 }
17321
Paul Thomas345bd7e2016-12-09 11:55:27 +000017322 if (!s->fn_result_spec
17323 && s->attr.flavor == FL_PARAMETER)
17324 {
17325 /* Function contained in a module.... */
17326 if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
17327 {
17328 gfc_symtree *st;
17329 s->fn_result_spec = 1;
17330 /* Make sure that this symbol is translated as a module
17331 variable. */
17332 st = gfc_get_unique_symtree (ns);
17333 st->n.sym = s;
17334 s->refs++;
17335 }
17336 /* ... which is use associated and called. */
17337 else if (s->attr.use_assoc || s->attr.used_in_submodule
17338 ||
17339 /* External function matched with an interface. */
17340 (s->ns->proc_name
17341 && ((s->ns == ns
17342 && s->ns->proc_name->attr.if_source == IFSRC_DECL)
17343 || s->ns->proc_name->attr.if_source == IFSRC_IFBODY)
17344 && s->ns->proc_name->attr.function))
17345 s->fn_result_spec = 1;
17346 }
17347 }
17348 return false;
17349}
17350
17351
Steven G. Kargl66e4ab32007-06-07 18:10:31 +000017352/* Resolve function and ENTRY types, issue diagnostics if needed. */
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017353
17354static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017355resolve_fntype (gfc_namespace *ns)
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017356{
17357 gfc_entry_list *el;
17358 gfc_symbol *sym;
17359
17360 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
17361 return;
17362
17363 /* If there are any entries, ns->proc_name is the entry master
17364 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
17365 if (ns->entries)
17366 sym = ns->entries->sym;
17367 else
17368 sym = ns->proc_name;
17369 if (sym->result == sym
17370 && sym->ts.type == BT_UNKNOWN
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017371 && !gfc_set_default_type (sym, 0, NULL)
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017372 && !sym->attr.untyped)
17373 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017374 gfc_error ("Function %qs at %L has no IMPLICIT type",
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017375 sym->name, &sym->declared_at);
17376 sym->attr.untyped = 1;
17377 }
17378
Janus Weilbc21d312009-08-13 21:46:46 +020017379 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc
Tobias Burnus0d6872c2008-11-12 07:59:33 +010017380 && !sym->attr.contained
Janus Weil6e2062b2011-02-18 11:04:30 +010017381 && !gfc_check_symbol_access (sym->ts.u.derived)
17382 && gfc_check_symbol_access (sym))
Erik Edelmann3bcc0182006-01-08 17:52:57 +000017383 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017384 gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at "
17385 "%L of PRIVATE type %qs", sym->name,
Janus Weilbc21d312009-08-13 21:46:46 +020017386 &sym->declared_at, sym->ts.u.derived->name);
Erik Edelmann3bcc0182006-01-08 17:52:57 +000017387 }
17388
Paul Thomas74533782007-03-18 15:00:55 +000017389 if (ns->entries)
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017390 for (el = ns->entries->next; el; el = el->next)
17391 {
17392 if (el->sym->result == el->sym
17393 && el->sym->ts.type == BT_UNKNOWN
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017394 && !gfc_set_default_type (el->sym, 0, NULL)
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017395 && !el->sym->attr.untyped)
17396 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017397 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017398 el->sym->name, &el->sym->declared_at);
17399 el->sym->attr.untyped = 1;
17400 }
17401 }
Paul Thomas345bd7e2016-12-09 11:55:27 +000017402
17403 if (sym->ts.type == BT_CHARACTER)
Paul Thomas9ad8aaf2018-05-20 10:08:24 +000017404 gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0);
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017405}
17406
Daniel Kraft94747282009-08-10 12:51:46 +020017407
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017408/* 12.3.2.1.1 Defined operators. */
17409
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017410static bool
Daniel Kraft94747282009-08-10 12:51:46 +020017411check_uop_procedure (gfc_symbol *sym, locus where)
17412{
17413 gfc_formal_arglist *formal;
17414
17415 if (!sym->attr.function)
17416 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017417 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
Daniel Kraft94747282009-08-10 12:51:46 +020017418 sym->name, &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017419 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017420 }
17421
17422 if (sym->ts.type == BT_CHARACTER
Paul Thomasafbc5ae2016-01-15 20:33:58 +000017423 && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
17424 && !(sym->result && ((sym->result->ts.u.cl
17425 && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
Daniel Kraft94747282009-08-10 12:51:46 +020017426 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017427 gfc_error ("User operator procedure %qs at %L cannot be assumed "
Daniel Kraft94747282009-08-10 12:51:46 +020017428 "character length", sym->name, &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017429 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017430 }
17431
Janus Weil4cbc9032013-01-29 22:40:51 +010017432 formal = gfc_sym_get_dummy_args (sym);
Daniel Kraft94747282009-08-10 12:51:46 +020017433 if (!formal || !formal->sym)
17434 {
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017435 gfc_error ("User operator procedure %qs at %L must have at least "
Daniel Kraft94747282009-08-10 12:51:46 +020017436 "one argument", sym->name, &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017437 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017438 }
17439
17440 if (formal->sym->attr.intent != INTENT_IN)
17441 {
17442 gfc_error ("First argument of operator interface at %L must be "
17443 "INTENT(IN)", &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017444 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017445 }
17446
17447 if (formal->sym->attr.optional)
17448 {
17449 gfc_error ("First argument of operator interface at %L cannot be "
17450 "optional", &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017451 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017452 }
17453
17454 formal = formal->next;
17455 if (!formal || !formal->sym)
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017456 return true;
Daniel Kraft94747282009-08-10 12:51:46 +020017457
17458 if (formal->sym->attr.intent != INTENT_IN)
17459 {
17460 gfc_error ("Second argument of operator interface at %L must be "
17461 "INTENT(IN)", &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017462 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017463 }
17464
17465 if (formal->sym->attr.optional)
17466 {
17467 gfc_error ("Second argument of operator interface at %L cannot be "
17468 "optional", &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017469 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017470 }
17471
17472 if (formal->next)
17473 {
17474 gfc_error ("Operator interface at %L must have, at most, two "
17475 "arguments", &where);
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017476 return false;
Daniel Kraft94747282009-08-10 12:51:46 +020017477 }
17478
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017479 return true;
Daniel Kraft94747282009-08-10 12:51:46 +020017480}
17481
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017482static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017483gfc_resolve_uops (gfc_symtree *symtree)
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017484{
17485 gfc_interface *itr;
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017486
Bernhard Fischer05c1e3a2006-09-30 21:10:54 +020017487 if (symtree == NULL)
17488 return;
17489
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017490 gfc_resolve_uops (symtree->left);
17491 gfc_resolve_uops (symtree->right);
17492
Kaveh R. Ghazia1ee9852008-07-19 16:22:12 +000017493 for (itr = symtree->n.uop->op; itr; itr = itr->next)
Daniel Kraft94747282009-08-10 12:51:46 +020017494 check_uop_procedure (itr->sym, itr->sym->declared_at);
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017495}
17496
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017497
H.J. Luefb08282006-02-05 19:53:00 +000017498/* Examine all of the expressions associated with a program unit,
17499 assign types to all intermediate expressions, make sure that all
17500 assignments are to compatible types and figure out which names
17501 refer to which functions or subroutines. It doesn't check code
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020017502 block, which is handled by gfc_resolve_code. */
Diego Novillo6de9cd92004-05-13 02:41:07 -040017503
H.J. Luefb08282006-02-05 19:53:00 +000017504static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017505resolve_types (gfc_namespace *ns)
Diego Novillo6de9cd92004-05-13 02:41:07 -040017506{
H.J. Luefb08282006-02-05 19:53:00 +000017507 gfc_namespace *n;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017508 gfc_charlen *cl;
17509 gfc_data *d;
17510 gfc_equiv *eq;
Daniel Krafta82f1f22008-09-05 22:51:50 +020017511 gfc_namespace* old_ns = gfc_current_ns;
Mark Egglestone4a5f732020-01-17 08:49:25 +000017512 bool recursive = ns->proc_name && ns->proc_name->attr.recursive;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017513
Mikael Morin2b91aea2015-03-25 10:15:46 +000017514 if (ns->types_resolved)
17515 return;
17516
Daniel Kraft52f49932008-09-02 10:13:21 +020017517 /* Check that all IMPLICIT types are ok. */
17518 if (!ns->seen_implicit_none)
17519 {
17520 unsigned letter;
17521 for (letter = 0; letter != GFC_LETTERS; ++letter)
17522 if (ns->set_flag[letter]
Paul Thomas22c23882014-10-18 14:35:51 +000017523 && !resolve_typespec_used (&ns->default_type[letter],
Janne Blomqvist524af0d2013-04-11 00:36:58 +030017524 &ns->implicit_loc[letter], NULL))
Daniel Kraft52f49932008-09-02 10:13:21 +020017525 return;
17526 }
17527
Daniel Krafta82f1f22008-09-05 22:51:50 +020017528 gfc_current_ns = ns;
17529
Paul Thomas0f3162e2006-02-24 13:54:06 +000017530 resolve_entries (ns);
17531
Mikael Morin6dcab502015-10-04 12:07:50 +000017532 resolve_common_vars (&ns->blank_common, false);
Tobias Burnusad22b1f2007-07-03 23:41:34 +020017533 resolve_common_blocks (ns->common_root);
17534
Paul Thomas0f3162e2006-02-24 13:54:06 +000017535 resolve_contained_functions (ns);
17536
Tobias Burnus12578be2011-04-29 18:49:53 +020017537 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
17538 && ns->proc_name->attr.if_source == IFSRC_IFBODY)
Tobias Burnus3ab216a2020-04-02 18:27:09 +020017539 gfc_resolve_formal_arglist (ns->proc_name);
Tobias Burnus12578be2011-04-29 18:49:53 +020017540
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000017541 gfc_traverse_ns (ns, resolve_bind_c_derived_types);
17542
Tobias Schlüter5cd09fa2007-04-12 20:48:06 +020017543 for (cl = ns->cl_list; cl; cl = cl->next)
17544 resolve_charlen (cl);
17545
Diego Novillo6de9cd92004-05-13 02:41:07 -040017546 gfc_traverse_ns (ns, resolve_symbol);
17547
Jakub Jelinekcf4d2462005-06-01 12:00:19 +020017548 resolve_fntype (ns);
17549
Diego Novillo6de9cd92004-05-13 02:41:07 -040017550 for (n = ns->contained; n; n = n->sibling)
17551 {
17552 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
Tobias Burnusa4d9b222014-12-13 00:12:06 +010017553 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
Diego Novillo6de9cd92004-05-13 02:41:07 -040017554 "also be PURE", n->proc_name->name,
17555 &n->proc_name->declared_at);
17556
H.J. Luefb08282006-02-05 19:53:00 +000017557 resolve_types (n);
Diego Novillo6de9cd92004-05-13 02:41:07 -040017558 }
17559
17560 forall_flag = 0;
Thomas Koenigce96d372013-09-02 22:09:07 +000017561 gfc_do_concurrent_flag = 0;
Diego Novillo6de9cd92004-05-13 02:41:07 -040017562 gfc_check_interfaces (ns);
17563
Diego Novillo6de9cd92004-05-13 02:41:07 -040017564 gfc_traverse_ns (ns, resolve_values);
17565
Mark Egglestone4a5f732020-01-17 08:49:25 +000017566 if (ns->save_all || (!flag_automatic && !recursive))
Diego Novillo6de9cd92004-05-13 02:41:07 -040017567 gfc_save_all (ns);
17568
17569 iter_stack = NULL;
17570 for (d = ns->data; d; d = d->next)
17571 resolve_data (d);
17572
17573 iter_stack = NULL;
17574 gfc_traverse_ns (ns, gfc_formalize_init_value);
17575
Christopher D. Ricketta8b3b0b2007-07-02 02:47:21 +000017576 gfc_traverse_ns (ns, gfc_verify_binding_labels);
17577
Diego Novillo6de9cd92004-05-13 02:41:07 -040017578 for (eq = ns->equiv; eq; eq = eq->next)
17579 resolve_equivalence (eq);
17580
Diego Novillo6de9cd92004-05-13 02:41:07 -040017581 /* Warn about unused labels. */
Bernhard Fischer2e5758e2006-10-15 14:12:59 +020017582 if (warn_unused_label)
Steven G. Kargl994c1cc2006-08-06 01:38:46 +000017583 warn_unused_fortran_label (ns->st_labels);
Paul Thomas0e3e65b2006-04-21 05:10:22 +000017584
17585 gfc_resolve_uops (ns->uop_root);
Daniel Krafta82f1f22008-09-05 22:51:50 +020017586
Paul Thomase73d3ca2016-08-31 05:36:22 +000017587 gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
17588
Jakub Jelinekdd2fc522014-05-11 22:26:36 +020017589 gfc_resolve_omp_declare_simd (ns);
17590
Jakub Jelinek5f236712014-06-06 09:24:38 +020017591 gfc_resolve_omp_udrs (ns->omp_udr_root);
17592
Mikael Morin2b91aea2015-03-25 10:15:46 +000017593 ns->types_resolved = 1;
17594
Daniel Krafta82f1f22008-09-05 22:51:50 +020017595 gfc_current_ns = old_ns;
H.J. Luefb08282006-02-05 19:53:00 +000017596}
17597
17598
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020017599/* Call gfc_resolve_code recursively. */
H.J. Luefb08282006-02-05 19:53:00 +000017600
17601static void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017602resolve_codes (gfc_namespace *ns)
H.J. Luefb08282006-02-05 19:53:00 +000017603{
17604 gfc_namespace *n;
Paul Thomas71a77782009-03-30 19:35:14 +000017605 bitmap_obstack old_obstack;
H.J. Luefb08282006-02-05 19:53:00 +000017606
Janus Weil611c64f2010-11-05 19:14:52 +010017607 if (ns->resolved == 1)
17608 return;
17609
H.J. Luefb08282006-02-05 19:53:00 +000017610 for (n = ns->contained; n; n = n->sibling)
17611 resolve_codes (n);
17612
17613 gfc_current_ns = ns;
Janus Weil76d02e92009-10-22 10:53:26 +020017614
17615 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
17616 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL))
17617 cs_base = NULL;
17618
Paul Thomas0e9a4452006-06-07 07:20:39 +000017619 /* Set to an out of range value. */
17620 current_entry_id = -1;
Tobias Schlüter0615f922007-04-13 15:48:08 +020017621
Paul Thomas71a77782009-03-30 19:35:14 +000017622 old_obstack = labels_obstack;
Tobias Schlüter0615f922007-04-13 15:48:08 +020017623 bitmap_obstack_initialize (&labels_obstack);
Paul Thomas71a77782009-03-30 19:35:14 +000017624
Thomas Schwinge41dbbb32015-01-15 21:11:12 +010017625 gfc_resolve_oacc_declare (ns);
Thomas Schwingef6bf4bc2019-03-21 21:02:42 +010017626 gfc_resolve_oacc_routines (ns);
Jakub Jelinekcd30a0b2017-10-19 09:38:59 +020017627 gfc_resolve_omp_local_vars (ns);
Jakub Jelinekb46ebd62014-06-24 09:45:22 +020017628 gfc_resolve_code (ns->code, ns);
Paul Thomas71a77782009-03-30 19:35:14 +000017629
Tobias Schlüter0615f922007-04-13 15:48:08 +020017630 bitmap_obstack_release (&labels_obstack);
Paul Thomas71a77782009-03-30 19:35:14 +000017631 labels_obstack = old_obstack;
H.J. Luefb08282006-02-05 19:53:00 +000017632}
17633
17634
17635/* This function is called after a complete program unit has been compiled.
17636 Its purpose is to examine all of the expressions associated with a program
17637 unit, assign types to all intermediate expressions, make sure that all
17638 assignments are to compatible types and figure out which names refer to
17639 which functions or subroutines. */
17640
17641void
Steven G. Kargledf1eac2007-01-20 22:01:41 +000017642gfc_resolve (gfc_namespace *ns)
H.J. Luefb08282006-02-05 19:53:00 +000017643{
17644 gfc_namespace *old_ns;
Paul Thomas3af8d8c2009-08-01 13:45:12 +000017645 code_stack *old_cs_base;
Mikael Morinf0e99402015-06-19 12:50:00 +000017646 struct gfc_omp_saved_state old_omp_state;
H.J. Luefb08282006-02-05 19:53:00 +000017647
Paul Thomas71a77782009-03-30 19:35:14 +000017648 if (ns->resolved)
17649 return;
17650
Paul Thomas3af8d8c2009-08-01 13:45:12 +000017651 ns->resolved = -1;
H.J. Luefb08282006-02-05 19:53:00 +000017652 old_ns = gfc_current_ns;
Paul Thomas3af8d8c2009-08-01 13:45:12 +000017653 old_cs_base = cs_base;
H.J. Luefb08282006-02-05 19:53:00 +000017654
Mikael Morinf0e99402015-06-19 12:50:00 +000017655 /* As gfc_resolve can be called during resolution of an OpenMP construct
17656 body, we should clear any state associated to it, so that say NS's
17657 DO loops are not interpreted as OpenMP loops. */
Jakub Jelinek1cad9282016-08-19 17:30:33 +020017658 if (!ns->construct_entities)
17659 gfc_omp_save_and_clear_state (&old_omp_state);
Mikael Morinf0e99402015-06-19 12:50:00 +000017660
H.J. Luefb08282006-02-05 19:53:00 +000017661 resolve_types (ns);
Alessandro Fanfarillo4d382322012-12-01 08:00:22 +000017662 component_assignment_level = 0;
H.J. Luefb08282006-02-05 19:53:00 +000017663 resolve_codes (ns);
Diego Novillo6de9cd92004-05-13 02:41:07 -040017664
Tobias Burnuse2a22842022-10-05 19:25:27 +020017665 if (ns->omp_assumes)
17666 gfc_resolve_omp_assumptions (ns->omp_assumes);
17667
Diego Novillo6de9cd92004-05-13 02:41:07 -040017668 gfc_current_ns = old_ns;
Paul Thomas3af8d8c2009-08-01 13:45:12 +000017669 cs_base = old_cs_base;
Paul Thomas71a77782009-03-30 19:35:14 +000017670 ns->resolved = 1;
Thomas Koenig601d98b2010-07-25 19:31:37 +000017671
17672 gfc_run_passes (ns);
Mikael Morinf0e99402015-06-19 12:50:00 +000017673
Jakub Jelinek1cad9282016-08-19 17:30:33 +020017674 if (!ns->construct_entities)
17675 gfc_omp_restore_state (&old_omp_state);
Diego Novillo6de9cd92004-05-13 02:41:07 -040017676}