Ralf Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 1 | /* Perform type resolution on the various structures. |
Jakub Jelinek | 7adcbaf | 2022-01-03 10:42:10 +0100 | [diff] [blame] | 2 | Copyright (C) 2001-2022 Free Software Foundation, Inc. |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3 | Contributed by Andy Vaught |
| 4 | |
Tobias Schlüter | 9fc4d79 | 2004-05-14 15:00:04 +0200 | [diff] [blame] | 5 | This file is part of GCC. |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 6 | |
Tobias Schlüter | 9fc4d79 | 2004-05-14 15:00:04 +0200 | [diff] [blame] | 7 | GCC is free software; you can redistribute it and/or modify it under |
| 8 | the terms of the GNU General Public License as published by the Free |
Nick Clifton | d234d78 | 2007-08-01 16:29:36 +0000 | [diff] [blame] | 9 | Software Foundation; either version 3, or (at your option) any later |
Tobias Schlüter | 9fc4d79 | 2004-05-14 15:00:04 +0200 | [diff] [blame] | 10 | version. |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11 | |
Tobias Schlüter | 9fc4d79 | 2004-05-14 15:00:04 +0200 | [diff] [blame] | 12 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| 13 | WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| 14 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| 15 | for more details. |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16 | |
| 17 | You should have received a copy of the GNU General Public License |
Nick Clifton | d234d78 | 2007-08-01 16:29:36 +0000 | [diff] [blame] | 18 | along with GCC; see the file COPYING3. If not see |
| 19 | <http://www.gnu.org/licenses/>. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 20 | |
| 21 | #include "config.h" |
Steven G. Kargl | d22e489 | 2005-01-03 21:43:55 +0000 | [diff] [blame] | 22 | #include "system.h" |
Steven Bosscher | 953bee7 | 2012-07-08 09:55:02 +0000 | [diff] [blame] | 23 | #include "coretypes.h" |
Andrew MacLeod | 1916bcb | 2015-07-09 11:27:35 +0000 | [diff] [blame] | 24 | #include "options.h" |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 25 | #include "bitmap.h" |
Andrew MacLeod | 2adfab8 | 2015-10-29 15:27:20 +0000 | [diff] [blame] | 26 | #include "gfortran.h" |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 27 | #include "arith.h" /* For gfc_compare_expr(). */ |
Richard Sandiford | 1524f80 | 2005-12-13 05:23:12 +0000 | [diff] [blame] | 28 | #include "dependency.h" |
Francois-Xavier Coudert | ca39e6f | 2007-10-05 12:33:07 +0000 | [diff] [blame] | 29 | #include "data.h" |
Tobias Burnus | 00a4618 | 2007-12-08 22:46:56 +0100 | [diff] [blame] | 30 | #include "target-memory.h" /* for gfc_simplify_transfer */ |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 31 | #include "constructor.h" |
Steven G. Kargl | d22e489 | 2005-01-03 21:43:55 +0000 | [diff] [blame] | 32 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 33 | /* Types used in equivalence statements. */ |
| 34 | |
Trevor Saunders | a79683d | 2015-08-19 02:48:48 +0000 | [diff] [blame] | 35 | enum seq_type |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 36 | { |
| 37 | SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED |
Trevor Saunders | a79683d | 2015-08-19 02:48:48 +0000 | [diff] [blame] | 38 | }; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 39 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 40 | /* Stack to keep track of the nesting of blocks as we move through the |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 41 | code. See resolve_branch() and gfc_resolve_code(). */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 42 | |
| 43 | typedef struct code_stack |
| 44 | { |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 45 | struct gfc_code *head, *current; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 46 | struct code_stack *prev; |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 47 | |
| 48 | /* This bitmap keeps track of the targets valid for a branch from |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 49 | inside this block except for END {IF|SELECT}s of enclosing |
| 50 | blocks. */ |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 51 | bitmap reachable_labels; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 52 | } |
| 53 | code_stack; |
| 54 | |
| 55 | static code_stack *cs_base = NULL; |
| 56 | |
| 57 | |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 58 | /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 59 | |
| 60 | static int forall_flag; |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 61 | int gfc_do_concurrent_flag; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 62 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 63 | /* True when we are resolving an expression that is an actual argument to |
| 64 | a procedure. */ |
| 65 | static bool actual_arg = false; |
| 66 | /* True when we are resolving an expression that is the first actual argument |
| 67 | to a procedure. */ |
| 68 | static bool first_actual_arg = false; |
| 69 | |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 70 | |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 71 | /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ |
| 72 | |
| 73 | static int omp_workshare_flag; |
| 74 | |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 75 | /* True if we are processing a formal arglist. The corresponding function |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 76 | resets the flag each time that it is read. */ |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 77 | static bool formal_arg_flag = false; |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 78 | |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 79 | /* True if we are resolving a specification expression. */ |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 80 | static bool specification_expr = false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 81 | |
| 82 | /* The id of the last entry seen. */ |
| 83 | static int current_entry_id; |
| 84 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 85 | /* We use bitmaps to determine if a branch target is valid. */ |
| 86 | static bitmap_obstack labels_obstack; |
| 87 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 88 | /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ |
| 89 | static bool inquiry_argument = false; |
| 90 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 91 | |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 92 | bool |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 93 | gfc_is_formal_arg (void) |
| 94 | { |
| 95 | return formal_arg_flag; |
| 96 | } |
| 97 | |
Paul Thomas | c867b7b | 2009-04-20 21:55:26 +0000 | [diff] [blame] | 98 | /* Is the symbol host associated? */ |
| 99 | static bool |
| 100 | is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) |
| 101 | { |
| 102 | for (ns = ns->parent; ns; ns = ns->parent) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 103 | { |
Paul Thomas | c867b7b | 2009-04-20 21:55:26 +0000 | [diff] [blame] | 104 | if (sym->ns == ns) |
| 105 | return true; |
| 106 | } |
| 107 | |
| 108 | return false; |
| 109 | } |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 110 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 115 | static bool |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 116 | resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) |
| 117 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 118 | if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 119 | { |
| 120 | if (where) |
| 121 | { |
| 122 | if (name) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 123 | gfc_error ("%qs at %L is of the ABSTRACT type %qs", |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 124 | name, where, ts->u.derived->name); |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 125 | else |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 126 | gfc_error ("ABSTRACT type %qs used at %L", |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 127 | ts->u.derived->name, where); |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 128 | } |
| 129 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 130 | return false; |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 131 | } |
| 132 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 133 | return true; |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 134 | } |
| 135 | |
| 136 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 137 | static bool |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 138 | check_proc_interface (gfc_symbol *ifc, locus *where) |
| 139 | { |
| 140 | /* Several checks for F08:C1216. */ |
| 141 | if (ifc->attr.procedure) |
| 142 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 143 | gfc_error ("Interface %qs at %L is declared " |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 144 | "in a later PROCEDURE statement", ifc->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 145 | return false; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 146 | } |
| 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 156 | gfc_error ("Interface %qs at %L may not be generic", |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 157 | ifc->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 158 | return false; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 159 | } |
| 160 | } |
| 161 | if (ifc->attr.proc == PROC_ST_FUNCTION) |
| 162 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 163 | gfc_error ("Interface %qs at %L may not be a statement function", |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 164 | ifc->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 165 | return false; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 166 | } |
| 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 172 | gfc_error ("Intrinsic procedure %qs not allowed in " |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 173 | "PROCEDURE statement at %L", ifc->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 174 | return false; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 175 | } |
| 176 | if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') |
| 177 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 178 | gfc_error ("Interface %qs at %L must be explicit", ifc->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 179 | return false; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 180 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 181 | return true; |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 182 | } |
| 183 | |
| 184 | |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 185 | static void resolve_symbol (gfc_symbol *sym); |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 186 | |
| 187 | |
| 188 | /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ |
| 189 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 190 | static bool |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 191 | resolve_procedure_interface (gfc_symbol *sym) |
| 192 | { |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 193 | gfc_symbol *ifc = sym->ts.interface; |
| 194 | |
| 195 | if (!ifc) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 196 | return true; |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 197 | |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 198 | if (ifc == sym) |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 199 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 200 | gfc_error ("PROCEDURE %qs at %L may not be used as its own interface", |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 201 | sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 202 | return false; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 203 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 204 | if (!check_proc_interface (ifc, &sym->declared_at)) |
| 205 | return false; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 206 | |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 207 | if (ifc->attr.if_source || ifc->attr.intrinsic) |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 208 | { |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 209 | /* Resolve interface and copy attributes. */ |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 210 | resolve_symbol (ifc); |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 211 | if (ifc->attr.intrinsic) |
Janus Weil | 2dda89a | 2012-07-30 21:55:41 +0200 | [diff] [blame] | 212 | gfc_resolve_intrinsic (ifc, &ifc->declared_at); |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 213 | |
| 214 | if (ifc->result) |
Janus Weil | c79bb35 | 2011-02-09 23:59:02 +0100 | [diff] [blame] | 215 | { |
| 216 | sym->ts = ifc->result->ts; |
Janus Weil | d809e15 | 2016-11-14 17:55:01 +0100 | [diff] [blame] | 217 | 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 Weil | c79bb35 | 2011-02-09 23:59:02 +0100 | [diff] [blame] | 222 | sym->result = sym; |
| 223 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 224 | else |
Janus Weil | d809e15 | 2016-11-14 17:55:01 +0100 | [diff] [blame] | 225 | { |
| 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 Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 233 | sym->ts.interface = ifc; |
| 234 | sym->attr.function = ifc->attr.function; |
| 235 | sym->attr.subroutine = ifc->attr.subroutine; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 236 | |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 237 | sym->attr.pure = ifc->attr.pure; |
| 238 | sym->attr.elemental = ifc->attr.elemental; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 239 | 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 Weil | 8be3d7d | 2010-11-11 22:44:15 +0100 | [diff] [blame] | 243 | sym->attr.is_bind_c = ifc->attr.is_bind_c; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 244 | /* 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 Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 248 | if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 249 | && !gfc_resolve_expr (sym->ts.u.cl->length)) |
| 250 | return false; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 251 | } |
| 252 | } |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 253 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 254 | return true; |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 255 | } |
| 256 | |
| 257 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 258 | /* 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 Burnus | 3ab216a | 2020-04-02 18:27:09 +0200 | [diff] [blame] | 267 | void |
| 268 | gfc_resolve_formal_arglist (gfc_symbol *proc) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 269 | { |
| 270 | gfc_formal_arglist *f; |
| 271 | gfc_symbol *sym; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 272 | bool saved_specification_expr; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 273 | int i; |
| 274 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 275 | 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 282 | || (sym->as && sym->as->rank != 0)) |
Francois-Xavier Coudert | 43e7fd2 | 2008-02-28 15:42:21 +0000 | [diff] [blame] | 283 | { |
| 284 | proc->attr.always_explicit = 1; |
| 285 | sym->attr.always_explicit = 1; |
| 286 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 287 | |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 288 | formal_arg_flag = true; |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 289 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 290 | for (f = proc->formal; f; f = f->next) |
| 291 | { |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 292 | gfc_array_spec *as; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 293 | |
Tobias Burnus | 6220bf4 | 2012-07-21 11:37:18 +0200 | [diff] [blame] | 294 | sym = f->sym; |
| 295 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 296 | if (sym == NULL) |
| 297 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 298 | /* Alternate return placeholder. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 299 | if (gfc_elemental (proc)) |
| 300 | gfc_error ("Alternate return specifier in elemental subroutine " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 301 | "%qs at %L is not allowed", proc->name, |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 302 | &proc->declared_at); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 303 | if (proc->attr.function) |
| 304 | gfc_error ("Alternate return specifier in function " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 305 | "%qs at %L is not allowed", proc->name, |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 306 | &proc->declared_at); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 307 | continue; |
| 308 | } |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 309 | else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 310 | && !resolve_procedure_interface (sym)) |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 311 | return; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 312 | |
Bud Davis | 9281625 | 2013-05-27 14:16:36 +0000 | [diff] [blame] | 313 | if (strcmp (proc->name, sym->name) == 0) |
| 314 | { |
| 315 | gfc_error ("Self-referential argument " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 316 | "%qs at %L is not allowed", sym->name, |
Bud Davis | 9281625 | 2013-05-27 14:16:36 +0000 | [diff] [blame] | 317 | &proc->declared_at); |
| 318 | return; |
| 319 | } |
| 320 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 321 | if (sym->attr.if_source != IFSRC_UNKNOWN) |
Tobias Burnus | 3ab216a | 2020-04-02 18:27:09 +0200 | [diff] [blame] | 322 | gfc_resolve_formal_arglist (sym); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 323 | |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 324 | if (sym->attr.subroutine || sym->attr.external) |
Janus Weil | 4056cc1 | 2011-09-29 13:57:35 +0200 | [diff] [blame] | 325 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 326 | if (sym->attr.flavor == FL_UNKNOWN) |
| 327 | gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); |
Janus Weil | 4056cc1 | 2011-09-29 13:57:35 +0200 | [diff] [blame] | 328 | } |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 329 | else |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 330 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 331 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 334 | } |
| 335 | |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 336 | as = sym->ts.type == BT_CLASS && sym->attr.class_ok |
| 337 | ? CLASS_DATA (sym)->as : sym->as; |
| 338 | |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 339 | saved_specification_expr = specification_expr; |
| 340 | specification_expr = true; |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 341 | gfc_resolve_array_spec (as, 0); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 342 | specification_expr = saved_specification_expr; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 343 | |
| 344 | /* We can't tell if an array with dimension (:) is assumed or deferred |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 345 | shape until we know if it has the pointer or allocatable attributes. |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 346 | */ |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 347 | 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 Burnus | 12578be | 2011-04-29 18:49:53 +0200 | [diff] [blame] | 353 | && sym->attr.flavor != FL_PROCEDURE) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 354 | { |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 355 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 358 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 359 | |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 360 | if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 361 | || (as && as->type == AS_ASSUMED_RANK) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 362 | || sym->attr.pointer || sym->attr.allocatable || sym->attr.target |
Tobias Burnus | 3d333a2 | 2012-07-19 22:20:17 +0200 | [diff] [blame] | 363 | || (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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 367 | || sym->attr.optional) |
Francois-Xavier Coudert | 43e7fd2 | 2008-02-28 15:42:21 +0000 | [diff] [blame] | 368 | { |
| 369 | proc->attr.always_explicit = 1; |
| 370 | if (proc->result) |
| 371 | proc->result->attr.always_explicit = 1; |
| 372 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 373 | |
| 374 | /* If the flavor is unknown at this point, it has to be a variable. |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 375 | A procedure specification would have already set the type. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 376 | |
| 377 | if (sym->attr.flavor == FL_UNKNOWN) |
Tobias Schlüter | 231b2fc | 2005-02-07 23:16:13 +0100 | [diff] [blame] | 378 | gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 379 | |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 380 | if (gfc_pure (proc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 381 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 382 | if (sym->attr.flavor == FL_PROCEDURE) |
Tobias Burnus | a26e8df | 2011-02-11 22:07:17 +0100 | [diff] [blame] | 383 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 384 | /* F08:C1279. */ |
| 385 | if (!gfc_pure (sym)) |
| 386 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 387 | gfc_error ("Dummy procedure %qs of PURE procedure at %L must " |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 388 | "also be PURE", sym->name, &sym->declared_at); |
| 389 | continue; |
| 390 | } |
Tobias Burnus | a26e8df | 2011-02-11 22:07:17 +0100 | [diff] [blame] | 391 | } |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 392 | else if (!sym->attr.pointer) |
Tobias Burnus | a26e8df | 2011-02-11 22:07:17 +0100 | [diff] [blame] | 393 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 394 | if (proc->attr.function && sym->attr.intent != INTENT_IN) |
| 395 | { |
| 396 | if (sym->attr.value) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 397 | gfc_notify_std (GFC_STD_F2008, "Argument %qs" |
| 398 | " of pure function %qs at %L with VALUE " |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 399 | "attribute but without INTENT(IN)", |
| 400 | sym->name, proc->name, &sym->declared_at); |
| 401 | else |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 402 | gfc_error ("Argument %qs of pure function %qs at %L must " |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 403 | "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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 410 | gfc_notify_std (GFC_STD_F2008, "Argument %qs" |
| 411 | " of pure subroutine %qs at %L with VALUE " |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 412 | "attribute but without INTENT", sym->name, |
| 413 | proc->name, &sym->declared_at); |
| 414 | else |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 415 | gfc_error ("Argument %qs of pure subroutine %qs at %L " |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 416 | "must have its INTENT specified or have the " |
| 417 | "VALUE attribute", sym->name, proc->name, |
| 418 | &sym->declared_at); |
| 419 | } |
Tobias Burnus | a26e8df | 2011-02-11 22:07:17 +0100 | [diff] [blame] | 420 | } |
Janus Weil | c19a003 | 2014-12-27 23:40:21 +0100 | [diff] [blame] | 421 | |
| 422 | /* F08:C1278a. */ |
| 423 | if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) |
| 424 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 425 | gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" |
Janus Weil | c19a003 | 2014-12-27 23:40:21 +0100 | [diff] [blame] | 426 | " may not be polymorphic", sym->name, proc->name, |
| 427 | &sym->declared_at); |
| 428 | continue; |
| 429 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 430 | } |
| 431 | |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 432 | if (proc->attr.implicit_pure) |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 433 | { |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 434 | if (sym->attr.flavor == FL_PROCEDURE) |
| 435 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 436 | if (!gfc_pure (sym)) |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 437 | proc->attr.implicit_pure = 0; |
| 438 | } |
| 439 | else if (!sym->attr.pointer) |
| 440 | { |
Tobias Burnus | c915f8b | 2012-09-13 16:57:38 +0200 | [diff] [blame] | 441 | if (proc->attr.function && sym->attr.intent != INTENT_IN |
| 442 | && !sym->value) |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 443 | proc->attr.implicit_pure = 0; |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 444 | |
Tobias Burnus | c915f8b | 2012-09-13 16:57:38 +0200 | [diff] [blame] | 445 | if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN |
| 446 | && !sym->value) |
Janus Weil | fe445bf | 2011-10-16 21:16:59 +0200 | [diff] [blame] | 447 | proc->attr.implicit_pure = 0; |
| 448 | } |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 449 | } |
| 450 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 451 | if (gfc_elemental (proc)) |
| 452 | { |
Janus Weil | 4056cc1 | 2011-09-29 13:57:35 +0200 | [diff] [blame] | 453 | /* F08:C1289. */ |
Tobias Burnus | 9775a92 | 2012-01-27 14:02:54 +0100 | [diff] [blame] | 454 | if (sym->attr.codimension |
| 455 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| 456 | && CLASS_DATA (sym)->attr.codimension)) |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 457 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 458 | gfc_error ("Coarray dummy argument %qs at %L to elemental " |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 459 | "procedure", sym->name, &sym->declared_at); |
| 460 | continue; |
| 461 | } |
| 462 | |
Tobias Burnus | 9775a92 | 2012-01-27 14:02:54 +0100 | [diff] [blame] | 463 | if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| 464 | && CLASS_DATA (sym)->as)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 465 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 466 | gfc_error ("Argument %qs of elemental procedure at %L must " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 467 | "be scalar", sym->name, &sym->declared_at); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 468 | continue; |
| 469 | } |
| 470 | |
Tobias Burnus | 9775a92 | 2012-01-27 14:02:54 +0100 | [diff] [blame] | 471 | if (sym->attr.allocatable |
| 472 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| 473 | && CLASS_DATA (sym)->attr.allocatable)) |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 474 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 475 | gfc_error ("Argument %qs of elemental procedure at %L cannot " |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 476 | "have the ALLOCATABLE attribute", sym->name, |
| 477 | &sym->declared_at); |
| 478 | continue; |
| 479 | } |
| 480 | |
Tobias Burnus | c696c6f | 2012-01-27 14:59:04 +0100 | [diff] [blame] | 481 | if (sym->attr.pointer |
| 482 | || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| 483 | && CLASS_DATA (sym)->attr.class_pointer)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 484 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 485 | gfc_error ("Argument %qs of elemental procedure at %L cannot " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 486 | "have the POINTER attribute", sym->name, |
| 487 | &sym->declared_at); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 488 | continue; |
| 489 | } |
Tobias Burnus | 242633d | 2008-01-06 10:18:43 +0100 | [diff] [blame] | 490 | |
| 491 | if (sym->attr.flavor == FL_PROCEDURE) |
| 492 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 493 | gfc_error ("Dummy procedure %qs not allowed in elemental " |
| 494 | "procedure %qs at %L", sym->name, proc->name, |
Tobias Burnus | 242633d | 2008-01-06 10:18:43 +0100 | [diff] [blame] | 495 | &sym->declared_at); |
| 496 | continue; |
| 497 | } |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 498 | |
Tobias Burnus | 25ffd46 | 2012-12-16 00:25:36 +0100 | [diff] [blame] | 499 | /* Fortran 2008 Corrigendum 1, C1290a. */ |
| 500 | if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 501 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 502 | gfc_error ("Argument %qs of elemental procedure %qs at %L must " |
Tobias Burnus | 25ffd46 | 2012-12-16 00:25:36 +0100 | [diff] [blame] | 503 | "have its INTENT specified or have the VALUE " |
| 504 | "attribute", sym->name, proc->name, |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 505 | &sym->declared_at); |
| 506 | continue; |
| 507 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 508 | } |
| 509 | |
| 510 | /* Each dummy shall be specified to be scalar. */ |
| 511 | if (proc->attr.proc == PROC_ST_FUNCTION) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 512 | { |
| 513 | if (sym->as != NULL) |
| 514 | { |
Francois-Xavier Coudert | 5f0367d | 2018-02-11 18:55:31 +0000 | [diff] [blame] | 515 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 520 | continue; |
| 521 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 522 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 523 | if (sym->ts.type == BT_CHARACTER) |
| 524 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 525 | gfc_charlen *cl = sym->ts.u.cl; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 526 | if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) |
| 527 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 528 | gfc_error ("Character-valued argument %qs of statement " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 529 | "function at %L must have constant length", |
| 530 | sym->name, &sym->declared_at); |
| 531 | continue; |
| 532 | } |
| 533 | } |
| 534 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 535 | } |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 536 | formal_arg_flag = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 537 | } |
| 538 | |
| 539 | |
| 540 | /* Work function called when searching for symbols that have argument lists |
| 541 | associated with them. */ |
| 542 | |
| 543 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 544 | find_arglists (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 545 | { |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 546 | if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 547 | || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 548 | return; |
| 549 | |
Tobias Burnus | 3ab216a | 2020-04-02 18:27:09 +0200 | [diff] [blame] | 550 | gfc_resolve_formal_arglist (sym); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 551 | } |
| 552 | |
| 553 | |
| 554 | /* Given a namespace, resolve all formal argument lists within the namespace. |
| 555 | */ |
| 556 | |
| 557 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 558 | resolve_formal_arglists (gfc_namespace *ns) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 559 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 560 | if (ns == NULL) |
| 561 | return; |
| 562 | |
| 563 | gfc_traverse_ns (ns, find_arglists); |
| 564 | } |
| 565 | |
| 566 | |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 567 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 568 | resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 569 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 570 | bool t; |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 571 | |
Paul Thomas | 345bd7e | 2016-12-09 11:55:27 +0000 | [diff] [blame] | 572 | 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 Burnus | b5bf3e4 | 2007-11-18 17:35:12 +0100 | [diff] [blame] | 580 | /* 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 Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 584 | return; |
| 585 | |
Steven G. Kargl | ee3aab6 | 2019-06-19 17:58:54 +0000 | [diff] [blame] | 586 | if (!sym->result) |
| 587 | return; |
| 588 | |
Paul Brook | 0dd973d | 2005-01-22 15:24:09 +0000 | [diff] [blame] | 589 | /* Try to find out of what the return type is. */ |
Janus Weil | f990982 | 2009-06-18 10:09:40 +0200 | [diff] [blame] | 590 | if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL) |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 591 | { |
Tobias Burnus | c2de0c1 | 2007-05-27 23:24:48 +0200 | [diff] [blame] | 592 | t = gfc_set_default_type (sym->result, 0, ns); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 593 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 594 | if (!t && !sym->result->attr.untyped) |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 595 | { |
Tobias Burnus | c2de0c1 | 2007-05-27 23:24:48 +0200 | [diff] [blame] | 596 | if (sym->result == sym) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 597 | gfc_error ("Contained function %qs at %L has no IMPLICIT type", |
Tobias Burnus | c2de0c1 | 2007-05-27 23:24:48 +0200 | [diff] [blame] | 598 | sym->name, &sym->declared_at); |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 599 | else if (!sym->result->attr.proc_pointer) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 600 | gfc_error ("Result %qs of contained function %qs at %L has " |
Tobias Burnus | c2de0c1 | 2007-05-27 23:24:48 +0200 | [diff] [blame] | 601 | "no IMPLICIT type", sym->result->name, sym->name, |
| 602 | &sym->result->declared_at); |
| 603 | sym->result->attr.untyped = 1; |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 604 | } |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 605 | } |
Paul Thomas | b95605f | 2005-11-21 16:05:58 +0000 | [diff] [blame] | 606 | |
Paul Thomas | 99d2293 | 2018-07-05 16:27:38 +0000 | [diff] [blame] | 607 | /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 608 | type, lists the only ways a character length value of * can be used: |
Paul Thomas | 77f72c9 | 2018-06-21 22:38:55 +0000 | [diff] [blame] | 609 | dummy arguments of procedures, named constants, function results and |
| 610 | in allocate statements if the allocate_object is an assumed length dummy |
Daniel Kraft | 6c19d9b | 2009-10-07 20:13:28 +0200 | [diff] [blame] | 611 | in external functions. Internal function results and results of module |
| 612 | procedures are not on this list, ergo, not permitted. */ |
Paul Thomas | b95605f | 2005-11-21 16:05:58 +0000 | [diff] [blame] | 613 | |
Tobias Burnus | c2de0c1 | 2007-05-27 23:24:48 +0200 | [diff] [blame] | 614 | if (sym->result->ts.type == BT_CHARACTER) |
Paul Thomas | b95605f | 2005-11-21 16:05:58 +0000 | [diff] [blame] | 615 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 616 | gfc_charlen *cl = sym->result->ts.u.cl; |
Paul Thomas | 8d51f26 | 2011-01-28 13:53:19 +0000 | [diff] [blame] | 617 | if ((!cl || !cl->length) && !sym->result->ts.deferred) |
Daniel Kraft | 6c19d9b | 2009-10-07 20:13:28 +0200 | [diff] [blame] | 618 | { |
| 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 Malcolm | 7fb22eb | 2017-03-15 18:05:06 +0000 | [diff] [blame] | 625 | 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 Kraft | 6c19d9b | 2009-10-07 20:13:28 +0200 | [diff] [blame] | 630 | sym->name, &sym->declared_at); |
| 631 | } |
Paul Thomas | b95605f | 2005-11-21 16:05:58 +0000 | [diff] [blame] | 632 | } |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 633 | } |
| 634 | |
| 635 | |
| 636 | /* Add NEW_ARGS to the formal argument list of PROC, taking care not to |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 637 | introduce duplicates. */ |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 638 | |
| 639 | static void |
| 640 | merge_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 Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 648 | /* See if this arg is already in the formal argument list. */ |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 649 | 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 Thomas | 54129a6 | 2006-12-22 20:49:00 +0000 | [diff] [blame] | 667 | /* Flag the arguments that are not present in all entries. */ |
| 668 | |
| 669 | static void |
| 670 | check_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 Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 694 | /* 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 | |
| 698 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 699 | resolve_entries (gfc_namespace *ns) |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 700 | { |
| 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 Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 720 | /* If this isn't a procedure something has gone horribly wrong. */ |
Paul Brook | 6e45f57 | 2004-09-08 14:33:03 +0000 | [diff] [blame] | 721 | gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 722 | |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 723 | /* 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 Thomas | 1a49260 | 2006-06-09 22:16:08 +0000 | [diff] [blame] | 736 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 742 | && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) |
Paul Thomas | 1a49260 | 2006-06-09 22:16:08 +0000 | [diff] [blame] | 743 | el->sym->ns = ns; |
| 744 | |
Paul Thomas | 08ee9e8 | 2007-07-31 22:14:29 +0000 | [diff] [blame] | 745 | /* 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 Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 754 | /* Add an entry statement for it. */ |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 755 | c = gfc_get_code (EXEC_ENTRY); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 756 | 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üter | 7be7d41 | 2004-08-24 18:54:52 +0200 | [diff] [blame] | 762 | Also include the function name so the user has some hope of figuring |
| 763 | out what is going on. */ |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 764 | snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", |
| 765 | master_count++, ns->proc_name->name); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 766 | gfc_get_ha_symbol (name, &proc); |
Paul Brook | 6e45f57 | 2004-09-08 14:33:03 +0000 | [diff] [blame] | 767 | gcc_assert (proc != NULL); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 768 | |
Tobias Schlüter | 231b2fc | 2005-02-07 23:16:13 +0100 | [diff] [blame] | 769 | gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 770 | if (ns->proc_name->attr.subroutine) |
Tobias Schlüter | 231b2fc | 2005-02-07 23:16:13 +0100 | [diff] [blame] | 771 | gfc_add_subroutine (&proc->attr, proc->name, NULL); |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 772 | else |
| 773 | { |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 774 | gfc_symbol *sym; |
| 775 | gfc_typespec *ts, *fts; |
Paul Thomas | 5be3827 | 2006-10-03 20:13:03 +0000 | [diff] [blame] | 776 | gfc_array_spec *as, *fas; |
Tobias Schlüter | 231b2fc | 2005-02-07 23:16:13 +0100 | [diff] [blame] | 777 | gfc_add_function (&proc->attr, proc->name, NULL); |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 778 | proc->result = proc; |
Paul Thomas | 5be3827 | 2006-10-03 20:13:03 +0000 | [diff] [blame] | 779 | fas = ns->entries->sym->as; |
| 780 | fas = fas ? fas : ns->entries->sym->result->as; |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 781 | fts = &ns->entries->sym->result->ts; |
| 782 | if (fts->type == BT_UNKNOWN) |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 783 | fts = gfc_get_default_type (ns->entries->sym->result->name, NULL); |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 784 | for (el = ns->entries->next; el; el = el->next) |
| 785 | { |
| 786 | ts = &el->sym->result->ts; |
Paul Thomas | 5be3827 | 2006-10-03 20:13:03 +0000 | [diff] [blame] | 787 | as = el->sym->as; |
| 788 | as = as ? as : el->sym->result->as; |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 789 | if (ts->type == BT_UNKNOWN) |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 790 | ts = gfc_get_default_type (el->sym->result->name, NULL); |
Paul Thomas | 5be3827 | 2006-10-03 20:13:03 +0000 | [diff] [blame] | 791 | |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 792 | 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 Thomas | f5d67ed | 2008-01-20 16:58:15 +0000 | [diff] [blame] | 798 | else if (as && fas && ns->entries->sym->result != el->sym->result |
| 799 | && gfc_compare_array_spec (as, fas) == 0) |
Tobias Burnus | 107d5ff | 2007-12-23 19:17:08 +0100 | [diff] [blame] | 800 | gfc_error ("Function %s at %L has entries with mismatched " |
Paul Thomas | 5be3827 | 2006-10-03 20:13:03 +0000 | [diff] [blame] | 801 | "array specifications", ns->entries->sym->name, |
| 802 | &ns->entries->sym->declared_at); |
Tobias Burnus | 107d5ff | 2007-12-23 19:17:08 +0100 | [diff] [blame] | 803 | /* 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 Anlauf | f9809ef | 2021-08-28 20:09:44 +0200 | [diff] [blame] | 807 | 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 Anlauf | b305ec9 | 2021-09-14 20:23:27 +0200 | [diff] [blame] | 814 | goto cleanup; |
Harald Anlauf | f9809ef | 2021-08-28 20:09:44 +0200 | [diff] [blame] | 815 | } |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 816 | 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 Weil | 9717f7a | 2012-07-17 23:51:20 +0200 | [diff] [blame] | 826 | gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " |
Tobias Burnus | 107d5ff | 2007-12-23 19:17:08 +0100 | [diff] [blame] | 827 | "entries returning variables of different " |
| 828 | "string lengths", ns->entries->sym->name, |
| 829 | &ns->entries->sym->declared_at); |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 830 | } |
| 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 Hirata | 49de9e7 | 2005-08-06 12:56:19 +0000 | [diff] [blame] | 844 | /* Otherwise the result will be passed through a union by |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 845 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 851 | { |
| 852 | if (el == ns->entries) |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 853 | gfc_error ("FUNCTION result %s cannot be an array in " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 854 | "FUNCTION %s at %L", sym->name, |
| 855 | ns->entries->sym->name, &sym->declared_at); |
| 856 | else |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 857 | gfc_error ("ENTRY result %s cannot be an array in " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 858 | "FUNCTION %s at %L", sym->name, |
| 859 | ns->entries->sym->name, &sym->declared_at); |
| 860 | } |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 861 | else if (sym->attr.pointer) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 862 | { |
| 863 | if (el == ns->entries) |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 864 | gfc_error ("FUNCTION result %s cannot be a POINTER in " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 865 | "FUNCTION %s at %L", sym->name, |
| 866 | ns->entries->sym->name, &sym->declared_at); |
| 867 | else |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 868 | gfc_error ("ENTRY result %s cannot be a POINTER in " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 869 | "FUNCTION %s at %L", sym->name, |
| 870 | ns->entries->sym->name, &sym->declared_at); |
| 871 | } |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 872 | else |
| 873 | { |
| 874 | ts = &sym->ts; |
| 875 | if (ts->type == BT_UNKNOWN) |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 876 | ts = gfc_get_default_type (sym->name, NULL); |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 877 | 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 Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 896 | case BT_UNKNOWN: |
| 897 | /* We will issue error elsewhere. */ |
| 898 | sym = NULL; |
| 899 | break; |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 900 | default: |
| 901 | break; |
| 902 | } |
| 903 | if (sym) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 904 | { |
| 905 | if (el == ns->entries) |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 906 | gfc_error ("FUNCTION result %s cannot be of type %s " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 907 | "in FUNCTION %s at %L", sym->name, |
| 908 | gfc_typename (ts), ns->entries->sym->name, |
| 909 | &sym->declared_at); |
| 910 | else |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 911 | gfc_error ("ENTRY result %s cannot be of type %s " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 912 | "in FUNCTION %s at %L", sym->name, |
| 913 | gfc_typename (ts), ns->entries->sym->name, |
| 914 | &sym->declared_at); |
| 915 | } |
Jakub Jelinek | d198b59 | 2005-04-29 17:31:39 +0200 | [diff] [blame] | 916 | } |
| 917 | } |
| 918 | } |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 919 | } |
Harald Anlauf | b305ec9 | 2021-09-14 20:23:27 +0200 | [diff] [blame] | 920 | |
| 921 | cleanup: |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 922 | 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 Thomas | 54129a6 | 2006-12-22 20:49:00 +0000 | [diff] [blame] | 929 | /* 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üter | 7be7d41 | 2004-08-24 18:54:52 +0200 | [diff] [blame] | 934 | /* Use the master function for the function body. */ |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 935 | ns->proc_name = proc; |
| 936 | |
Tobias Schlüter | 7be7d41 | 2004-08-24 18:54:52 +0200 | [diff] [blame] | 937 | /* Finalize the new symbols. */ |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 938 | gfc_commit_symbols (); |
| 939 | |
| 940 | /* Restore the original namespace. */ |
| 941 | gfc_current_ns = old_ns; |
| 942 | } |
| 943 | |
| 944 | |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 945 | /* Resolve common variables. */ |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 946 | static void |
Mikael Morin | 6dcab50 | 2015-10-04 12:07:50 +0000 | [diff] [blame] | 947 | resolve_common_vars (gfc_common_head *common_block, bool named_common) |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 948 | { |
Mikael Morin | 6dcab50 | 2015-10-04 12:07:50 +0000 | [diff] [blame] | 949 | gfc_symbol *csym = common_block->head; |
Mark Eggleston | 4d2a56a | 2020-06-11 14:33:51 +0100 | [diff] [blame] | 950 | gfc_gsymbol *gsym; |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 951 | |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 952 | for (; csym; csym = csym->common_next) |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 953 | { |
Mark Eggleston | 4d2a56a | 2020-06-11 14:33:51 +0100 | [diff] [blame] | 954 | 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 Morin | 2b3f52a | 2015-10-04 12:30:16 +0000 | [diff] [blame] | 960 | /* 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 Anlauf | 0f7cec0 | 2019-02-17 21:19:20 +0000 | [diff] [blame] | 964 | { |
| 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 Morin | 2b3f52a | 2015-10-04 12:30:16 +0000 | [diff] [blame] | 969 | |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 970 | if (csym->value || csym->attr.data) |
| 971 | { |
| 972 | if (!csym->ns->is_block_data) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 973 | gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 974 | "but only in BLOCK DATA initialization is " |
| 975 | "allowed", csym->name, &csym->declared_at); |
| 976 | else if (!named_common) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 977 | gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 978 | "in a blank COMMON but initialization is only " |
| 979 | "allowed in named common blocks", csym->name, |
| 980 | &csym->declared_at); |
| 981 | } |
| 982 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 983 | if (UNLIMITED_POLY (csym)) |
Harald Anlauf | a88280c | 2021-09-01 19:05:47 +0200 | [diff] [blame] | 984 | gfc_error_now ("%qs at %L cannot appear in COMMON " |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 985 | "[F2008:C5100]", csym->name, &csym->declared_at); |
| 986 | |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 987 | if (csym->ts.type != BT_DERIVED) |
| 988 | continue; |
| 989 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 990 | if (!(csym->ts.u.derived->attr.sequence |
| 991 | || csym->ts.u.derived->attr.is_bind_c)) |
Tobias Burnus | 4daa149 | 2014-11-25 23:33:32 +0100 | [diff] [blame] | 992 | gfc_error_now ("Derived type variable %qs in COMMON at %L " |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 993 | "has neither the SEQUENCE nor the BIND(C) " |
| 994 | "attribute", csym->name, &csym->declared_at); |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 995 | if (csym->ts.u.derived->attr.alloc_comp) |
Tobias Burnus | 4daa149 | 2014-11-25 23:33:32 +0100 | [diff] [blame] | 996 | gfc_error_now ("Derived type variable %qs in COMMON at %L " |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 997 | "has an ultimate component that is " |
| 998 | "allocatable", csym->name, &csym->declared_at); |
Daniel Franke | 16e520b | 2010-05-19 09:07:25 -0400 | [diff] [blame] | 999 | if (gfc_has_default_initializer (csym->ts.u.derived)) |
Tobias Burnus | 4daa149 | 2014-11-25 23:33:32 +0100 | [diff] [blame] | 1000 | gfc_error_now ("Derived type variable %qs in COMMON at %L " |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 1001 | "may not have default initializer", csym->name, |
| 1002 | &csym->declared_at); |
Tobias Burnus | 6f9c9d6 | 2009-04-03 20:26:44 +0200 | [diff] [blame] | 1003 | |
| 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 Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1006 | } |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 1007 | } |
| 1008 | |
| 1009 | /* Resolve common blocks. */ |
| 1010 | static void |
| 1011 | resolve_common_blocks (gfc_symtree *common_root) |
| 1012 | { |
| 1013 | gfc_symbol *sym; |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1014 | gfc_gsymbol * gsym; |
Tobias Burnus | 346ecba | 2008-01-06 19:17:14 +0100 | [diff] [blame] | 1015 | |
| 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 Morin | 6dcab50 | 2015-10-04 12:07:50 +0000 | [diff] [blame] | 1024 | resolve_common_vars (common_root->n.common, true); |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 1025 | |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1026 | /* 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 1044 | gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1045 | "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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 1058 | gfc_error ("COMMON block %qs at %L uses the same global identifier " |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1059 | "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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 1066 | gfc_error ("Fortran 2008: COMMON block %qs with binding label at " |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1067 | "%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 Koenig | 55b9c61 | 2019-03-13 07:21:33 +0000 | [diff] [blame] | 1074 | gsym = gfc_get_gsymbol (common_root->n.common->name, false); |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1075 | 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'Humieres | 9845246 | 2017-12-10 20:11:18 +0100 | [diff] [blame] | 1088 | gfc_error ("COMMON block at %L with binding label %qs uses the same " |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1089 | "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 Koenig | 55b9c61 | 2019-03-13 07:21:33 +0000 | [diff] [blame] | 1096 | gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true); |
Tobias Burnus | 878cdb7 | 2013-05-20 22:03:48 +0200 | [diff] [blame] | 1097 | gsym->type = GSYM_COMMON; |
| 1098 | gsym->where = common_root->n.common->where; |
| 1099 | gsym->defined = 1; |
| 1100 | } |
| 1101 | gsym->used = 1; |
| 1102 | } |
| 1103 | |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1104 | gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); |
| 1105 | if (sym == NULL) |
| 1106 | return; |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 1107 | |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1108 | if (sym->attr.flavor == FL_PARAMETER) |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 1109 | gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1110 | sym->name, &common_root->n.common->where, &sym->declared_at); |
| 1111 | |
Janus Weil | ef71fdd | 2011-09-26 22:05:43 +0200 | [diff] [blame] | 1112 | if (sym->attr.external) |
Sandra Loosemore | 6791469 | 2019-01-09 16:37:45 -0500 | [diff] [blame] | 1113 | gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute", |
Janus Weil | ef71fdd | 2011-09-26 22:05:43 +0200 | [diff] [blame] | 1114 | sym->name, &common_root->n.common->where); |
| 1115 | |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1116 | if (sym->attr.intrinsic) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1117 | gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1118 | sym->name, &common_root->n.common->where); |
| 1119 | else if (sym->attr.result |
Janus Weil | 2d71b91 | 2009-11-26 20:01:02 +0100 | [diff] [blame] | 1120 | || gfc_is_function_return_value (sym, gfc_current_ns)) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 1121 | gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1122 | "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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 1126 | gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " |
Tobias Burnus | 041cf98 | 2007-08-26 20:29:45 +0200 | [diff] [blame] | 1127 | "that is also a global procedure", sym->name, |
| 1128 | &common_root->n.common->where); |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 1129 | } |
| 1130 | |
| 1131 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1132 | /* 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 | |
| 1141 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1142 | resolve_contained_functions (gfc_namespace *ns) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1143 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1144 | gfc_namespace *child; |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 1145 | gfc_entry_list *el; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1146 | |
| 1147 | resolve_formal_arglists (ns); |
| 1148 | |
| 1149 | for (child = ns->contained; child; child = child->sibling) |
| 1150 | { |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 1151 | /* Resolve alternate entry points first. */ |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 1152 | resolve_entries (child); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1153 | |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 1154 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1158 | } |
| 1159 | } |
| 1160 | |
| 1161 | |
Paul Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 1162 | |
| 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 | |
| 1169 | static gfc_actual_arglist *param_list, *param_tail, *param; |
| 1170 | |
| 1171 | static bool |
| 1172 | get_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 Thomas | 2fcd588 | 2017-10-07 21:14:06 +0000 | [diff] [blame] | 1193 | gfc_error ("The KIND parameter %qs in the PDT constructor " |
| 1194 | "at %C has no value", param->name); |
Paul Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 1195 | return false; |
| 1196 | } |
| 1197 | } |
| 1198 | |
| 1199 | return true; |
| 1200 | } |
| 1201 | |
| 1202 | static bool |
| 1203 | get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, |
| 1204 | gfc_symbol *derived) |
| 1205 | { |
Paul Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 1206 | gfc_constructor *cons = NULL; |
Paul Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 1207 | 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 Thomas | 2fcd588 | 2017-10-07 21:14:06 +0000 | [diff] [blame] | 1220 | if (cons->expr |
| 1221 | && cons->expr->expr_type == EXPR_STRUCTURE |
Paul Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 1222 | && 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1246 | static bool resolve_fl_derived0 (gfc_symbol *sym); |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 1247 | static bool resolve_fl_struct (gfc_symbol *sym); |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 1248 | |
| 1249 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1250 | /* Resolve all of the elements of a structure constructor and make sure that |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1251 | the types are correct. The 'init' flag indicates that the given |
| 1252 | constructor is an initializer. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1253 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1254 | static bool |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1255 | resolve_structure_cons (gfc_expr *expr, int init) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1256 | { |
| 1257 | gfc_constructor *cons; |
| 1258 | gfc_component *comp; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1259 | bool t; |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1260 | symbol_attribute a; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1261 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1262 | t = true; |
Janus Weil | bd48f123 | 2010-08-29 23:29:38 +0200 | [diff] [blame] | 1263 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 1264 | 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 Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 1270 | |
| 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 1289 | } |
Janus Weil | bd48f123 | 2010-08-29 23:29:38 +0200 | [diff] [blame] | 1290 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 1291 | /* 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 Anlauf | 12463f1 | 2022-03-01 23:13:17 +0100 | [diff] [blame] | 1296 | else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS |
| 1297 | || expr->ts.type == BT_UNION) |
| 1298 | && expr->ts.u.derived) |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 1299 | comp = expr->ts.u.derived->components; |
Harald Anlauf | 12463f1 | 2022-03-01 23:13:17 +0100 | [diff] [blame] | 1300 | else |
| 1301 | return false; |
| 1302 | |
| 1303 | cons = gfc_constructor_first (expr->value.constructor); |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 1304 | |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 1305 | for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1306 | { |
Francois-Xavier Coudert | 0df50e7 | 2007-11-21 18:32:40 +0000 | [diff] [blame] | 1307 | int rank; |
| 1308 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1309 | if (!cons->expr) |
Paul Thomas | 404d840 | 2006-10-04 04:48:35 +0000 | [diff] [blame] | 1310 | continue; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1311 | |
Fritz Reese | f8da53e | 2016-10-27 17:21:46 +0000 | [diff] [blame] | 1312 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1318 | if (!gfc_resolve_expr (cons->expr)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1319 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1320 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1321 | continue; |
| 1322 | } |
| 1323 | |
Francois-Xavier Coudert | 0df50e7 | 2007-11-21 18:32:40 +0000 | [diff] [blame] | 1324 | rank = comp->as ? comp->as->rank : 0; |
Louis Krupp | 75a3c61 | 2018-01-16 01:09:11 +0000 | [diff] [blame] | 1325 | if (comp->ts.type == BT_CLASS |
| 1326 | && !comp->ts.u.derived->attr.unlimited_polymorphic |
| 1327 | && CLASS_DATA (comp)->as) |
Paul Thomas | 3cd52c1 | 2015-02-05 08:02:58 +0000 | [diff] [blame] | 1328 | rank = CLASS_DATA (comp)->as->rank; |
| 1329 | |
Francois-Xavier Coudert | 0df50e7 | 2007-11-21 18:32:40 +0000 | [diff] [blame] | 1330 | if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank |
Janus Weil | d4b7d0f | 2008-08-23 23:04:01 +0200 | [diff] [blame] | 1331 | && (comp->attr.allocatable || cons->expr->rank)) |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1332 | { |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1333 | gfc_error ("The rank of the element in the structure " |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1334 | "constructor at %L does not match that of the " |
| 1335 | "component (%d/%d)", &cons->expr->where, |
Francois-Xavier Coudert | 0df50e7 | 2007-11-21 18:32:40 +0000 | [diff] [blame] | 1336 | cons->expr->rank, rank); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1337 | t = false; |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1338 | } |
| 1339 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1340 | /* If we don't have the right type, try to convert it. */ |
| 1341 | |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1342 | if (!comp->attr.proc_pointer && |
| 1343 | !gfc_compare_types (&cons->expr->ts, &comp->ts)) |
Paul Thomas | e0e85e0 | 2005-12-22 07:05:22 +0000 | [diff] [blame] | 1344 | { |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 1345 | if (strcmp (comp->name, "_extends") == 0) |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 1346 | { |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 1347 | /* Can afford to be brutal with the _extends initializer. |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 1348 | 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 Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 1351 | } |
| 1352 | else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 1353 | { |
| 1354 | gfc_error ("The element in the structure constructor at %L, " |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1355 | "for pointer component %qs, is %s but should be %s", |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 1356 | &cons->expr->where, comp->name, |
| 1357 | gfc_basic_typename (cons->expr->ts.type), |
| 1358 | gfc_basic_typename (comp->ts.type)); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1359 | t = false; |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 1360 | } |
Paul Thomas | e0e85e0 | 2005-12-22 07:05:22 +0000 | [diff] [blame] | 1361 | else |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 1362 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1363 | bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); |
| 1364 | if (t) |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 1365 | t = t2; |
| 1366 | } |
Paul Thomas | e0e85e0 | 2005-12-22 07:05:22 +0000 | [diff] [blame] | 1367 | } |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1368 | |
Tobias Burnus | a48a917 | 2010-08-04 13:51:32 +0200 | [diff] [blame] | 1369 | /* 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 Anlauf | 0712f35 | 2022-03-27 21:35:15 +0200 | [diff] [blame] | 1381 | 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 Burnus | a48a917 | 2010-08-04 13:51:32 +0200 | [diff] [blame] | 1392 | if (cons->expr->expr_type == EXPR_VARIABLE |
Harald Anlauf | 0712f35 | 2022-03-27 21:35:15 +0200 | [diff] [blame] | 1393 | && cons->expr->rank != 0 |
Tobias Burnus | a48a917 | 2010-08-04 13:51:32 +0200 | [diff] [blame] | 1394 | && 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 Thomas | c3879be | 2016-12-10 18:35:47 +0000 | [diff] [blame] | 1410 | |
Tobias Burnus | a48a917 | 2010-08-04 13:51:32 +0200 | [diff] [blame] | 1411 | if (cons->expr->expr_type == EXPR_ARRAY) |
| 1412 | { |
Paul Thomas | c3879be | 2016-12-10 18:35:47 +0000 | [diff] [blame] | 1413 | /* 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 Burnus | c130efd | 2010-08-04 20:49:23 +0200 | [diff] [blame] | 1416 | cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
Tobias Burnus | a48a917 | 2010-08-04 13:51:32 +0200 | [diff] [blame] | 1417 | 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 Thomas | c1203a7 | 2008-03-24 19:11:24 +0000 | [diff] [blame] | 1423 | if (cons->expr->expr_type == EXPR_NULL |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 1424 | && !(comp->attr.pointer || comp->attr.allocatable |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 1425 | || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 1426 | || (comp->ts.type == BT_CLASS |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 1427 | && (CLASS_DATA (comp)->attr.class_pointer |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 1428 | || CLASS_DATA (comp)->attr.allocatable)))) |
Paul Thomas | c1203a7 | 2008-03-24 19:11:24 +0000 | [diff] [blame] | 1429 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1430 | t = false; |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1431 | gfc_error ("The NULL in the structure constructor at %L is " |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1432 | "being applied to component %qs, which is neither " |
Paul Thomas | c1203a7 | 2008-03-24 19:11:24 +0000 | [diff] [blame] | 1433 | "a POINTER nor ALLOCATABLE", &cons->expr->where, |
| 1434 | comp->name); |
| 1435 | } |
| 1436 | |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1437 | 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 Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 1445 | c2 = gfc_get_proc_ptr_comp (cons->expr); |
| 1446 | if (c2) |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1447 | { |
| 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 Weil | 6f3ab30 | 2012-06-22 23:05:51 +0200 | [diff] [blame] | 1463 | err, sizeof (err), NULL, NULL)) |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1464 | { |
Thomas Koenig | e0b9e5f | 2019-09-14 20:40:55 +0000 | [diff] [blame] | 1465 | gfc_error_opt (0, "Interface mismatch for procedure-pointer " |
Jakub Jelinek | 2700d0e | 2016-12-27 16:17:19 +0100 | [diff] [blame] | 1466 | "component %qs in structure constructor at %L:" |
| 1467 | " %s", comp->name, &cons->expr->where, err); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1468 | return false; |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1469 | } |
| 1470 | } |
| 1471 | |
Harald Anlauf | 1e819bd | 2021-10-15 21:23:17 +0200 | [diff] [blame] | 1472 | /* 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 Anlauf | 99af0b2 | 2021-10-26 20:51:46 +0200 | [diff] [blame] | 1481 | 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 Anlauf | bc66b47 | 2022-02-21 22:49:05 +0100 | [diff] [blame] | 1490 | if (cons->expr->shape == NULL) |
| 1491 | continue; |
Harald Anlauf | 1e819bd | 2021-10-15 21:23:17 +0200 | [diff] [blame] | 1492 | 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 Weil | e8cd398 | 2010-08-30 23:56:28 +0200 | [diff] [blame] | 1509 | if (!comp->attr.pointer || comp->attr.proc_pointer |
| 1510 | || cons->expr->expr_type == EXPR_NULL) |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1511 | continue; |
| 1512 | |
| 1513 | a = gfc_expr_attr (cons->expr); |
| 1514 | |
| 1515 | if (!a.pointer && !a.target) |
| 1516 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1517 | t = false; |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1518 | gfc_error ("The element in the structure constructor at %L, " |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1519 | "for pointer component %qs should be a POINTER or " |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 1520 | "a TARGET", &cons->expr->where, comp->name); |
| 1521 | } |
Tobias Burnus | 4eceddd | 2010-03-14 14:18:28 +0100 | [diff] [blame] | 1522 | |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1523 | if (init) |
| 1524 | { |
| 1525 | /* F08:C461. Additional checks for pointer initialization. */ |
| 1526 | if (a.allocatable) |
| 1527 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1528 | t = false; |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1529 | gfc_error ("Pointer initialization target at %L " |
Dominique d'Humieres | 2f029c0 | 2017-03-22 17:29:30 +0100 | [diff] [blame] | 1530 | "must not be ALLOCATABLE", &cons->expr->where); |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1531 | } |
| 1532 | if (!a.save) |
| 1533 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1534 | t = false; |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1535 | gfc_error ("Pointer initialization target at %L " |
| 1536 | "must have the SAVE attribute", &cons->expr->where); |
| 1537 | } |
| 1538 | } |
| 1539 | |
Tobias Burnus | 4eceddd | 2010-03-14 14:18:28 +0100 | [diff] [blame] | 1540 | /* F2003, C1272 (3). */ |
Tobias Burnus | ccd7751 | 2014-03-19 22:03:14 +0100 | [diff] [blame] | 1541 | 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 Burnus | 4eceddd | 2010-03-14 14:18:28 +0100 | [diff] [blame] | 1545 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1546 | t = false; |
Janus Weil | 6a38e15 | 2011-09-08 00:20:47 +0200 | [diff] [blame] | 1547 | gfc_error ("Invalid expression in the structure constructor for " |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1548 | "pointer component %qs at %L in PURE procedure", |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 1549 | comp->name, &cons->expr->where); |
Tobias Burnus | 4eceddd | 2010-03-14 14:18:28 +0100 | [diff] [blame] | 1550 | } |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 1551 | |
Tobias Burnus | ccd7751 | 2014-03-19 22:03:14 +0100 | [diff] [blame] | 1552 | if (impure) |
| 1553 | gfc_unset_implicit_pure (NULL); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1554 | } |
| 1555 | |
| 1556 | return t; |
| 1557 | } |
| 1558 | |
| 1559 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1560 | /****************** Expression name resolution ******************/ |
| 1561 | |
| 1562 | /* Returns 0 if a symbol was not declared with a type or |
Tobias Schlüter | 4f61394 | 2004-08-13 17:24:09 +0000 | [diff] [blame] | 1563 | attribute declaration statement, nonzero otherwise. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1564 | |
| 1565 | static int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1566 | was_declared (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1567 | { |
| 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üter | 9439ae4 | 2005-03-19 20:45:45 +0100 | [diff] [blame] | 1575 | if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1576 | || a.optional || a.pointer || a.save || a.target || a.volatile_ |
Tobias Burnus | 1eee562 | 2010-01-08 10:23:26 +0100 | [diff] [blame] | 1577 | || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 1578 | || a.asynchronous || a.codimension) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1579 | return 1; |
| 1580 | |
| 1581 | return 0; |
| 1582 | } |
| 1583 | |
| 1584 | |
| 1585 | /* Determine if a symbol is generic or not. */ |
| 1586 | |
| 1587 | static int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1588 | generic_sym (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1589 | { |
| 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 1600 | |
Jerry DeLisle | 6d023ec | 2007-07-28 21:17:20 +0000 | [diff] [blame] | 1601 | if (s != NULL) |
| 1602 | { |
| 1603 | if (s == sym) |
| 1604 | return 0; |
| 1605 | else |
| 1606 | return generic_sym (s); |
| 1607 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1608 | |
Jerry DeLisle | 6d023ec | 2007-07-28 21:17:20 +0000 | [diff] [blame] | 1609 | return 0; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1610 | } |
| 1611 | |
| 1612 | |
| 1613 | /* Determine if a symbol is specific or not. */ |
| 1614 | |
| 1615 | static int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1616 | specific_sym (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1617 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1624 | || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1625 | || 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 Saunders | a79683d | 2015-08-19 02:48:48 +0000 | [diff] [blame] | 1639 | enum proc_type |
| 1640 | { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1641 | |
| 1642 | static proc_type |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1643 | procedure_kind (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1644 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1645 | 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 Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1654 | /* Check references to assumed size arrays. The flag need_full_assumed_size |
Kazu Hirata | b82feea | 2006-04-08 14:31:12 +0000 | [diff] [blame] | 1655 | is nonzero when matching actual arguments. */ |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1656 | |
| 1657 | static int need_full_assumed_size = 0; |
| 1658 | |
| 1659 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1660 | check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1661 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1662 | if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1663 | return false; |
| 1664 | |
Ian Lance Taylor | e0c68ce | 2008-09-04 17:32:38 +0000 | [diff] [blame] | 1665 | /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. |
| 1666 | What should it be? */ |
Janus Weil | 582f217 | 2013-05-30 12:19:16 +0200 | [diff] [blame] | 1667 | if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) |
Paul Thomas | c52938e | 2008-03-16 19:14:17 +0000 | [diff] [blame] | 1668 | && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) |
Ian Lance Taylor | e0c68ce | 2008-09-04 17:32:38 +0000 | [diff] [blame] | 1669 | && (e->ref->u.ar.type == AR_FULL)) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1670 | { |
| 1671 | gfc_error ("The upper bound in the last dimension must " |
| 1672 | "appear in the reference to the assumed size " |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1673 | "array %qs at %L", sym->name, &e->where); |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1674 | 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 | |
| 1685 | static bool |
| 1686 | resolve_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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1694 | if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1695 | return true; |
| 1696 | break; |
| 1697 | |
| 1698 | case EXPR_OP: |
| 1699 | if (resolve_assumed_size_actual (e->value.op.op1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1700 | || resolve_assumed_size_actual (e->value.op.op2)) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 1701 | return true; |
| 1702 | break; |
| 1703 | |
| 1704 | default: |
| 1705 | break; |
| 1706 | } |
| 1707 | return false; |
| 1708 | } |
| 1709 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1710 | |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1711 | /* 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. */ |
| 1714 | static int |
| 1715 | count_specific_procs (gfc_expr *e) |
| 1716 | { |
| 1717 | int n; |
| 1718 | gfc_interface *p; |
| 1719 | gfc_symbol *sym; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 1720 | |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1721 | 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1733 | gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1734 | &e->where); |
| 1735 | |
| 1736 | if (n == 0) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1737 | gfc_error ("GENERIC procedure %qs is not allowed as an actual " |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1738 | "argument at %L", sym->name, &e->where); |
| 1739 | |
| 1740 | return n; |
| 1741 | } |
| 1742 | |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1743 | |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1744 | /* See if a call to sym could possibly be a not allowed RECURSION because of |
Tobias Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 1745 | a missing RECURSIVE declaration. This means that either sym is the current |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1746 | 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 | |
| 1750 | static bool |
| 1751 | is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) |
| 1752 | { |
| 1753 | gfc_symbol* proc_sym; |
| 1754 | gfc_symbol* context_proc; |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 1755 | gfc_namespace* real_context; |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1756 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 1757 | if (sym->attr.flavor == FL_PROGRAM |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 1758 | || gfc_fl_struct (sym->attr.flavor)) |
Jerry DeLisle | 6f7e06c | 2009-11-07 02:30:08 +0000 | [diff] [blame] | 1759 | return false; |
| 1760 | |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1761 | /* 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 Burnus | c61819f | 2014-12-16 21:44:45 +0100 | [diff] [blame] | 1768 | if (proc_sym->attr.recursive || flag_recursive) |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1769 | return false; |
| 1770 | |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 1771 | /* 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 Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1794 | |
| 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 Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1817 | /* Resolve an intrinsic procedure: Set its function/subroutine attribute, |
| 1818 | its typespec and formal argument list. */ |
| 1819 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1820 | bool |
Janus Weil | 2dda89a | 2012-07-30 21:55:41 +0200 | [diff] [blame] | 1821 | gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1822 | { |
Tobias Burnus | d000aa6 | 2010-09-27 00:30:48 +0200 | [diff] [blame] | 1823 | gfc_intrinsic_sym* isym = NULL; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1824 | const char* symstd; |
| 1825 | |
Mark Eggleston | dbeaa7a | 2020-04-23 10:33:14 +0100 | [diff] [blame] | 1826 | if (sym->resolve_symbol_called >= 2) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1827 | return true; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1828 | |
Mark Eggleston | dbeaa7a | 2020-04-23 10:33:14 +0100 | [diff] [blame] | 1829 | sym->resolve_symbol_called = 2; |
| 1830 | |
Tobias Burnus | 1315703 | 2011-05-12 19:40:29 +0200 | [diff] [blame] | 1831 | /* Already resolved. */ |
| 1832 | if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1833 | return true; |
Tobias Burnus | 1315703 | 2011-05-12 19:40:29 +0200 | [diff] [blame] | 1834 | |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1835 | /* 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 Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 1840 | 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 Burnus | 2b91eb3 | 2012-03-02 12:00:04 +0100 | [diff] [blame] | 1850 | else if (!sym->attr.subroutine) |
Tobias Burnus | d000aa6 | 2010-09-27 00:30:48 +0200 | [diff] [blame] | 1851 | isym = gfc_find_function (sym->name); |
| 1852 | |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 1853 | if (isym && !sym->attr.subroutine) |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1854 | { |
Tobias Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 1855 | if (sym->ts.type != BT_UNKNOWN && warn_surprising |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1856 | && !sym->attr.implicit_type) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 1857 | gfc_warning (OPT_Wsurprising, |
| 1858 | "Type specified for intrinsic function %qs at %L is" |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1859 | " ignored", sym->name, &sym->declared_at); |
| 1860 | |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1861 | if (!sym->attr.function && |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1862 | !gfc_add_function(&sym->attr, sym->name, loc)) |
| 1863 | return false; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1864 | |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1865 | sym->ts = isym->ts; |
| 1866 | } |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 1867 | else if (isym || (isym = gfc_find_subroutine (sym->name))) |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1868 | { |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1869 | if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) |
| 1870 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1871 | gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1872 | " specifier", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1873 | return false; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1874 | } |
| 1875 | |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1876 | if (!sym->attr.subroutine && |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1877 | !gfc_add_subroutine(&sym->attr, sym->name, loc)) |
| 1878 | return false; |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1879 | } |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1880 | else |
| 1881 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 1882 | gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1883 | &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1884 | return false; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1885 | } |
| 1886 | |
Tobias Burnus | 8fdcb6a | 2014-06-12 20:35:00 +0200 | [diff] [blame] | 1887 | gfc_copy_formal_args_intr (sym, isym, NULL); |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1888 | |
Tobias Burnus | 019c0e5 | 2013-12-08 22:34:18 +0100 | [diff] [blame] | 1889 | sym->attr.pure = isym->pure; |
| 1890 | sym->attr.elemental = isym->elemental; |
| 1891 | |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1892 | /* Check it is actually available in the standard settings. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1893 | if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1894 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 1895 | 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 Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1899 | sym->name, &sym->declared_at, symstd); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1900 | return false; |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 1901 | } |
| 1902 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1903 | return true; |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1904 | } |
| 1905 | |
| 1906 | |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1907 | /* Resolve a procedure expression, like passing it to a called procedure or as |
| 1908 | RHS for a procedure pointer assignment. */ |
| 1909 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1910 | static bool |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1911 | resolve_procedure_expression (gfc_expr* expr) |
| 1912 | { |
| 1913 | gfc_symbol* sym; |
| 1914 | |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1915 | if (expr->expr_type != EXPR_VARIABLE) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1916 | return true; |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1917 | gcc_assert (expr->symtree); |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1918 | |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1919 | sym = expr->symtree->n.sym; |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1920 | |
| 1921 | if (sym->attr.intrinsic) |
Janus Weil | 2dda89a | 2012-07-30 21:55:41 +0200 | [diff] [blame] | 1922 | gfc_resolve_intrinsic (sym, &expr->where); |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 1923 | |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1924 | if (sym->attr.flavor != FL_PROCEDURE |
| 1925 | || (sym->attr.function && sym->result == sym)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1926 | return true; |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1927 | |
| 1928 | /* A non-RECURSIVE procedure that is used as procedure expression within its |
| 1929 | own body is in danger of being called recursively. */ |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 1930 | if (is_illegal_recursion (sym, gfc_current_ns)) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 1931 | gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1932 | " itself recursively. Declare it RECURSIVE or use" |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 1933 | " %<-frecursive%>", sym->name, &expr->where); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 1934 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1935 | return true; |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 1936 | } |
| 1937 | |
| 1938 | |
Steven G. Kargl | b00802f | 2019-06-13 18:40:19 +0000 | [diff] [blame] | 1939 | /* Check that name is not a derived type. */ |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 1940 | |
Steven G. Kargl | b00802f | 2019-06-13 18:40:19 +0000 | [diff] [blame] | 1941 | static bool |
| 1942 | is_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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1958 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1964 | static bool |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1965 | resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, |
| 1966 | bool no_formal_args) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1967 | { |
| 1968 | gfc_symbol *sym; |
| 1969 | gfc_symtree *parent_st; |
| 1970 | gfc_expr *e; |
Janus Weil | d06790a | 2014-12-15 17:10:50 +0100 | [diff] [blame] | 1971 | gfc_component *comp; |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 1972 | int save_need_full_assumed_size; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 1973 | bool return_value = false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 1974 | bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 1975 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 1976 | actual_arg = true; |
| 1977 | first_actual_arg = true; |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 1978 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1979 | for (; arg; arg = arg->next) |
| 1980 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1981 | e = arg->expr; |
| 1982 | if (e == NULL) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1983 | { |
| 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 1991 | goto cleanup; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1992 | } |
| 1993 | } |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 1994 | first_actual_arg = false; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 1995 | continue; |
| 1996 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 1997 | |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 1998 | if (e->expr_type == EXPR_VARIABLE |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 1999 | && e->symtree->n.sym->attr.generic |
| 2000 | && no_formal_args |
| 2001 | && count_specific_procs (e) != 1) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2002 | goto cleanup; |
Paul Thomas | 27372c3 | 2007-10-12 16:51:53 +0000 | [diff] [blame] | 2003 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2004 | if (e->ts.type != BT_PROCEDURE) |
| 2005 | { |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2006 | save_need_full_assumed_size = need_full_assumed_size; |
Ian Lance Taylor | e0c68ce | 2008-09-04 17:32:38 +0000 | [diff] [blame] | 2007 | if (e->expr_type != EXPR_VARIABLE) |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2008 | need_full_assumed_size = 0; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2009 | if (!gfc_resolve_expr (e)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2010 | goto cleanup; |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2011 | need_full_assumed_size = save_need_full_assumed_size; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2012 | goto argument_list; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2013 | } |
| 2014 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2015 | /* See if the expression node should really be a variable reference. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2016 | |
| 2017 | sym = e->symtree->n.sym; |
| 2018 | |
Steven G. Kargl | b00802f | 2019-06-13 18:40:19 +0000 | [diff] [blame] | 2019 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2026 | if (sym->attr.flavor == FL_PROCEDURE |
| 2027 | || sym->attr.intrinsic |
| 2028 | || sym->attr.external) |
| 2029 | { |
François-Xavier Coudert | 0e7e7e6 | 2006-10-07 13:34:16 +0000 | [diff] [blame] | 2030 | int actual_ok; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2031 | |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 2032 | /* If a procedure is not already determined to be something else |
| 2033 | check if it is intrinsic. */ |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 2034 | if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 2035 | sym->attr.intrinsic = 1; |
| 2036 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 2037 | if (sym->attr.proc == PROC_ST_FUNCTION) |
| 2038 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2039 | gfc_error ("Statement function %qs at %L is not allowed as an " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 2040 | "actual argument", sym->name, &e->where); |
| 2041 | } |
| 2042 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2043 | actual_ok = gfc_intrinsic_actual_ok (sym->name, |
| 2044 | sym->attr.subroutine); |
François-Xavier Coudert | 0e7e7e6 | 2006-10-07 13:34:16 +0000 | [diff] [blame] | 2045 | if (sym->attr.intrinsic && actual_ok == 0) |
| 2046 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2047 | gfc_error ("Intrinsic %qs at %L is not allowed as an " |
François-Xavier Coudert | 0e7e7e6 | 2006-10-07 13:34:16 +0000 | [diff] [blame] | 2048 | "actual argument", sym->name, &e->where); |
| 2049 | } |
François-Xavier Coudert | 0e7e7e6 | 2006-10-07 13:34:16 +0000 | [diff] [blame] | 2050 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 2051 | if (sym->attr.contained && !sym->attr.use_assoc |
| 2052 | && sym->ns->proc_name->attr.flavor != FL_MODULE) |
| 2053 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 2054 | if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 2055 | " used as actual argument at %L", |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2056 | sym->name, &e->where)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2057 | goto cleanup; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 2058 | } |
| 2059 | |
| 2060 | if (sym->attr.elemental && !sym->attr.intrinsic) |
| 2061 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2062 | gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2063 | "allowed as an actual argument at %L", sym->name, |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 2064 | &e->where); |
| 2065 | } |
Francois-Xavier Coudert | 781e100 | 2005-04-28 13:56:08 +0200 | [diff] [blame] | 2066 | |
Paul Thomas | 36d3fb4 | 2007-03-15 06:44:25 +0000 | [diff] [blame] | 2067 | /* Check if a generic interface has a specific procedure |
| 2068 | with the same name before emitting an error. */ |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 2069 | if (sym->attr.generic && count_specific_procs (e) != 1) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2070 | goto cleanup; |
| 2071 | |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 2072 | /* Just in case a specific was found for the expression. */ |
| 2073 | sym = e->symtree->n.sym; |
Paul Thomas | 3e978d3 | 2006-08-20 05:45:43 +0000 | [diff] [blame] | 2074 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2075 | /* If the symbol is the function that names the current (or |
| 2076 | parent) scope, then we really have a variable reference. */ |
| 2077 | |
Janus Weil | 2d71b91 | 2009-11-26 20:01:02 +0100 | [diff] [blame] | 2078 | if (gfc_is_function_return_value (sym, sym->ns)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2079 | goto got_variable; |
| 2080 | |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2081 | /* If all else fails, see if we have a specific intrinsic. */ |
Jerry DeLisle | 2603347 | 2007-10-31 14:26:57 +0000 | [diff] [blame] | 2082 | if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2083 | { |
| 2084 | gfc_intrinsic_sym *isym; |
Jerry DeLisle | 6cc309c | 2007-11-14 00:59:09 +0000 | [diff] [blame] | 2085 | |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2086 | 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2090 | "for the reference %qs at %L", sym->name, |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2091 | &e->where); |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2092 | goto cleanup; |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2093 | } |
| 2094 | sym->ts = isym->ts; |
Jerry DeLisle | 6cc309c | 2007-11-14 00:59:09 +0000 | [diff] [blame] | 2095 | sym->attr.intrinsic = 1; |
Jerry DeLisle | 2603347 | 2007-10-31 14:26:57 +0000 | [diff] [blame] | 2096 | sym->attr.function = 1; |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 2097 | } |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 2098 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2099 | if (!gfc_resolve_expr (e)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2100 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2101 | goto argument_list; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2102 | } |
| 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2111 | gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2112 | goto cleanup; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2113 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2125 | if (!gfc_resolve_expr (e)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2126 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2127 | goto argument_list; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2128 | } |
| 2129 | |
| 2130 | got_variable: |
| 2131 | e->expr_type = EXPR_VARIABLE; |
| 2132 | e->ts = sym->ts; |
Tobias Burnus | 102344e | 2012-01-27 14:08:52 +0100 | [diff] [blame] | 2133 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2136 | { |
Tobias Burnus | 102344e | 2012-01-27 14:08:52 +0100 | [diff] [blame] | 2137 | e->rank = sym->ts.type == BT_CLASS |
| 2138 | ? CLASS_DATA (sym)->as->rank : sym->as->rank; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2139 | e->ref = gfc_get_ref (); |
| 2140 | e->ref->type = REF_ARRAY; |
| 2141 | e->ref->u.ar.type = AR_FULL; |
Tobias Burnus | 102344e | 2012-01-27 14:08:52 +0100 | [diff] [blame] | 2142 | e->ref->u.ar.as = sym->ts.type == BT_CLASS |
| 2143 | ? CLASS_DATA (sym)->as : sym->as; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2144 | } |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2145 | |
Daniel Franke | 1b35264 | 2007-05-21 18:24:55 -0400 | [diff] [blame] | 2146 | /* Expressions are assigned a default ts.type of BT_PROCEDURE in |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 2147 | primary.cc (match_actual_arg). If above code determines that it |
Daniel Franke | 1b35264 | 2007-05-21 18:24:55 -0400 | [diff] [blame] | 2148 | is a variable instead, it needs to be resolved as it was not |
| 2149 | done at the beginning of this function. */ |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2150 | save_need_full_assumed_size = need_full_assumed_size; |
Ian Lance Taylor | e0c68ce | 2008-09-04 17:32:38 +0000 | [diff] [blame] | 2151 | if (e->expr_type != EXPR_VARIABLE) |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2152 | need_full_assumed_size = 0; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2153 | if (!gfc_resolve_expr (e)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2154 | goto cleanup; |
Tobias Burnus | 5ad6345 | 2008-01-13 22:35:33 +0100 | [diff] [blame] | 2155 | need_full_assumed_size = save_need_full_assumed_size; |
Daniel Franke | 1b35264 | 2007-05-21 18:24:55 -0400 | [diff] [blame] | 2156 | |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2157 | 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 Weil | 2eb3745 | 2018-09-20 21:33:05 +0200 | [diff] [blame] | 2162 | if (strcmp ("%VAL", arg->name) == 0) |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2163 | { |
| 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2168 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2169 | } |
| 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2175 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2176 | } |
| 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 Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 2181 | intrinsic.cc. */ |
Tobias Burnus | 7193e30 | 2007-02-28 19:17:34 +0100 | [diff] [blame] | 2182 | if (ptype != PROC_UNKNOWN |
| 2183 | && ptype != PROC_DUMMY |
Tobias Burnus | 29ea08d | 2007-04-25 10:32:21 +0200 | [diff] [blame] | 2184 | && ptype != PROC_EXTERNAL |
| 2185 | && ptype != PROC_MODULE) |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2186 | { |
| 2187 | gfc_error ("By-value argument at %L is not allowed " |
| 2188 | "in this context", &e->where); |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2189 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2190 | } |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2191 | } |
| 2192 | |
| 2193 | /* Statement functions have already been excluded above. */ |
Janus Weil | 2eb3745 | 2018-09-20 21:33:05 +0200 | [diff] [blame] | 2194 | else if (strcmp ("%LOC", arg->name) == 0 |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2195 | && e->ts.type == BT_PROCEDURE) |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2196 | { |
| 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2201 | goto cleanup; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 2202 | } |
| 2203 | } |
| 2204 | } |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 2205 | |
Janus Weil | d06790a | 2014-12-15 17:10:50 +0100 | [diff] [blame] | 2206 | comp = gfc_get_proc_ptr_comp(e); |
Mikael Morin | bc0c7f3 | 2015-05-24 14:55:50 +0000 | [diff] [blame] | 2207 | if (e->expr_type == EXPR_VARIABLE |
| 2208 | && comp && comp->attr.elemental) |
Janus Weil | d06790a | 2014-12-15 17:10:50 +0100 | [diff] [blame] | 2209 | { |
| 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 2215 | /* Fortran 2008, C1237. */ |
| 2216 | if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2217 | && gfc_has_ultimate_pointer (e)) |
| 2218 | { |
| 2219 | gfc_error ("Coindexed actual argument at %L with ultimate pointer " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 2220 | "component", &e->where); |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2221 | goto cleanup; |
| 2222 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2223 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2224 | first_actual_arg = false; |
| 2225 | } |
| 2226 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2227 | return_value = true; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2228 | |
| 2229 | cleanup: |
| 2230 | actual_arg = actual_arg_sav; |
| 2231 | first_actual_arg = first_actual_arg_sav; |
| 2232 | |
| 2233 | return return_value; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2234 | } |
| 2235 | |
| 2236 | |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2237 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2240 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2241 | static bool |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2242 | resolve_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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2260 | && expr->value.function.esym->attr.elemental) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2261 | { |
| 2262 | arg0 = expr->value.function.actual; |
| 2263 | esym = expr->value.function.esym; |
| 2264 | } |
| 2265 | else if (expr->value.function.isym != NULL |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2266 | && expr->value.function.isym->elemental) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2267 | { |
| 2268 | arg0 = expr->value.function.actual; |
| 2269 | isym = expr->value.function.isym; |
| 2270 | } |
| 2271 | else |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2272 | return true; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2273 | } |
Daniel Kraft | dd9315d | 2008-10-16 18:28:23 +0200 | [diff] [blame] | 2274 | else if (c && c->ext.actual != NULL) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2275 | { |
| 2276 | arg0 = c->ext.actual; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 2277 | |
Daniel Kraft | dd9315d | 2008-10-16 18:28:23 +0200 | [diff] [blame] | 2278 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2285 | return true; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2286 | } |
| 2287 | else |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2288 | return true; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2289 | |
| 2290 | /* The rank of an elemental is the rank of its array argument(s). */ |
| 2291 | for (arg = arg0; arg; arg = arg->next) |
| 2292 | { |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 2293 | if (arg->expr != NULL && arg->expr->rank != 0) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2294 | { |
| 2295 | rank = arg->expr->rank; |
| 2296 | if (arg->expr->expr_type == EXPR_VARIABLE |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2297 | && arg->expr->symtree->n.sym->attr.optional) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2298 | 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. Kargl | 994c1cc | 2006-08-06 01:38:46 +0000 | [diff] [blame] | 2342 | if (pedantic && arg->expr != NULL |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2343 | && 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 Franke | cd5ecab | 2007-05-29 17:10:48 -0400 | [diff] [blame] | 2348 | && !(isym && isym->id == GFC_ISYM_CONVERSION)) |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2349 | { |
Mark Eggleston | 685d8da | 2020-06-01 14:56:00 +0100 | [diff] [blame] | 2350 | 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 Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2372 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2383 | return false; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2384 | |
Tobias Burnus | 3c7b91d | 2007-09-13 20:08:04 +0200 | [diff] [blame] | 2385 | /* Elemental procedure's array actual arguments must conform. */ |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2386 | if (e != NULL) |
| 2387 | { |
Mark Eggleston | 0a7183f | 2020-06-02 08:38:01 +0100 | [diff] [blame] | 2388 | if (!gfc_check_conformance (arg->expr, e, _("elemental procedure"))) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2389 | return false; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2390 | } |
| 2391 | else |
| 2392 | e = arg->expr; |
| 2393 | } |
| 2394 | |
Tobias Burnus | 4a96582 | 2007-09-18 08:34:30 +0200 | [diff] [blame] | 2395 | /* 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 Anlauf | 69db6e7 | 2022-03-29 22:12:15 +0200 | [diff] [blame] | 2400 | if (eformal->sym |
| 2401 | && (eformal->sym->attr.intent == INTENT_OUT |
| 2402 | || eformal->sym->attr.intent == INTENT_INOUT) |
Tobias Burnus | 4a96582 | 2007-09-18 08:34:30 +0200 | [diff] [blame] | 2403 | && arg->expr && arg->expr->rank == 0) |
| 2404 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2405 | gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " |
| 2406 | "ELEMENTAL subroutine %qs is a scalar, but another " |
Tobias Burnus | 4a96582 | 2007-09-18 08:34:30 +0200 | [diff] [blame] | 2407 | "actual argument is an array", &arg->expr->where, |
| 2408 | (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" |
| 2409 | : "INOUT", eformal->sym->name, esym->name); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2410 | return false; |
Tobias Burnus | 4a96582 | 2007-09-18 08:34:30 +0200 | [diff] [blame] | 2411 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2412 | return true; |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 2413 | } |
| 2414 | |
| 2415 | |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2416 | /* 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 Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 2421 | Otherwise, the new symbol is equipped with the attributes of the |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2422 | reference. The corresponding code that is called in creating |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 2423 | global entities is parse.cc. |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 2424 | |
| 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 Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2429 | |
Paul Thomas | 3af8d8c | 2009-08-01 13:45:12 +0000 | [diff] [blame] | 2430 | |
| 2431 | static bool |
| 2432 | not_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 | |
| 2446 | static bool |
| 2447 | not_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 Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2471 | |
| 2472 | /* Check for the requirement of an explicit interface. F08:12.4.2.2. */ |
| 2473 | |
| 2474 | bool |
| 2475 | gfc_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 Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 2544 | 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 Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2549 | 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 Burnus | 019c0e5 | 2013-12-08 22:34:18 +0100 | [diff] [blame] | 2581 | if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2582 | { |
| 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 Thomas | ff60488 | 2007-01-02 14:23:36 +0000 | [diff] [blame] | 2596 | static void |
Thomas Koenig | fb07836 | 2019-08-15 22:52:40 +0000 | [diff] [blame] | 2597 | resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2598 | { |
| 2599 | gfc_gsymbol * gsym; |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 2600 | gfc_namespace *ns; |
Ian Lance Taylor | 32e8bb8 | 2009-04-24 15:31:38 +0000 | [diff] [blame] | 2601 | enum gfc_symbol_type type; |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2602 | char reason[200]; |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2603 | |
| 2604 | type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; |
| 2605 | |
Thomas Koenig | 55b9c61 | 2019-03-13 07:21:33 +0000 | [diff] [blame] | 2606 | gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, |
| 2607 | sym->binding_label != NULL); |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2608 | |
| 2609 | if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) |
Francois-Xavier Coudert | ca39e6f | 2007-10-05 12:33:07 +0000 | [diff] [blame] | 2610 | gfc_global_used (gsym, where); |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2611 | |
Tobias Burnus | 9fa5223 | 2013-03-18 10:50:23 +0100 | [diff] [blame] | 2612 | if ((sym->attr.if_source == IFSRC_UNKNOWN |
| 2613 | || sym->attr.if_source == IFSRC_IFBODY) |
| 2614 | && gsym->type != GSYM_UNKNOWN |
Janus Weil | 04ba12e | 2014-01-06 12:31:34 +0100 | [diff] [blame] | 2615 | && !gsym->binding_label |
Tobias Burnus | 9fa5223 | 2013-03-18 10:50:23 +0100 | [diff] [blame] | 2616 | && gsym->ns |
Tobias Burnus | 9fa5223 | 2013-03-18 10:50:23 +0100 | [diff] [blame] | 2617 | && gsym->ns->proc_name |
| 2618 | && not_in_recursive (sym, gsym->ns) |
| 2619 | && not_entry_self_reference (sym, gsym->ns)) |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 2620 | { |
Tobias Burnus | 48a32c4 | 2010-07-23 22:07:30 +0200 | [diff] [blame] | 2621 | gfc_symbol *def_sym; |
Tobias Burnus | 48a32c4 | 2010-07-23 22:07:30 +0200 | [diff] [blame] | 2622 | def_sym = gsym->ns->proc_name; |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 2623 | |
Thomas Koenig | 866664a | 2019-03-24 12:51:19 +0000 | [diff] [blame] | 2624 | if (gsym->ns->resolved != -1) |
Tobias Burnus | 48a32c4 | 2010-07-23 22:07:30 +0200 | [diff] [blame] | 2625 | { |
Thomas Koenig | 866664a | 2019-03-24 12:51:19 +0000 | [diff] [blame] | 2626 | |
| 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 Koenig | 2955784 | 2019-04-06 14:16:01 +0000 | [diff] [blame] | 2665 | if (def_sym->attr.entry_master || def_sym->attr.entry) |
Thomas Koenig | 866664a | 2019-03-24 12:51:19 +0000 | [diff] [blame] | 2666 | { |
| 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 Burnus | 48a32c4 | 2010-07-23 22:07:30 +0200 | [diff] [blame] | 2675 | } |
| 2676 | |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2677 | if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) |
Daniel Franke | 30145da | 2010-05-25 14:10:01 -0400 | [diff] [blame] | 2678 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2679 | gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2680 | sym->name, &sym->declared_at, gfc_typename (&sym->ts), |
| 2681 | gfc_typename (&def_sym->ts)); |
| 2682 | goto done; |
Daniel Franke | 30145da | 2010-05-25 14:10:01 -0400 | [diff] [blame] | 2683 | } |
| 2684 | |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2685 | if (sym->attr.if_source == IFSRC_UNKNOWN |
| 2686 | && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) |
Daniel Franke | 30145da | 2010-05-25 14:10:01 -0400 | [diff] [blame] | 2687 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2688 | gfc_error ("Explicit interface required for %qs at %L: %s", |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2689 | sym->name, &sym->declared_at, reason); |
| 2690 | goto done; |
Daniel Franke | 1b1a662 | 2010-06-12 09:43:48 -0400 | [diff] [blame] | 2691 | } |
| 2692 | |
Thomas König | 2298af0 | 2020-04-17 19:53:45 +0200 | [diff] [blame] | 2693 | bool bad_result_characteristics; |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2694 | if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, |
Thomas König | 2298af0 | 2020-04-17 19:53:45 +0200 | [diff] [blame] | 2695 | reason, sizeof(reason), NULL, NULL, |
| 2696 | &bad_result_characteristics)) |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 2697 | { |
Thomas König | 2298af0 | 2020-04-17 19:53:45 +0200 | [diff] [blame] | 2698 | /* 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 Koenig | cc9a922 | 2020-07-05 20:11:35 +0200 | [diff] [blame] | 2708 | sym->error = 1; |
Thomas König | 2298af0 | 2020-04-17 19:53:45 +0200 | [diff] [blame] | 2709 | gfc_errors_to_warnings (false); |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2710 | goto done; |
Daniel Franke | 30145da | 2010-05-25 14:10:01 -0400 | [diff] [blame] | 2711 | } |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 2712 | } |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 2713 | |
Janus Weil | 9648699 | 2013-04-12 16:21:39 +0200 | [diff] [blame] | 2714 | done: |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 2715 | |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 2716 | if (gsym->type == GSYM_UNKNOWN) |
| 2717 | { |
| 2718 | gsym->type = type; |
| 2719 | gsym->where = *where; |
| 2720 | } |
| 2721 | |
| 2722 | gsym->used = 1; |
| 2723 | } |
Richard Sandiford | 1524f80 | 2005-12-13 05:23:12 +0000 | [diff] [blame] | 2724 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2725 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2726 | /************* Function resolution *************/ |
| 2727 | |
| 2728 | /* Resolve a function call known to be generic. |
| 2729 | Section 14.1.2.4.1. */ |
| 2730 | |
| 2731 | static match |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2732 | resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2733 | { |
| 2734 | gfc_symbol *s; |
| 2735 | |
| 2736 | if (sym->attr.generic) |
| 2737 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2738 | s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2739 | if (s != NULL) |
| 2740 | { |
| 2741 | expr->value.function.name = s->name; |
| 2742 | expr->value.function.esym = s; |
Paul Thomas | f5f701a | 2006-04-16 03:45:24 +0000 | [diff] [blame] | 2743 | |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2749 | if (s->as != NULL) |
| 2750 | expr->rank = s->as->rank; |
Paul Thomas | f5f701a | 2006-04-16 03:45:24 +0000 | [diff] [blame] | 2751 | else if (s->result != NULL && s->result->as != NULL) |
| 2752 | expr->rank = s->result->as->rank; |
| 2753 | |
Paul Thomas | 0a164a3 | 2007-12-16 11:34:08 +0000 | [diff] [blame] | 2754 | gfc_set_sym_referenced (expr->value.function.esym); |
| 2755 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2756 | return MATCH_YES; |
| 2757 | } |
| 2758 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2759 | /* TODO: Need to search for elemental references in generic |
| 2760 | interface. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2761 | } |
| 2762 | |
| 2763 | if (sym->attr.intrinsic) |
| 2764 | return gfc_intrinsic_func_interface (expr, 0); |
| 2765 | |
| 2766 | return MATCH_NO; |
| 2767 | } |
| 2768 | |
| 2769 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2770 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2771 | resolve_generic_f (gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2772 | { |
| 2773 | gfc_symbol *sym; |
| 2774 | match m; |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2775 | gfc_interface *intr = NULL; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2776 | |
| 2777 | sym = expr->symtree->n.sym; |
| 2778 | |
| 2779 | for (;;) |
| 2780 | { |
| 2781 | m = resolve_generic_f0 (expr, sym); |
| 2782 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2783 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2784 | else if (m == MATCH_ERROR) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2785 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2786 | |
| 2787 | generic: |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2788 | if (!intr) |
| 2789 | for (intr = sym->generic; intr; intr = intr->next) |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 2790 | if (gfc_fl_struct (intr->sym->attr.flavor)) |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2791 | break; |
| 2792 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2793 | 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 Thomas | 71f77fd | 2006-12-20 13:48:06 +0000 | [diff] [blame] | 2803 | /* Last ditch attempt. See if the reference is to an intrinsic |
| 2804 | that possesses a matching interface. 14.1.2.4 */ |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2805 | if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2806 | { |
Jerry DeLisle | 1d10121 | 2016-01-24 22:18:20 +0000 | [diff] [blame] | 2807 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2814 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2815 | } |
| 2816 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2817 | if (intr) |
| 2818 | { |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 2819 | if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2820 | NULL, false)) |
| 2821 | return false; |
Paul Thomas | de624be | 2017-10-21 09:02:17 +0000 | [diff] [blame] | 2822 | if (!gfc_use_derived (expr->ts.u.derived)) |
| 2823 | return false; |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2824 | return resolve_structure_cons (expr, 0); |
| 2825 | } |
| 2826 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2827 | m = gfc_intrinsic_func_interface (expr, 0); |
| 2828 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2829 | return true; |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 2830 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2831 | if (m == MATCH_NO) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2832 | gfc_error ("Generic function %qs at %L is not consistent with a " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2833 | "specific intrinsic interface", expr->symtree->n.sym->name, |
| 2834 | &expr->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2835 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2836 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2837 | } |
| 2838 | |
| 2839 | |
| 2840 | /* Resolve a function call known to be specific. */ |
| 2841 | |
| 2842 | static match |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2843 | resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2844 | { |
| 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2870 | gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2871 | "with an intrinsic", sym->name, &expr->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2872 | |
| 2873 | return MATCH_ERROR; |
| 2874 | } |
| 2875 | |
| 2876 | return MATCH_NO; |
| 2877 | |
| 2878 | found: |
| 2879 | gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); |
| 2880 | |
Janus Weil | a7c0b11 | 2009-07-04 14:28:43 +0200 | [diff] [blame] | 2881 | if (sym->result) |
| 2882 | expr->ts = sym->result->ts; |
| 2883 | else |
| 2884 | expr->ts = sym->ts; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2885 | expr->value.function.name = sym->name; |
| 2886 | expr->value.function.esym = sym; |
Andre Vehreschild | 6c25f79 | 2015-03-16 11:29:59 +0100 | [diff] [blame] | 2887 | /* 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 Weil | 36ad06d | 2013-12-07 20:27:19 +0100 | [diff] [blame] | 2891 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2894 | expr->rank = sym->as->rank; |
| 2895 | |
| 2896 | return MATCH_YES; |
| 2897 | } |
| 2898 | |
| 2899 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2900 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2901 | resolve_specific_f (gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2902 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2912 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2913 | if (m == MATCH_ERROR) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2914 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2915 | |
| 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 2925 | gfc_error ("Unable to resolve the specific function %qs at %L", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2926 | expr->symtree->n.sym->name, &expr->where); |
| 2927 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2928 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2929 | } |
| 2930 | |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 2931 | /* Recursively append candidate SYM to CANDIDATES. Store the number of |
| 2932 | candidates in CANDIDATES_LEN. */ |
| 2933 | |
| 2934 | static void |
| 2935 | lookup_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 | |
| 2959 | const char* |
| 2960 | gfc_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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2968 | |
| 2969 | /* Resolve a procedure call not known to be generic nor specific. */ |
| 2970 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2971 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 2972 | resolve_unknown_f (gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2973 | { |
| 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 Kraft | c3005b0 | 2008-07-24 20:52:51 +0200 | [diff] [blame] | 2988 | if (gfc_is_intrinsic (sym, 0, expr->where)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2989 | { |
| 2990 | if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 2991 | return true; |
| 2992 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 2993 | } |
| 2994 | |
Bernhard Reutner-Fischer | 1727bb5 | 2021-10-31 17:44:45 +0100 | [diff] [blame] | 2995 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3008 | /* 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 | |
| 3020 | set_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 Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 3027 | ts = gfc_get_default_type (sym->name, sym->ns); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3028 | |
| 3029 | if (ts->type == BT_UNKNOWN) |
| 3030 | { |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 3031 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3040 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3041 | } |
| 3042 | else |
| 3043 | expr->ts = *ts; |
| 3044 | } |
| 3045 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3046 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3047 | } |
| 3048 | |
| 3049 | |
Paul Thomas | e7c8ff5 | 2007-07-10 05:11:00 +0000 | [diff] [blame] | 3050 | /* Return true, if the symbol is an external procedure. */ |
| 3051 | static bool |
| 3052 | is_external_proc (gfc_symbol *sym) |
| 3053 | { |
| 3054 | if (!sym->attr.dummy && !sym->attr.contained |
Janus Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 3055 | && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) |
Paul Thomas | e7c8ff5 | 2007-07-10 05:11:00 +0000 | [diff] [blame] | 3056 | && sym->attr.proc != PROC_ST_FUNCTION |
Janus Weil | 68d8db7 | 2010-06-29 23:40:38 +0200 | [diff] [blame] | 3057 | && !sym->attr.proc_pointer |
Paul Thomas | e7c8ff5 | 2007-07-10 05:11:00 +0000 | [diff] [blame] | 3058 | && !sym->attr.use_assoc |
| 3059 | && sym->name) |
| 3060 | return true; |
Daniel Kraft | c3005b0 | 2008-07-24 20:52:51 +0200 | [diff] [blame] | 3061 | |
| 3062 | return false; |
Paul Thomas | e7c8ff5 | 2007-07-10 05:11:00 +0000 | [diff] [blame] | 3063 | } |
| 3064 | |
| 3065 | |
Volker Reichelt | 2054fc2 | 2005-02-24 21:59:24 +0000 | [diff] [blame] | 3066 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3068 | function is PURE, zero if not. */ |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 3069 | static int |
| 3070 | pure_stmt_function (gfc_expr *, gfc_symbol *); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3071 | |
Janus Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3072 | int |
| 3073 | gfc_pure_function (gfc_expr *e, const char **name) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3074 | { |
| 3075 | int pure; |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3076 | gfc_component *comp; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3077 | |
Paul Thomas | 36f7dca | 2007-02-03 13:38:42 +0000 | [diff] [blame] | 3078 | *name = NULL; |
| 3079 | |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3080 | if (e->symtree != NULL |
| 3081 | && e->symtree->n.sym != NULL |
| 3082 | && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 3083 | return pure_stmt_function (e, e->symtree->n.sym); |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3084 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3085 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3092 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3099 | || e->value.function.isym->elemental; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3100 | *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 Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3113 | /* Check if the expression is a reference to an implicitly pure function. */ |
| 3114 | |
| 3115 | int |
| 3116 | gfc_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 Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 3128 | static bool |
| 3129 | impure_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 Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3142 | return gfc_pure_function (e, &name) ? false : true; |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 3143 | } |
| 3144 | |
| 3145 | |
| 3146 | static int |
| 3147 | pure_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 Weil | 41cc1dd | 2014-12-15 11:34:46 +0100 | [diff] [blame] | 3153 | /* Check if an impure function is allowed in the current context. */ |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3154 | |
| 3155 | static bool check_pure_function (gfc_expr *e) |
| 3156 | { |
| 3157 | const char *name = NULL; |
Janus Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3158 | if (!gfc_pure_function (e, &name) && name) |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3159 | { |
| 3160 | if (forall_flag) |
| 3161 | { |
Janus Weil | 41cc1dd | 2014-12-15 11:34:46 +0100 | [diff] [blame] | 3162 | gfc_error ("Reference to impure function %qs at %L inside a " |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3163 | "FORALL %s", name, &e->where, |
| 3164 | forall_flag == 2 ? "mask" : "block"); |
| 3165 | return false; |
| 3166 | } |
| 3167 | else if (gfc_do_concurrent_flag) |
| 3168 | { |
Janus Weil | 41cc1dd | 2014-12-15 11:34:46 +0100 | [diff] [blame] | 3169 | gfc_error ("Reference to impure function %qs at %L inside a " |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3170 | "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 Weil | 41cc1dd | 2014-12-15 11:34:46 +0100 | [diff] [blame] | 3176 | gfc_error ("Reference to impure function %qs at %L " |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3177 | "within a PURE procedure", name, &e->where); |
| 3178 | return false; |
| 3179 | } |
Janus Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3180 | if (!gfc_implicit_pure_function (e)) |
| 3181 | gfc_unset_implicit_pure (NULL); |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3182 | } |
| 3183 | return true; |
| 3184 | } |
| 3185 | |
| 3186 | |
Paul Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 3187 | /* Update current procedure's array_outer_dependency flag, considering |
| 3188 | a call to procedure SYM. */ |
| 3189 | |
| 3190 | static void |
| 3191 | update_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. Kargl | 55157d5 | 2018-05-25 00:39:23 +0000 | [diff] [blame] | 3207 | if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer) |
| 3208 | && gfc_current_ns->proc_name) |
Paul Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 3209 | gfc_current_ns->proc_name->attr.array_outer_dependency = 1; |
| 3210 | } |
| 3211 | |
| 3212 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3213 | /* Resolve a function call, which means resolving the arguments, then figuring |
| 3214 | out which entity the name refers to. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3215 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3216 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3217 | resolve_function (gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3218 | { |
| 3219 | gfc_actual_arglist *arg; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3220 | gfc_symbol *sym; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3221 | bool t; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3222 | int temp; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 3223 | procedure_type p = PROC_INTRINSIC; |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 3224 | bool no_formal_args; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3225 | |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3226 | sym = NULL; |
| 3227 | if (expr->symtree) |
| 3228 | sym = expr->symtree->n.sym; |
| 3229 | |
Janus Weil | 6c03662 | 2009-11-24 09:16:32 +0100 | [diff] [blame] | 3230 | /* If this is a procedure pointer component, it has already been resolved. */ |
Mikael Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 3231 | if (gfc_is_proc_ptr_comp (expr)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3232 | return true; |
Mikael Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 3233 | |
Tobias Burnus | 63617e3 | 2016-06-21 20:36:25 +0200 | [diff] [blame] | 3234 | /* 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önig | 52354da | 2020-01-16 22:09:37 +0100 | [diff] [blame] | 3241 | 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. Kargl | 2c68bc8 | 2008-09-06 17:11:29 +0200 | [diff] [blame] | 3248 | if (sym && sym->attr.intrinsic |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3249 | && !gfc_resolve_intrinsic (sym, &expr->where)) |
| 3250 | return false; |
Steven G. Kargl | 2c68bc8 | 2008-09-06 17:11:29 +0200 | [diff] [blame] | 3251 | |
Janus Weil | 726d856 | 2008-12-02 12:58:16 +0100 | [diff] [blame] | 3252 | if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 3253 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3254 | gfc_error ("%qs at %L is not a function", sym->name, &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3255 | return false; |
Paul Thomas | 20a037d | 2006-12-31 07:51:47 +0000 | [diff] [blame] | 3256 | } |
| 3257 | |
Paul Thomas | 77f72c9 | 2018-06-21 22:38:55 +0000 | [diff] [blame] | 3258 | /* If this is a deferred TBP with an abstract interface (which may |
Janus Weil | b3d286b | 2010-03-08 10:35:04 +0100 | [diff] [blame] | 3259 | of course be referenced), expr->value.function.esym will be set. */ |
| 3260 | if (sym && sym->attr.abstract && !expr->value.function.esym) |
Tobias Burnus | 9e1d712 | 2007-08-18 16:57:21 +0200 | [diff] [blame] | 3261 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3262 | gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", |
Tobias Burnus | 9e1d712 | 2007-08-18 16:57:21 +0200 | [diff] [blame] | 3263 | sym->name, &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3264 | return false; |
Tobias Burnus | 9e1d712 | 2007-08-18 16:57:21 +0200 | [diff] [blame] | 3265 | } |
| 3266 | |
Paul Thomas | 77f72c9 | 2018-06-21 22:38:55 +0000 | [diff] [blame] | 3267 | /* 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 Thomas | 474f253 | 2018-06-22 22:31:17 +0000 | [diff] [blame] | 3270 | && sym->result->ts.u.cl |
Paul Thomas | 99d2293 | 2018-07-05 16:27:38 +0000 | [diff] [blame] | 3271 | && sym->result->ts.u.cl->length == NULL |
| 3272 | && !sym->result->ts.deferred) |
Paul Thomas | 77f72c9 | 2018-06-21 22:38:55 +0000 | [diff] [blame] | 3273 | { |
| 3274 | gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed " |
Paul Thomas | 99d2293 | 2018-07-05 16:27:38 +0000 | [diff] [blame] | 3275 | "character length result (F2008: C418)", sym->name, |
Paul Thomas | 77f72c9 | 2018-06-21 22:38:55 +0000 | [diff] [blame] | 3276 | &sym->declared_at); |
| 3277 | return false; |
| 3278 | } |
| 3279 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3280 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3283 | |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 3284 | if (expr->symtree && expr->symtree->n.sym) |
| 3285 | p = expr->symtree->n.sym->attr.proc; |
| 3286 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 3287 | if (expr->value.function.isym && expr->value.function.isym->inquiry) |
| 3288 | inquiry_argument = true; |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 3289 | no_formal_args = sym && is_external_proc (sym) |
| 3290 | && gfc_sym_get_dummy_args (sym) == NULL; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 3291 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 3292 | if (!resolve_actual_arglist (expr->value.function.actual, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3293 | p, no_formal_args)) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 3294 | { |
| 3295 | inquiry_argument = false; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3296 | return false; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 3297 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3298 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 3299 | inquiry_argument = false; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 3300 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 3301 | /* Resume assumed_size checking. */ |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3302 | need_full_assumed_size--; |
| 3303 | |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 3304 | /* If the procedure is external, check for usage. */ |
| 3305 | if (sym && is_external_proc (sym)) |
Thomas Koenig | fb07836 | 2019-08-15 22:52:40 +0000 | [diff] [blame] | 3306 | resolve_global_procedure (sym, &expr->where, 0); |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 3307 | |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3308 | if (sym && sym->ts.type == BT_CHARACTER |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 3309 | && sym->ts.u.cl |
| 3310 | && sym->ts.u.cl->length == NULL |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3311 | && !sym->attr.dummy |
Paul Thomas | 8d51f26 | 2011-01-28 13:53:19 +0000 | [diff] [blame] | 3312 | && !sym->ts.deferred |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3313 | && expr->value.function.esym == NULL |
| 3314 | && !sym->attr.contained) |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3315 | { |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3316 | /* Internal procedures are taken care of in resolve_contained_fntype. */ |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3317 | gfc_error ("Function %qs is declared CHARACTER(*) and cannot " |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 3318 | "be used at %L since it is not a dummy argument", |
| 3319 | sym->name, &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3320 | return false; |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3321 | } |
| 3322 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3323 | /* See if function is already resolved. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3324 | |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 3325 | if (expr->value.function.name != NULL |
| 3326 | || expr->value.function.isym != NULL) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3327 | { |
| 3328 | if (expr->ts.type == BT_UNKNOWN) |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3329 | expr->ts = sym->ts; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3330 | t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3331 | } |
| 3332 | else |
| 3333 | { |
| 3334 | /* Apply the rules of section 14.1.2. */ |
| 3335 | |
Paul Thomas | 20236f9 | 2006-01-26 20:19:09 +0000 | [diff] [blame] | 3336 | switch (procedure_kind (sym)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3337 | { |
| 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. Kargl | 8b4e5e7 | 2019-10-02 17:01:30 +0000 | [diff] [blame] | 3361 | /* Walk the argument list looking for invalid BOZ. */ |
Steven G. Kargl | 405e87e | 2019-10-11 17:52:27 +0000 | [diff] [blame] | 3362 | 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. Kargl | 8b4e5e7 | 2019-10-02 17:01:30 +0000 | [diff] [blame] | 3370 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3371 | temp = need_full_assumed_size; |
| 3372 | need_full_assumed_size = 0; |
| 3373 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3374 | if (!resolve_elemental_actual (expr, NULL)) |
| 3375 | return false; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3376 | |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 3377 | if (omp_workshare_flag |
| 3378 | && expr->value.function.esym |
| 3379 | && ! gfc_elemental (expr->value.function.esym)) |
| 3380 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3381 | gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3382 | "in WORKSHARE construct", expr->value.function.esym->name, |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 3383 | &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3384 | t = false; |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 3385 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3386 | |
Daniel Franke | cd5ecab | 2007-05-29 17:10:48 -0400 | [diff] [blame] | 3387 | #define GENERIC_ID expr->value.function.isym->id |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3388 | else if (expr->value.function.actual != NULL |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3389 | && expr->value.function.isym != NULL |
| 3390 | && GENERIC_ID != GFC_ISYM_LBOUND |
Tobias Burnus | 2c06087 | 2014-04-30 21:08:19 +0200 | [diff] [blame] | 3391 | && GENERIC_ID != GFC_ISYM_LCOBOUND |
| 3392 | && GENERIC_ID != GFC_ISYM_UCOBOUND |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3393 | && GENERIC_ID != GFC_ISYM_LEN |
| 3394 | && GENERIC_ID != GFC_ISYM_LOC |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 3395 | && GENERIC_ID != GFC_ISYM_C_LOC |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3396 | && GENERIC_ID != GFC_ISYM_PRESENT) |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3397 | { |
Tobias Burnus | fa95169 | 2006-10-16 13:17:29 +0200 | [diff] [blame] | 3398 | /* Array intrinsics must also have the last upper bound of an |
Kazu Hirata | b82feea | 2006-04-08 14:31:12 +0000 | [diff] [blame] | 3399 | assumed size array argument. UBOUND and SIZE have to be |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3400 | excluded from the check if the second argument is anything |
| 3401 | than a constant. */ |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 3402 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3403 | for (arg = expr->value.function.actual; arg; arg = arg->next) |
| 3404 | { |
Tobias Burnus | 7a687b2 | 2008-09-06 17:27:50 +0200 | [diff] [blame] | 3405 | if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) |
Tobias Burnus | 1634e53 | 2013-05-02 18:29:14 +0200 | [diff] [blame] | 3406 | && arg == expr->value.function.actual |
Tobias Burnus | 7a687b2 | 2008-09-06 17:27:50 +0200 | [diff] [blame] | 3407 | && arg->next != NULL && arg->next->expr) |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3408 | { |
| 3409 | if (arg->next->expr->expr_type != EXPR_CONSTANT) |
| 3410 | break; |
| 3411 | |
Janus Weil | 2eb3745 | 2018-09-20 21:33:05 +0200 | [diff] [blame] | 3412 | if (arg->next->name && strcmp (arg->next->name, "kind") == 0) |
Tobias Burnus | 7a687b2 | 2008-09-06 17:27:50 +0200 | [diff] [blame] | 3413 | break; |
| 3414 | |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3415 | if ((int)mpz_get_si (arg->next->expr->value.integer) |
| 3416 | < arg->expr->rank) |
| 3417 | break; |
| 3418 | } |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 3419 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3420 | if (arg->expr != NULL |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3421 | && arg->expr->rank > 0 |
| 3422 | && resolve_assumed_size_actual (arg->expr)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3423 | return false; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3424 | } |
| 3425 | } |
Paul Thomas | 4d4074e | 2006-12-09 20:41:51 +0000 | [diff] [blame] | 3426 | #undef GENERIC_ID |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3427 | |
| 3428 | need_full_assumed_size = temp; |
| 3429 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3430 | if (!check_pure_function(expr)) |
| 3431 | t = false; |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 3432 | |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3433 | /* 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 Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3437 | gfc_symbol *esym; |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3438 | esym = expr->value.function.esym; |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3439 | |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3440 | if (is_illegal_recursion (esym, gfc_current_ns)) |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3441 | { |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3442 | if (esym->attr.entry && esym->ns->entries) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3443 | gfc_error ("ENTRY %qs at %L cannot be called recursively, as" |
| 3444 | " function %qs is not RECURSIVE", |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3445 | esym->name, &expr->where, esym->ns->entries->sym->name); |
| 3446 | else |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3447 | gfc_error ("Function %qs at %L cannot be called recursively, as it" |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3448 | " is not RECURSIVE", esym->name, &expr->where); |
| 3449 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3450 | t = false; |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3451 | } |
| 3452 | } |
| 3453 | |
Erik Edelmann | 47992a4 | 2006-01-05 00:22:39 +0000 | [diff] [blame] | 3454 | /* 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 Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 3458 | if (expr->ts.type == BT_CHARACTER && expr->value.function.esym |
Erik Edelmann | 47992a4 | 2006-01-05 00:22:39 +0000 | [diff] [blame] | 3459 | && expr->value.function.esym->attr.use_assoc) |
| 3460 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 3461 | gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); |
Erik Edelmann | 47992a4 | 2006-01-05 00:22:39 +0000 | [diff] [blame] | 3462 | } |
| 3463 | |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3464 | /* 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 Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 3468 | && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN |
| 3469 | && !expr->symtree->n.sym->result->attr.proc_pointer) |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3470 | expr->ts = expr->symtree->n.sym->result->ts; |
Paul Thomas | 9ebe2d2 | 2007-01-15 08:16:17 +0000 | [diff] [blame] | 3471 | } |
| 3472 | |
Paul Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 3473 | 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 Burnus | 0caf400 | 2020-11-03 09:55:58 +0100 | [diff] [blame] | 3484 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3489 | return t; |
| 3490 | } |
| 3491 | |
| 3492 | |
| 3493 | /************* Subroutine resolution *************/ |
| 3494 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3495 | static bool |
| 3496 | pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3497 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3498 | if (gfc_pure (sym)) |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3499 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3500 | |
| 3501 | if (forall_flag) |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3502 | { |
| 3503 | gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", |
| 3504 | name, loc); |
| 3505 | return false; |
| 3506 | } |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 3507 | else if (gfc_do_concurrent_flag) |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3508 | { |
| 3509 | gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " |
| 3510 | "PURE", name, loc); |
| 3511 | return false; |
| 3512 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3513 | else if (gfc_pure (NULL)) |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3514 | { |
| 3515 | gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); |
| 3516 | return false; |
| 3517 | } |
Tobias Burnus | 3d2cea8 | 2011-11-24 18:57:41 +0100 | [diff] [blame] | 3518 | |
Tobias Burnus | ccd7751 | 2014-03-19 22:03:14 +0100 | [diff] [blame] | 3519 | gfc_unset_implicit_pure (NULL); |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3520 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3521 | } |
| 3522 | |
| 3523 | |
| 3524 | static match |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3525 | resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3526 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3534 | c->resolved_sym = s; |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3535 | if (!pure_subroutine (s, s->name, &c->loc)) |
| 3536 | return MATCH_ERROR; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3537 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3550 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3551 | resolve_generic_s (gfc_code *c) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3552 | { |
| 3553 | gfc_symbol *sym; |
| 3554 | match m; |
| 3555 | |
| 3556 | sym = c->symtree->n.sym; |
| 3557 | |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3558 | for (;;) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3559 | { |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3560 | m = resolve_generic_s0 (c, sym); |
| 3561 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3562 | return true; |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3563 | else if (m == MATCH_ERROR) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3564 | return false; |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3565 | |
| 3566 | generic: |
| 3567 | if (sym->ns->parent == NULL) |
| 3568 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3569 | gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3570 | |
| 3571 | if (sym == NULL) |
| 3572 | break; |
| 3573 | if (!generic_sym (sym)) |
| 3574 | goto generic; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3575 | } |
| 3576 | |
Paul Thomas | 71f77fd | 2006-12-20 13:48:06 +0000 | [diff] [blame] | 3577 | /* Last ditch attempt. See if the reference is to an intrinsic |
| 3578 | that possesses a matching interface. 14.1.2.4 */ |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3579 | sym = c->symtree->n.sym; |
Paul Thomas | 71f77fd | 2006-12-20 13:48:06 +0000 | [diff] [blame] | 3580 | |
Daniel Kraft | c3005b0 | 2008-07-24 20:52:51 +0200 | [diff] [blame] | 3581 | if (!gfc_is_intrinsic (sym, 1, c->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3582 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3583 | gfc_error ("There is no specific subroutine for the generic %qs at %L", |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3584 | sym->name, &c->loc); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3585 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3586 | } |
| 3587 | |
| 3588 | m = gfc_intrinsic_sub_interface (c, 0); |
| 3589 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3590 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3591 | if (m == MATCH_NO) |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3592 | gfc_error ("Generic subroutine %qs at %L is not consistent with an " |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3593 | "intrinsic subroutine interface", sym->name, &c->loc); |
| 3594 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3595 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3596 | } |
| 3597 | |
| 3598 | |
| 3599 | /* Resolve a subroutine call known to be specific. */ |
| 3600 | |
| 3601 | static match |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3602 | resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3603 | { |
| 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3627 | gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3628 | "with an intrinsic", sym->name, &c->loc); |
| 3629 | |
| 3630 | return MATCH_ERROR; |
| 3631 | } |
| 3632 | |
| 3633 | return MATCH_NO; |
| 3634 | |
| 3635 | found: |
| 3636 | gfc_procedure_use (sym, &c->ext.actual, &c->loc); |
| 3637 | |
| 3638 | c->resolved_sym = sym; |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3639 | if (!pure_subroutine (sym, sym->name, &c->loc)) |
| 3640 | return MATCH_ERROR; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3641 | |
| 3642 | return MATCH_YES; |
| 3643 | } |
| 3644 | |
| 3645 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3646 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3647 | resolve_specific_s (gfc_code *c) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3648 | { |
| 3649 | gfc_symbol *sym; |
| 3650 | match m; |
| 3651 | |
| 3652 | sym = c->symtree->n.sym; |
| 3653 | |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3654 | for (;;) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3655 | { |
| 3656 | m = resolve_specific_s0 (c, sym); |
| 3657 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3658 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3659 | if (m == MATCH_ERROR) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3660 | return false; |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3661 | |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3669 | } |
| 3670 | |
Paul Thomas | 8c086c9 | 2006-08-30 05:18:36 +0000 | [diff] [blame] | 3671 | sym = c->symtree->n.sym; |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3672 | gfc_error ("Unable to resolve the specific subroutine %qs at %L", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3673 | sym->name, &c->loc); |
| 3674 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3675 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3676 | } |
| 3677 | |
| 3678 | |
| 3679 | /* Resolve a subroutine call not known to be generic nor specific. */ |
| 3680 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3681 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3682 | resolve_unknown_s (gfc_code *c) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3683 | { |
| 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 Kraft | c3005b0 | 2008-07-24 20:52:51 +0200 | [diff] [blame] | 3696 | if (gfc_is_intrinsic (sym, 1, c->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3697 | { |
| 3698 | if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3699 | return true; |
| 3700 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3701 | } |
| 3702 | |
| 3703 | /* The reference is to an external name. */ |
| 3704 | |
| 3705 | found: |
| 3706 | gfc_procedure_use (sym, &c->ext.actual, &c->loc); |
| 3707 | |
| 3708 | c->resolved_sym = sym; |
| 3709 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 3710 | return pure_subroutine (sym, sym->name, &c->loc); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3711 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3718 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3719 | resolve_call (gfc_code *c) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3720 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3721 | bool t; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 3722 | procedure_type ptype = PROC_INTRINSIC; |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 3723 | gfc_symbol *csym, *sym; |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 3724 | bool no_formal_args; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3725 | |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 3726 | csym = c->symtree ? c->symtree->n.sym : NULL; |
| 3727 | |
| 3728 | if (csym && csym->ts.type != BT_UNKNOWN) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 3729 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 3730 | gfc_error ("%qs at %L has a type, which is not consistent with " |
Paul Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 3731 | "the CALL at %L", csym->name, &csym->declared_at, &c->loc); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3732 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 3733 | } |
| 3734 | |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 3735 | if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) |
| 3736 | { |
Paul Thomas | 79b1d36 | 2009-01-03 17:47:20 +0000 | [diff] [blame] | 3737 | gfc_symtree *st; |
Mikael Morin | d932cea | 2013-01-06 15:50:09 +0000 | [diff] [blame] | 3738 | gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); |
Paul Thomas | 79b1d36 | 2009-01-03 17:47:20 +0000 | [diff] [blame] | 3739 | sym = st ? st->n.sym : NULL; |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 3740 | 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 Thomas | 79b1d36 | 2009-01-03 17:47:20 +0000 | [diff] [blame] | 3746 | if (csym->attr.generic) |
| 3747 | c->symtree->n.sym = sym; |
| 3748 | else |
| 3749 | c->symtree = st; |
| 3750 | csym = c->symtree->n.sym; |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 3751 | } |
| 3752 | } |
| 3753 | |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3754 | /* If this ia a deferred TBP, c->expr1 will be set. */ |
| 3755 | if (!c->expr1 && csym) |
Janus Weil | 8bae627 | 2009-11-05 11:42:48 +0100 | [diff] [blame] | 3756 | { |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3757 | if (csym->attr.abstract) |
| 3758 | { |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3759 | gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3760 | csym->name, &c->loc); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3761 | return false; |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3762 | } |
Janus Weil | 8bae627 | 2009-11-05 11:42:48 +0100 | [diff] [blame] | 3763 | |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3764 | /* 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3769 | gfc_error ("ENTRY %qs at %L cannot be called recursively, " |
| 3770 | "as subroutine %qs is not RECURSIVE", |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3771 | csym->name, &c->loc, csym->ns->entries->sym->name); |
| 3772 | else |
Manuel López-Ibáñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 3773 | gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3774 | "as it is not RECURSIVE", csym->name, &c->loc); |
Daniel Kraft | 1933ba0 | 2008-11-30 21:36:10 +0100 | [diff] [blame] | 3775 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3776 | t = false; |
Janus Weil | fdb1fa9 | 2013-02-12 13:15:26 +0100 | [diff] [blame] | 3777 | } |
Francois-Xavier Coudert | 77f131c | 2006-05-17 16:11:40 +0200 | [diff] [blame] | 3778 | } |
| 3779 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3780 | /* 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 Thomas | 0b4e2af | 2008-09-17 22:23:51 +0000 | [diff] [blame] | 3784 | if (csym) |
| 3785 | ptype = csym->attr.proc; |
Paul Thomas | 7fcafa7 | 2006-12-31 06:55:16 +0000 | [diff] [blame] | 3786 | |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 3787 | no_formal_args = csym && is_external_proc (csym) |
| 3788 | && gfc_sym_get_dummy_args (csym) == NULL; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3789 | if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) |
| 3790 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3791 | |
Steven G. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 3792 | /* Resume assumed_size checking. */ |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3793 | need_full_assumed_size--; |
| 3794 | |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 3795 | /* If external, check for usage. */ |
| 3796 | if (csym && is_external_proc (csym)) |
Thomas Koenig | fb07836 | 2019-08-15 22:52:40 +0000 | [diff] [blame] | 3797 | resolve_global_procedure (csym, &c->loc, 1); |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 3798 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3799 | t = true; |
Richard Sandiford | 1524f80 | 2005-12-13 05:23:12 +0000 | [diff] [blame] | 3800 | if (c->resolved_sym == NULL) |
Daniel Kraft | 12f681a | 2008-11-01 14:26:19 +0100 | [diff] [blame] | 3801 | { |
| 3802 | c->resolved_isym = NULL; |
| 3803 | switch (procedure_kind (csym)) |
| 3804 | { |
| 3805 | case PTYPE_GENERIC: |
| 3806 | t = resolve_generic_s (c); |
| 3807 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3808 | |
Daniel Kraft | 12f681a | 2008-11-01 14:26:19 +0100 | [diff] [blame] | 3809 | case PTYPE_SPECIFIC: |
| 3810 | t = resolve_specific_s (c); |
| 3811 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3812 | |
Daniel Kraft | 12f681a | 2008-11-01 14:26:19 +0100 | [diff] [blame] | 3813 | case PTYPE_UNKNOWN: |
| 3814 | t = resolve_unknown_s (c); |
| 3815 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3816 | |
Daniel Kraft | 12f681a | 2008-11-01 14:26:19 +0100 | [diff] [blame] | 3817 | default: |
| 3818 | gfc_internal_error ("resolve_subroutine(): bad function type"); |
| 3819 | } |
| 3820 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3821 | |
Paul Thomas | b8ea6db | 2006-07-16 15:01:59 +0000 | [diff] [blame] | 3822 | /* Some checks of elemental subroutine actual arguments. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3823 | if (!resolve_elemental_actual (NULL, c)) |
| 3824 | return false; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 3825 | |
Paul Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 3826 | 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 Burnus | 0caf400 | 2020-11-03 09:55:58 +0100 | [diff] [blame] | 3832 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3838 | return t; |
| 3839 | } |
| 3840 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3841 | |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3842 | /* Compare the shapes of two arrays that have non-NULL shapes. If both |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3843 | 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. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3845 | if their shapes do not match. If either op1->shape or op2->shape is |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3846 | NULL, return true. */ |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3847 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3848 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3849 | compare_shapes (gfc_expr *op1, gfc_expr *op2) |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3850 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3851 | bool t; |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3852 | int i; |
| 3853 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3854 | t = true; |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 3855 | |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3856 | 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 3862 | gfc_error ("Shapes for operands at %L and %L are not conformable", |
| 3863 | &op1->where, &op2->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 3864 | t = false; |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 3865 | break; |
| 3866 | } |
| 3867 | } |
| 3868 | } |
| 3869 | |
| 3870 | return t; |
| 3871 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 3872 | |
Fritz Reese | dd90ca3 | 2016-10-25 18:27:51 +0000 | [diff] [blame] | 3873 | /* Convert a logical operator to the corresponding bitwise intrinsic call. |
| 3874 | For example A .AND. B becomes IAND(A, B). */ |
| 3875 | static gfc_expr * |
| 3876 | logical_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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 3955 | |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 3956 | /* Recursively append candidate UOP to CANDIDATES. Store the number of |
| 3957 | candidates in CANDIDATES_LEN. */ |
| 3958 | static void |
| 3959 | lookup_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 | |
| 3986 | static const char* |
| 3987 | lookup_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 Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 3996 | /* 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 | |
| 4000 | static int |
| 4001 | impure_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 Eggleston | 32bef8f | 2019-11-25 10:36:25 +0000 | [diff] [blame] | 4030 | /* Return true if TYPE is character based, false otherwise. */ |
| 4031 | |
| 4032 | static int |
| 4033 | is_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 | |
| 4042 | static void |
| 4043 | convert_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 | |
| 4057 | static void |
| 4058 | convert_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 Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 4066 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4067 | /* Resolve an operator expression node. This can involve replacing the |
| 4068 | operation with a user defined function call. */ |
| 4069 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4070 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4071 | resolve_operator (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4072 | { |
| 4073 | gfc_expr *op1, *op2; |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4074 | /* One error uses 3 names; additional space for wording (also via gettext). */ |
| 4075 | char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50]; |
Francois-Xavier Coudert | 2718929 | 2007-03-25 09:01:23 +0000 | [diff] [blame] | 4076 | bool dual_locus_error; |
Martin Liska | 53fcf72 | 2019-02-13 14:04:56 +0100 | [diff] [blame] | 4077 | bool t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4078 | |
| 4079 | /* Resolve all subnodes-- give them types. */ |
| 4080 | |
Kaveh R. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 4081 | switch (e->value.op.op) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4082 | { |
| 4083 | default: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4084 | if (!gfc_resolve_expr (e->value.op.op2)) |
Sandra Loosemore | ee11be7 | 2021-11-04 15:43:29 -0700 | [diff] [blame] | 4085 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4086 | |
Marek Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 4087 | /* Fall through. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4088 | |
| 4089 | case INTRINSIC_NOT: |
| 4090 | case INTRINSIC_UPLUS: |
| 4091 | case INTRINSIC_UMINUS: |
Tobias Schlüter | 2414e1d | 2006-02-10 01:10:47 +0100 | [diff] [blame] | 4092 | case INTRINSIC_PARENTHESES: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4093 | if (!gfc_resolve_expr (e->value.op.op1)) |
| 4094 | return false; |
Steven G. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4095 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4103 | break; |
| 4104 | } |
| 4105 | |
| 4106 | /* Typecheck the new node. */ |
| 4107 | |
Tobias Schlüter | 58b03ab | 2005-02-23 22:34:11 +0100 | [diff] [blame] | 4108 | op1 = e->value.op.op1; |
| 4109 | op2 = e->value.op.op2; |
Thomas König | 4dc6437 | 2020-04-19 12:56:32 +0200 | [diff] [blame] | 4110 | if (op1 == NULL && op2 == NULL) |
| 4111 | return false; |
Sandra Loosemore | ee11be7 | 2021-11-04 15:43:29 -0700 | [diff] [blame] | 4112 | /* Error out if op2 did not resolve. We already diagnosed op1. */ |
| 4113 | if (t == false) |
| 4114 | return false; |
Thomas König | 4dc6437 | 2020-04-19 12:56:32 +0200 | [diff] [blame] | 4115 | |
Francois-Xavier Coudert | 2718929 | 2007-03-25 09:01:23 +0000 | [diff] [blame] | 4116 | dual_locus_error = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4117 | |
Steven G. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4118 | /* 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 Burnus | bb9e683 | 2007-07-03 10:02:08 +0200 | [diff] [blame] | 4128 | if ((op1 && op1->expr_type == EXPR_NULL) |
| 4129 | || (op2 && op2->expr_type == EXPR_NULL)) |
| 4130 | { |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4131 | snprintf (msg, sizeof (msg), |
| 4132 | _("Invalid context for NULL() pointer at %%L")); |
Tobias Burnus | bb9e683 | 2007-07-03 10:02:08 +0200 | [diff] [blame] | 4133 | goto bad_op; |
| 4134 | } |
| 4135 | |
Kaveh R. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 4136 | switch (e->value.op.op) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4137 | { |
| 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 Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4148 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4151 | 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 Franke | dcea1b2 | 2009-12-11 16:08:39 -0500 | [diff] [blame] | 4160 | gfc_type_convert_binary (e, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4161 | break; |
| 4162 | } |
| 4163 | |
Steven G. Kargl | 1dd88f8 | 2018-06-09 15:58:24 +0000 | [diff] [blame] | 4164 | if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4165 | snprintf (msg, sizeof (msg), |
| 4166 | _("Unexpected derived-type entities in binary intrinsic " |
| 4167 | "numeric operator %%<%s%%> at %%L"), |
Steven G. Kargl | 1dd88f8 | 2018-06-09 15:58:24 +0000 | [diff] [blame] | 4168 | gfc_op2string (e->value.op.op)); |
| 4169 | else |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4170 | 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 Eggleston | f61e54e | 2019-10-03 09:40:23 +0000 | [diff] [blame] | 4173 | gfc_typename (op2)); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4174 | goto bad_op; |
| 4175 | |
| 4176 | case INTRINSIC_CONCAT: |
Francois-Xavier Coudert | d393bbd | 2008-05-18 22:45:05 +0000 | [diff] [blame] | 4177 | if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER |
| 4178 | && op1->ts.kind == op2->ts.kind) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4179 | { |
| 4180 | e->ts.type = BT_CHARACTER; |
| 4181 | e->ts.kind = op1->ts.kind; |
| 4182 | break; |
| 4183 | } |
| 4184 | |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4185 | snprintf (msg, sizeof (msg), |
| 4186 | _("Operands of string concatenation operator at %%L are %s/%s"), |
| 4187 | gfc_typename (op1), gfc_typename (op2)); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4188 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4198 | 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 Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 4202 | |
Janus Weil | bf9197d | 2018-08-10 16:08:53 +0200 | [diff] [blame] | 4203 | if (flag_frontend_optimize && |
| 4204 | (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)) |
Janus Weil | 6457b1f | 2018-07-18 20:31:59 +0200 | [diff] [blame] | 4205 | { |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4211 | break; |
| 4212 | } |
| 4213 | |
Fritz Reese | dd90ca3 | 2016-10-25 18:27:51 +0000 | [diff] [blame] | 4214 | /* 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 Liska | 53fcf72 | 2019-02-13 14:04:56 +0100 | [diff] [blame] | 4225 | goto simplify_op; |
Fritz Reese | dd90ca3 | 2016-10-25 18:27:51 +0000 | [diff] [blame] | 4226 | } |
| 4227 | |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4228 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4232 | |
| 4233 | goto bad_op; |
| 4234 | |
| 4235 | case INTRINSIC_NOT: |
Fritz Reese | dd90ca3 | 2016-10-25 18:27:51 +0000 | [diff] [blame] | 4236 | /* 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 Liska | 53fcf72 | 2019-02-13 14:04:56 +0100 | [diff] [blame] | 4242 | goto simplify_op; |
Fritz Reese | dd90ca3 | 2016-10-25 18:27:51 +0000 | [diff] [blame] | 4243 | } |
| 4244 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4245 | 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 Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4252 | snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"), |
| 4253 | gfc_typename (op1)); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4254 | goto bad_op; |
| 4255 | |
| 4256 | case INTRINSIC_GT: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4257 | case INTRINSIC_GT_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4258 | case INTRINSIC_GE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4259 | case INTRINSIC_GE_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4260 | case INTRINSIC_LT: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4261 | case INTRINSIC_LT_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4262 | case INTRINSIC_LE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4263 | case INTRINSIC_LE_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4264 | if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) |
| 4265 | { |
Francois-Xavier Coudert | 31043f6 | 2005-09-17 20:58:01 +0200 | [diff] [blame] | 4266 | strcpy (msg, _("COMPLEX quantities cannot be compared at %L")); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4267 | goto bad_op; |
| 4268 | } |
| 4269 | |
Marek Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 4270 | /* Fall through. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4271 | |
| 4272 | case INTRINSIC_EQ: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4273 | case INTRINSIC_EQ_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4274 | case INTRINSIC_NE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4275 | case INTRINSIC_NE_OS: |
Mark Eggleston | 32bef8f | 2019-11-25 10:36:25 +0000 | [diff] [blame] | 4276 | |
| 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 Coudert | d393bbd | 2008-05-18 22:45:05 +0000 | [diff] [blame] | 4285 | if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER |
| 4286 | && op1->ts.kind == op2->ts.kind) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4287 | { |
| 4288 | e->ts.type = BT_LOGICAL; |
Tobias Schlüter | 9d64df1 | 2004-08-27 16:49:35 +0200 | [diff] [blame] | 4289 | e->ts.kind = gfc_default_logical_kind; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4290 | break; |
| 4291 | } |
| 4292 | |
Steven G. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4293 | /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ |
| 4294 | if (op1->ts.type == BT_BOZ) |
| 4295 | { |
Mark Eggleston | 0a7183f | 2020-06-02 08:38:01 +0100 | [diff] [blame] | 4296 | 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. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4299 | 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 Eggleston | 0a7183f | 2020-06-02 08:38:01 +0100 | [diff] [blame] | 4311 | if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear" |
| 4312 | " as an operand of a relational operator"), |
Steven G. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4313 | &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 Eggleston | 32bef8f | 2019-11-25 10:36:25 +0000 | [diff] [blame] | 4322 | 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. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 4329 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4330 | if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) |
| 4331 | { |
Daniel Franke | dcea1b2 | 2009-12-11 16:08:39 -0500 | [diff] [blame] | 4332 | gfc_type_convert_binary (e, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4333 | |
| 4334 | e->ts.type = BT_LOGICAL; |
Tobias Schlüter | 9d64df1 | 2004-08-27 16:49:35 +0200 | [diff] [blame] | 4335 | e->ts.kind = gfc_default_logical_kind; |
Thomas Koenig | cf21551 | 2012-08-19 15:05:41 +0000 | [diff] [blame] | 4336 | |
Tobias Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 4337 | if (warn_compare_reals) |
Thomas Koenig | cf21551 | 2012-08-19 15:05:41 +0000 | [diff] [blame] | 4338 | { |
| 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 Eggleston | 0a7183f | 2020-06-02 08:38:01 +0100 | [diff] [blame] | 4350 | msg = G_("Equality comparison for %s at %L"); |
Thomas Koenig | cf21551 | 2012-08-19 15:05:41 +0000 | [diff] [blame] | 4351 | else |
Mark Eggleston | 0a7183f | 2020-06-02 08:38:01 +0100 | [diff] [blame] | 4352 | msg = G_("Inequality comparison for %s at %L"); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 4353 | |
Janus Weil | 28ce22e | 2016-11-05 11:35:23 +0100 | [diff] [blame] | 4354 | gfc_warning (OPT_Wcompare_reals, msg, |
Mark Eggleston | f61e54e | 2019-10-03 09:40:23 +0000 | [diff] [blame] | 4355 | gfc_typename (op1), &op1->where); |
Thomas Koenig | cf21551 | 2012-08-19 15:05:41 +0000 | [diff] [blame] | 4356 | } |
| 4357 | } |
| 4358 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4359 | break; |
| 4360 | } |
| 4361 | |
Volker Reichelt | 6a28f51 | 2005-07-27 08:30:46 +0000 | [diff] [blame] | 4362 | if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4363 | 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 Reichelt | 6a28f51 | 2005-07-27 08:30:46 +0000 | [diff] [blame] | 4368 | else |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4369 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4373 | |
| 4374 | goto bad_op; |
| 4375 | |
| 4376 | case INTRINSIC_USER: |
Kaveh R. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 4377 | if (e->value.op.uop->op == NULL) |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 4378 | { |
| 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 Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4383 | snprintf (msg, sizeof (msg), |
| 4384 | _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), |
| 4385 | name, guessed); |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 4386 | else |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4387 | snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"), |
| 4388 | name); |
Bernhard Reutner-Fischer | bcc478b | 2017-10-19 09:24:33 +0200 | [diff] [blame] | 4389 | } |
Daniel Franke | 622af87 | 2007-06-29 15:05:58 -0400 | [diff] [blame] | 4390 | else if (op2 == NULL) |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4391 | snprintf (msg, sizeof (msg), |
| 4392 | _("Operand of user operator %%<%s%%> at %%L is %s"), |
| 4393 | e->value.op.uop->name, gfc_typename (op1)); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4394 | else |
Thomas Koenig | 7c1a49f | 2010-12-31 11:20:22 +0000 | [diff] [blame] | 4395 | { |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4396 | 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 Koenig | 7c1a49f | 2010-12-31 11:20:22 +0000 | [diff] [blame] | 4400 | e->value.op.uop->op->sym->attr.referenced = 1; |
| 4401 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4402 | |
| 4403 | goto bad_op; |
| 4404 | |
Tobias Schlüter | 2414e1d | 2006-02-10 01:10:47 +0100 | [diff] [blame] | 4405 | case INTRINSIC_PARENTHESES: |
Tobias Schlüter | dcdc83a | 2007-10-04 09:34:38 +0200 | [diff] [blame] | 4406 | e->ts = op1->ts; |
| 4407 | if (e->ts.type == BT_CHARACTER) |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 4408 | e->ts.u.cl = op1->ts.u.cl; |
Tobias Schlüter | 2414e1d | 2006-02-10 01:10:47 +0100 | [diff] [blame] | 4409 | break; |
| 4410 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4411 | default: |
| 4412 | gfc_internal_error ("resolve_operator(): Bad intrinsic"); |
| 4413 | } |
| 4414 | |
| 4415 | /* Deal with arrayness of an operand through an operator. */ |
| 4416 | |
Kaveh R. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 4417 | switch (e->value.op.op) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4418 | { |
| 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 Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4430 | case INTRINSIC_EQ_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4431 | case INTRINSIC_NE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4432 | case INTRINSIC_NE_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4433 | case INTRINSIC_GT: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4434 | case INTRINSIC_GT_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4435 | case INTRINSIC_GE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4436 | case INTRINSIC_GE_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4437 | case INTRINSIC_LT: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4438 | case INTRINSIC_LT_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4439 | case INTRINSIC_LE: |
Daniel Franke | 3bed9dd | 2007-07-08 17:08:52 -0400 | [diff] [blame] | 4440 | case INTRINSIC_LE_OS: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4441 | |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4466 | if (e->shape == NULL) |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 4467 | { |
Steven G. Kargl | d1d7b04 | 2010-06-11 00:06:30 +0000 | [diff] [blame] | 4468 | t = compare_shapes (op1, op2); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4469 | if (!t) |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 4470 | e->shape = NULL; |
| 4471 | else |
Steven G. Kargl | d1d7b04 | 2010-06-11 00:06:30 +0000 | [diff] [blame] | 4472 | e->shape = gfc_copy_shape (op1->shape, op1->rank); |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 4473 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4474 | } |
| 4475 | else |
| 4476 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4477 | /* Allow higher level expressions to work. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4478 | e->rank = 0; |
Francois-Xavier Coudert | 2718929 | 2007-03-25 09:01:23 +0000 | [diff] [blame] | 4479 | |
| 4480 | /* Try user-defined operators, and otherwise throw an error. */ |
| 4481 | dual_locus_error = true; |
Tobias Burnus | b179026 | 2021-03-24 07:50:22 +0100 | [diff] [blame] | 4482 | snprintf (msg, sizeof (msg), |
| 4483 | _("Inconsistent ranks for operator at %%L and %%L")); |
Francois-Xavier Coudert | 2718929 | 2007-03-25 09:01:23 +0000 | [diff] [blame] | 4484 | goto bad_op; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4485 | } |
| 4486 | } |
| 4487 | |
| 4488 | break; |
| 4489 | |
Paul Thomas | 08113c7 | 2007-07-24 19:15:27 +0000 | [diff] [blame] | 4490 | case INTRINSIC_PARENTHESES: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4491 | case INTRINSIC_NOT: |
| 4492 | case INTRINSIC_UPLUS: |
| 4493 | case INTRINSIC_UMINUS: |
Paul Thomas | 08113c7 | 2007-07-24 19:15:27 +0000 | [diff] [blame] | 4494 | /* Simply copy arrayness attribute */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4495 | e->rank = op1->rank; |
| 4496 | |
| 4497 | if (e->shape == NULL) |
| 4498 | e->shape = gfc_copy_shape (op1->shape, op1->rank); |
| 4499 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4500 | break; |
| 4501 | |
| 4502 | default: |
| 4503 | break; |
| 4504 | } |
| 4505 | |
Martin Liska | 53fcf72 | 2019-02-13 14:04:56 +0100 | [diff] [blame] | 4506 | simplify_op: |
| 4507 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4508 | /* Attempt to simplify the expression. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4509 | if (t) |
Paul Thomas | dd5ecf4 | 2006-12-04 19:30:33 +0000 | [diff] [blame] | 4510 | { |
| 4511 | t = gfc_simplify_expr (e, 0); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4512 | /* Some calls do not succeed in simplification and return false |
Ralf Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 4513 | even though there is no error; e.g. variable references to |
Paul Thomas | dd5ecf4 | 2006-12-04 19:30:33 +0000 | [diff] [blame] | 4514 | PARAMETER arrays. */ |
| 4515 | if (!gfc_is_constant_expr (e)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4516 | t = true; |
Paul Thomas | dd5ecf4 | 2006-12-04 19:30:33 +0000 | [diff] [blame] | 4517 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4518 | return t; |
| 4519 | |
| 4520 | bad_op: |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 4521 | |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 4522 | { |
Janus Weil | eaee02a | 2011-11-06 22:36:54 +0100 | [diff] [blame] | 4523 | match m = gfc_extend_expr (e); |
| 4524 | if (m == MATCH_YES) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4525 | return true; |
Janus Weil | eaee02a | 2011-11-06 22:36:54 +0100 | [diff] [blame] | 4526 | if (m == MATCH_ERROR) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4527 | return false; |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 4528 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4529 | |
Francois-Xavier Coudert | 2718929 | 2007-03-25 09:01:23 +0000 | [diff] [blame] | 4530 | if (dual_locus_error) |
| 4531 | gfc_error (msg, &op1->where, &op2->where); |
| 4532 | else |
| 4533 | gfc_error (msg, &e->where); |
Steven G. Kargl | 2c5ed58 | 2005-03-05 22:13:21 +0000 | [diff] [blame] | 4534 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4535 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4536 | } |
| 4537 | |
| 4538 | |
| 4539 | /************** Array resolution subroutines **************/ |
| 4540 | |
Trevor Saunders | a79683d | 2015-08-19 02:48:48 +0000 | [diff] [blame] | 4541 | enum compare_result |
| 4542 | { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4543 | |
| 4544 | /* Compare two integer expressions. */ |
| 4545 | |
Martin Liska | ff5ed3f | 2015-02-26 21:18:08 +0100 | [diff] [blame] | 4546 | static compare_result |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4547 | compare_bound (gfc_expr *a, gfc_expr *b) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4548 | { |
| 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 Koenig | df80a45 | 2007-12-16 21:09:34 +0000 | [diff] [blame] | 4555 | /* If either of the types isn't INTEGER, we must have |
| 4556 | raised an error earlier. */ |
| 4557 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4558 | if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) |
Thomas Koenig | df80a45 | 2007-12-16 21:09:34 +0000 | [diff] [blame] | 4559 | return CMP_UNKNOWN; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4560 | |
| 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 Liska | ff5ed3f | 2015-02-26 21:18:08 +0100 | [diff] [blame] | 4573 | static compare_result |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4574 | compare_bound_int (gfc_expr *a, int b) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4575 | { |
| 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 Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4594 | /* Compare an integer expression with a mpz_t. */ |
| 4595 | |
Martin Liska | ff5ed3f | 2015-02-26 21:18:08 +0100 | [diff] [blame] | 4596 | static compare_result |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4597 | compare_bound_mpz_t (gfc_expr *a, mpz_t b) |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4598 | { |
| 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 4617 | /* Compute the last value of a sequence given by a triplet. |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4618 | Return 0 if it wasn't able to compute the last value, or if the |
| 4619 | sequence if empty, and 1 otherwise. */ |
| 4620 | |
| 4621 | static int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4622 | compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, |
| 4623 | gfc_expr *stride, mpz_t last) |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4624 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4636 | if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4637 | { |
| 4638 | if (compare_bound (start, end) == CMP_GT) |
| 4639 | return 0; |
| 4640 | mpz_set (last, end->value.integer); |
| 4641 | return 1; |
| 4642 | } |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 4643 | |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4644 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4667 | /* Compare a single dimension of an array reference to the array |
| 4668 | specification. */ |
| 4669 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4670 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4671 | check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4672 | { |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4673 | mpz_t last_value; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4674 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4675 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4682 | return true; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4683 | } |
| 4684 | } |
| 4685 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4686 | /* Given start, end and stride values, calculate the minimum and |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 4687 | maximum referenced indexes. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4688 | |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4689 | switch (ar->dimen_type[i]) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4690 | { |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4691 | case DIMEN_VECTOR: |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 4692 | case DIMEN_THIS_IMAGE: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4693 | break; |
| 4694 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4695 | case DIMEN_STAR: |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4696 | case DIMEN_ELEMENT: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4697 | if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4698 | { |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4699 | if (i < as->rank) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4700 | gfc_warning (0, "Array reference at %L is out of bounds " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4701 | "(%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 Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4705 | gfc_warning (0, "Array reference at %L is out of bounds " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4706 | "(%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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4710 | return true; |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4711 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4712 | if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4713 | { |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4714 | if (i < as->rank) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4715 | gfc_warning (0, "Array reference at %L is out of bounds " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4716 | "(%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 Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4720 | gfc_warning (0, "Array reference at %L is out of bounds " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4721 | "(%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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4725 | return true; |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4726 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4727 | |
| 4728 | break; |
| 4729 | |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4730 | case DIMEN_RANGE: |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4731 | { |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4732 | #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 Liska | ff5ed3f | 2015-02-26 21:18:08 +0100 | [diff] [blame] | 4735 | compare_result comp_start_end = compare_bound (AR_START, AR_END); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4736 | |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4737 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4741 | return false; |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4742 | } |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4743 | |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4744 | /* 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 Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4755 | if (compare_bound (AR_START, as->lower[i]) == CMP_LT) |
| 4756 | { |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4757 | gfc_warning (0, "Lower array reference at %L is out of bounds " |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4758 | "(%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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4761 | return true; |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4762 | } |
| 4763 | if (compare_bound (AR_START, as->upper[i]) == CMP_GT) |
| 4764 | { |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4765 | gfc_warning (0, "Lower array reference at %L is out of bounds " |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4766 | "(%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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4769 | return true; |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4770 | } |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4771 | } |
| 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 Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4779 | if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT) |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4780 | { |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4781 | gfc_warning (0, "Upper array reference at %L is out of bounds " |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4782 | "(%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 Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4785 | mpz_clear (last_value); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4786 | return true; |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4787 | } |
| 4788 | if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) |
| 4789 | { |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 4790 | gfc_warning (0, "Upper array reference at %L is out of bounds " |
Tobias Burnus | 1954a27 | 2007-10-14 22:24:20 +0200 | [diff] [blame] | 4791 | "(%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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4795 | return true; |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4796 | } |
| 4797 | } |
| 4798 | mpz_clear (last_value); |
François-Xavier Coudert | 0094f36 | 2006-06-05 22:41:29 +0000 | [diff] [blame] | 4799 | |
| 4800 | #undef AR_START |
| 4801 | #undef AR_END |
Francois-Xavier Coudert | d912240 | 2007-03-24 20:19:51 +0000 | [diff] [blame] | 4802 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4803 | break; |
| 4804 | |
| 4805 | default: |
| 4806 | gfc_internal_error ("check_dimension(): Bad array reference"); |
| 4807 | } |
| 4808 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4809 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4810 | } |
| 4811 | |
| 4812 | |
| 4813 | /* Compare an array reference with an array specification. */ |
| 4814 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4815 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4816 | compare_spec_to_ref (gfc_array_ref *ar) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4817 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4826 | ||*/ (ar->type == AR_SECTION |
| 4827 | && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4828 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4829 | gfc_error ("Rightmost upper bound of assumed size array section " |
| 4830 | "not specified at %L", &ar->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4831 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4832 | } |
| 4833 | |
| 4834 | if (ar->type == AR_FULL) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4835 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4836 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4841 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4842 | } |
| 4843 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4844 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4849 | return false; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4850 | } |
| 4851 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4852 | for (i = 0; i < as->rank; i++) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4853 | if (!check_dimension (i, ar, as)) |
| 4854 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4855 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4856 | /* Local access has no coarray spec. */ |
| 4857 | if (ar->codimen != 0) |
| 4858 | for (i = as->rank; i < as->rank + as->corank; i++) |
| 4859 | { |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 4860 | if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate |
| 4861 | && ar->dimen_type[i] != DIMEN_THIS_IMAGE) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4862 | { |
| 4863 | gfc_error ("Coindex of codimension %d must be a scalar at %L", |
| 4864 | i + 1 - as->rank, &ar->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4865 | return false; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4866 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4867 | if (!check_dimension (i, ar, as)) |
| 4868 | return false; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 4869 | } |
| 4870 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4871 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4872 | } |
| 4873 | |
| 4874 | |
| 4875 | /* Resolve one part of an array index. */ |
| 4876 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4877 | static bool |
Richard Guenther | 92375a2 | 2010-04-22 08:34:41 +0000 | [diff] [blame] | 4878 | gfc_resolve_index_1 (gfc_expr *index, int check_scalar, |
| 4879 | int force_index_integer_kind) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4880 | { |
| 4881 | gfc_typespec ts; |
| 4882 | |
| 4883 | if (index == NULL) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4884 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4885 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4886 | if (!gfc_resolve_expr (index)) |
| 4887 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4888 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4889 | if (check_scalar && index->rank != 0) |
| 4890 | { |
| 4891 | gfc_error ("Array index at %L must be scalar", &index->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4892 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4893 | } |
| 4894 | |
Tobias Schlüter | ee94306 | 2005-03-13 19:46:36 +0100 | [diff] [blame] | 4895 | if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) |
| 4896 | { |
Jerry DeLisle | acb388a | 2008-05-16 16:44:28 +0000 | [diff] [blame] | 4897 | gfc_error ("Array index at %L must be of INTEGER type, found %s", |
| 4898 | &index->where, gfc_basic_typename (index->ts.type)); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4899 | return false; |
Tobias Schlüter | ee94306 | 2005-03-13 19:46:36 +0100 | [diff] [blame] | 4900 | } |
| 4901 | |
| 4902 | if (index->ts.type == BT_REAL) |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 4903 | if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4904 | &index->where)) |
| 4905 | return false; |
Tobias Schlüter | ee94306 | 2005-03-13 19:46:36 +0100 | [diff] [blame] | 4906 | |
Richard Guenther | 92375a2 | 2010-04-22 08:34:41 +0000 | [diff] [blame] | 4907 | if ((index->ts.kind != gfc_index_integer_kind |
| 4908 | && force_index_integer_kind) |
Tobias Schlüter | ee94306 | 2005-03-13 19:46:36 +0100 | [diff] [blame] | 4909 | || index->ts.type != BT_INTEGER) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4910 | { |
Erik Edelmann | 810306f | 2006-01-25 20:46:29 +0000 | [diff] [blame] | 4911 | gfc_clear_ts (&ts); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4912 | ts.type = BT_INTEGER; |
| 4913 | ts.kind = gfc_index_integer_kind; |
| 4914 | |
| 4915 | gfc_convert_type_warn (index, &ts, 2, 0); |
| 4916 | } |
| 4917 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4918 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4919 | } |
| 4920 | |
Richard Guenther | 92375a2 | 2010-04-22 08:34:41 +0000 | [diff] [blame] | 4921 | /* Resolve one part of an array index. */ |
| 4922 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4923 | bool |
Richard Guenther | 92375a2 | 2010-04-22 08:34:41 +0000 | [diff] [blame] | 4924 | gfc_resolve_index (gfc_expr *index, int check_scalar) |
| 4925 | { |
| 4926 | return gfc_resolve_index_1 (index, check_scalar, 1); |
| 4927 | } |
| 4928 | |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4929 | /* Resolve a dim argument to an intrinsic function. */ |
| 4930 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4931 | bool |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4932 | gfc_resolve_dim_arg (gfc_expr *dim) |
| 4933 | { |
| 4934 | if (dim == NULL) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4935 | return true; |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4936 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4937 | if (!gfc_resolve_expr (dim)) |
| 4938 | return false; |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4939 | |
| 4940 | if (dim->rank != 0) |
| 4941 | { |
| 4942 | gfc_error ("Argument dim at %L must be scalar", &dim->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4943 | return false; |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 4944 | |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4945 | } |
Jerry DeLisle | 33717d5 | 2007-11-18 20:53:16 +0000 | [diff] [blame] | 4946 | |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4947 | if (dim->ts.type != BT_INTEGER) |
| 4948 | { |
| 4949 | gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4950 | return false; |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4951 | } |
Jerry DeLisle | 33717d5 | 2007-11-18 20:53:16 +0000 | [diff] [blame] | 4952 | |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4953 | if (dim->ts.kind != gfc_index_integer_kind) |
| 4954 | { |
| 4955 | gfc_typespec ts; |
| 4956 | |
Jakub Jelinek | a79ff09 | 2010-02-11 20:47:20 +0100 | [diff] [blame] | 4957 | gfc_clear_ts (&ts); |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4958 | ts.type = BT_INTEGER; |
| 4959 | ts.kind = gfc_index_integer_kind; |
| 4960 | |
| 4961 | gfc_convert_type_warn (dim, &ts, 2, 0); |
| 4962 | } |
| 4963 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 4964 | return true; |
Thomas Koenig | bf30222 | 2005-08-10 20:16:29 +0000 | [diff] [blame] | 4965 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4966 | |
| 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 Thomas | 85fb1d7 | 2021-01-07 17:34:49 +0000 | [diff] [blame] | 4976 | static void |
| 4977 | resolve_assoc_var (gfc_symbol* sym, bool resolve_target); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4978 | |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 4979 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 4980 | find_array_spec (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4981 | { |
| 4982 | gfc_array_spec *as; |
| 4983 | gfc_component *c; |
| 4984 | gfc_ref *ref; |
Paul Thomas | 16a51cf | 2019-04-22 06:50:33 +0000 | [diff] [blame] | 4985 | bool class_as = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 4986 | |
Paul Thomas | 85fb1d7 | 2021-01-07 17:34:49 +0000 | [diff] [blame] | 4987 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 4994 | if (e->symtree->n.sym->ts.type == BT_CLASS) |
Paul Thomas | 16a51cf | 2019-04-22 06:50:33 +0000 | [diff] [blame] | 4995 | { |
| 4996 | as = CLASS_DATA (e->symtree->n.sym)->as; |
| 4997 | class_as = true; |
| 4998 | } |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 4999 | else |
| 5000 | as = e->symtree->n.sym->as; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5001 | |
| 5002 | for (ref = e->ref; ref; ref = ref->next) |
| 5003 | switch (ref->type) |
| 5004 | { |
| 5005 | case REF_ARRAY: |
| 5006 | if (as == NULL) |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 5007 | { |
Steve Kargl | 2eaa0cc | 2022-11-22 22:31:51 +0100 | [diff] [blame] | 5008 | locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where; |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 5009 | gfc_error ("Invalid array reference of a non-array entity at %L", |
Steve Kargl | 2eaa0cc | 2022-11-22 22:31:51 +0100 | [diff] [blame] | 5010 | &loc); |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 5011 | return false; |
| 5012 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5013 | |
| 5014 | ref->u.ar.as = as; |
| 5015 | as = NULL; |
| 5016 | break; |
| 5017 | |
| 5018 | case REF_COMPONENT: |
Tobias Burnus | 0213967 | 2011-12-04 17:33:15 +0100 | [diff] [blame] | 5019 | c = ref->u.c.component; |
Janus Weil | d4b7d0f | 2008-08-23 23:04:01 +0200 | [diff] [blame] | 5020 | if (c->attr.dimension) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5021 | { |
Paul Thomas | 16a51cf | 2019-04-22 06:50:33 +0000 | [diff] [blame] | 5022 | if (as != NULL && !(class_as && as == c->as)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5023 | gfc_internal_error ("find_array_spec(): unused as(1)"); |
| 5024 | as = c->as; |
| 5025 | } |
| 5026 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5027 | break; |
| 5028 | |
| 5029 | case REF_SUBSTRING: |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 5030 | case REF_INQUIRY: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5031 | break; |
| 5032 | } |
| 5033 | |
| 5034 | if (as != NULL) |
| 5035 | gfc_internal_error ("find_array_spec(): unused as(2)"); |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 5036 | |
| 5037 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5038 | } |
| 5039 | |
| 5040 | |
| 5041 | /* Resolve an array reference. */ |
| 5042 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5043 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5044 | resolve_array_ref (gfc_array_ref *ar) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5045 | { |
| 5046 | int i, check_scalar; |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5047 | gfc_expr *e; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5048 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 5049 | for (i = 0; i < ar->dimen + ar->codimen; i++) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5050 | { |
| 5051 | check_scalar = ar->dimen_type[i] == DIMEN_RANGE; |
| 5052 | |
Richard Guenther | 92375a2 | 2010-04-22 08:34:41 +0000 | [diff] [blame] | 5053 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5056 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5062 | |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5063 | e = ar->start[i]; |
| 5064 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5065 | if (ar->dimen_type[i] == DIMEN_UNKNOWN) |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5066 | switch (e->rank) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5067 | { |
| 5068 | case 0: |
| 5069 | ar->dimen_type[i] = DIMEN_ELEMENT; |
| 5070 | break; |
| 5071 | |
| 5072 | case 1: |
| 5073 | ar->dimen_type[i] = DIMEN_VECTOR; |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5074 | if (e->expr_type == EXPR_VARIABLE |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5075 | && e->symtree->n.sym->ts.type == BT_DERIVED) |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5076 | ar->start[i] = gfc_get_parentheses (e); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5077 | break; |
| 5078 | |
| 5079 | default: |
| 5080 | gfc_error ("Array index at %L is an array of rank %d", |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 5081 | &ar->c_where[i], e->rank); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5082 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5083 | } |
Thomas Koenig | ee24763 | 2010-08-09 19:34:49 +0000 | [diff] [blame] | 5084 | |
| 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 Koenig | 2d27cb4 | 2011-08-21 12:02:12 +0000 | [diff] [blame] | 5088 | to one. Don't try a division by zero. */ |
Thomas Koenig | ee24763 | 2010-08-09 19:34:49 +0000 | [diff] [blame] | 5089 | if (ar->dimen_type[i] == DIMEN_RANGE |
| 5090 | && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT |
Thomas Koenig | 2d27cb4 | 2011-08-21 12:02:12 +0000 | [diff] [blame] | 5091 | && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 |
| 5092 | && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) |
Thomas Koenig | ee24763 | 2010-08-09 19:34:49 +0000 | [diff] [blame] | 5093 | { |
| 5094 | mpz_t size, end; |
| 5095 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5096 | if (gfc_ref_dimen_size (ar, i, &size, &end)) |
Thomas Koenig | ee24763 | 2010-08-09 19:34:49 +0000 | [diff] [blame] | 5097 | { |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5117 | } |
| 5118 | |
Mikael Morin | 5551a54 | 2011-10-07 21:56:11 +0200 | [diff] [blame] | 5119 | 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 5136 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5137 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5151 | if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) |
| 5152 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5153 | |
Mikael Morin | b78a06b | 2011-10-07 21:07:04 +0200 | [diff] [blame] | 5154 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5162 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5163 | } |
| 5164 | |
| 5165 | |
Harald Anlauf | bdd1b1f | 2021-01-14 20:25:33 +0100 | [diff] [blame] | 5166 | bool |
| 5167 | gfc_resolve_substring (gfc_ref *ref, bool *equal_length) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5168 | { |
Francois-Xavier Coudert | b0c0681 | 2009-05-16 16:53:02 +0000 | [diff] [blame] | 5169 | int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); |
| 5170 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5171 | if (ref->u.ss.start != NULL) |
| 5172 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5173 | if (!gfc_resolve_expr (ref->u.ss.start)) |
| 5174 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5175 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5180 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5181 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5187 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5188 | } |
| 5189 | |
Francois-Xavier Coudert | 97bca51 | 2006-06-24 20:10:47 +0200 | [diff] [blame] | 5190 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5193 | { |
| 5194 | gfc_error ("Substring start index at %L is less than one", |
| 5195 | &ref->u.ss.start->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5196 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5197 | } |
| 5198 | } |
| 5199 | |
| 5200 | if (ref->u.ss.end != NULL) |
| 5201 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5202 | if (!gfc_resolve_expr (ref->u.ss.end)) |
| 5203 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5204 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5209 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5210 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5216 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5217 | } |
| 5218 | |
| 5219 | if (ref->u.ss.length != NULL |
Francois-Xavier Coudert | 97bca51 | 2006-06-24 20:10:47 +0200 | [diff] [blame] | 5220 | && 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5223 | { |
Francois-Xavier Coudert | 97bca51 | 2006-06-24 20:10:47 +0200 | [diff] [blame] | 5224 | gfc_error ("Substring end index at %L exceeds the string length", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5225 | &ref->u.ss.start->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5226 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5227 | } |
Francois-Xavier Coudert | b0c0681 | 2009-05-16 16:53:02 +0000 | [diff] [blame] | 5228 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5236 | return false; |
Francois-Xavier Coudert | b0c0681 | 2009-05-16 16:53:02 +0000 | [diff] [blame] | 5237 | } |
Thomas Koenig | 0335cc3 | 2019-01-15 22:18:55 +0000 | [diff] [blame] | 5238 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5245 | } |
| 5246 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5247 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5248 | } |
| 5249 | |
| 5250 | |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5251 | /* This function supplies missing substring charlens. */ |
| 5252 | |
| 5253 | void |
| 5254 | gfc_resolve_substring_charlen (gfc_expr *e) |
| 5255 | { |
| 5256 | gfc_ref *char_ref; |
| 5257 | gfc_expr *start, *end; |
Louis Krupp | 58864d1 | 2015-10-06 23:47:18 +0000 | [diff] [blame] | 5258 | gfc_typespec *ts = NULL; |
Harald Anlauf | 1fe2703 | 2019-02-09 17:25:23 +0000 | [diff] [blame] | 5259 | mpz_t diff; |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5260 | |
| 5261 | for (char_ref = e->ref; char_ref; char_ref = char_ref->next) |
Louis Krupp | 58864d1 | 2015-10-06 23:47:18 +0000 | [diff] [blame] | 5262 | { |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 5263 | if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) |
| 5264 | break; |
Louis Krupp | 58864d1 | 2015-10-06 23:47:18 +0000 | [diff] [blame] | 5265 | if (char_ref->type == REF_COMPONENT) |
| 5266 | ts = &char_ref->u.c.component->ts; |
| 5267 | } |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5268 | |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 5269 | if (!char_ref || char_ref->type == REF_INQUIRY) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5270 | return; |
| 5271 | |
| 5272 | gcc_assert (char_ref->next == NULL); |
| 5273 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 5274 | if (e->ts.u.cl) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5275 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 5276 | if (e->ts.u.cl->length) |
| 5277 | gfc_free_expr (e->ts.u.cl->length); |
Steven G. Kargl | 98a819e | 2015-10-17 16:50:47 +0000 | [diff] [blame] | 5278 | else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5279 | return; |
| 5280 | } |
| 5281 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 5282 | if (!e->ts.u.cl) |
Janus Weil | b76e28c | 2009-08-17 11:11:00 +0200 | [diff] [blame] | 5283 | e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5284 | |
| 5285 | if (char_ref->u.ss.start) |
| 5286 | start = gfc_copy_expr (char_ref->u.ss.start); |
| 5287 | else |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 5288 | start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5289 | |
| 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 Krupp | 58864d1 | 2015-10-06 23:47:18 +0000 | [diff] [blame] | 5293 | { |
| 5294 | if (!ts) |
| 5295 | ts = &e->symtree->n.sym->ts; |
| 5296 | end = gfc_copy_expr (ts->u.cl->length); |
| 5297 | } |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5298 | else |
| 5299 | end = NULL; |
| 5300 | |
| 5301 | if (!start || !end) |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 5302 | { |
| 5303 | gfc_free_expr (start); |
| 5304 | gfc_free_expr (end); |
| 5305 | return; |
| 5306 | } |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5307 | |
Harald Anlauf | 1fe2703 | 2019-02-09 17:25:23 +0000 | [diff] [blame] | 5308 | /* 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 Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5327 | |
Steven G. Kargl | 98a819e | 2015-10-17 16:50:47 +0000 | [diff] [blame] | 5328 | /* 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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 5335 | e->ts.u.cl->length->ts.type = BT_INTEGER; |
| 5336 | e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5337 | |
| 5338 | /* Make sure that the length is simplified. */ |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 5339 | gfc_simplify_expr (e->ts.u.cl->length, 1); |
| 5340 | gfc_resolve_expr (e->ts.u.cl->length); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 5341 | } |
| 5342 | |
| 5343 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5344 | /* Resolve subtype references. */ |
| 5345 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 5346 | bool |
| 5347 | gfc_resolve_ref (gfc_expr *expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5348 | { |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5349 | int current_part_dimension, n_components, seen_part_dimension, dim; |
| 5350 | gfc_ref *ref, **prev, *array_ref; |
Thomas Koenig | 0335cc3 | 2019-01-15 22:18:55 +0000 | [diff] [blame] | 5351 | bool equal_length; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5352 | |
| 5353 | for (ref = expr->ref; ref; ref = ref->next) |
| 5354 | if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) |
| 5355 | { |
Harald Anlauf | f838d15 | 2022-07-18 22:34:53 +0200 | [diff] [blame] | 5356 | if (!find_array_spec (expr)) |
| 5357 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5358 | break; |
| 5359 | } |
| 5360 | |
Martin Liska | a693d9b | 2019-02-04 14:28:34 +0100 | [diff] [blame] | 5361 | for (prev = &expr->ref; *prev != NULL; |
| 5362 | prev = *prev == NULL ? prev : &(*prev)->next) |
Thomas Koenig | b9e2570 | 2019-01-19 11:03:28 +0000 | [diff] [blame] | 5363 | switch ((*prev)->type) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5364 | { |
| 5365 | case REF_ARRAY: |
Thomas Koenig | b9e2570 | 2019-01-19 11:03:28 +0000 | [diff] [blame] | 5366 | if (!resolve_array_ref (&(*prev)->u.ar)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5367 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5368 | break; |
| 5369 | |
| 5370 | case REF_COMPONENT: |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 5371 | case REF_INQUIRY: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5372 | break; |
| 5373 | |
| 5374 | case REF_SUBSTRING: |
Thomas Koenig | 0335cc3 | 2019-01-15 22:18:55 +0000 | [diff] [blame] | 5375 | equal_length = false; |
Harald Anlauf | bdd1b1f | 2021-01-14 20:25:33 +0100 | [diff] [blame] | 5376 | if (!gfc_resolve_substring (*prev, &equal_length)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5377 | return false; |
Thomas Koenig | 0335cc3 | 2019-01-15 22:18:55 +0000 | [diff] [blame] | 5378 | |
| 5379 | if (expr->expr_type != EXPR_SUBSTRING && equal_length) |
| 5380 | { |
| 5381 | /* Remove the reference and move the charlen, if any. */ |
Thomas Koenig | b9e2570 | 2019-01-19 11:03:28 +0000 | [diff] [blame] | 5382 | ref = *prev; |
Thomas Koenig | 0335cc3 | 2019-01-15 22:18:55 +0000 | [diff] [blame] | 5383 | *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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5389 | 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 Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5397 | array_ref = NULL; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5398 | |
| 5399 | for (ref = expr->ref; ref; ref = ref->next) |
| 5400 | { |
| 5401 | switch (ref->type) |
| 5402 | { |
| 5403 | case REF_ARRAY: |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5404 | array_ref = ref; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5405 | switch (ref->u.ar.type) |
| 5406 | { |
| 5407 | case AR_FULL: |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 5408 | /* Coarray scalar. */ |
| 5409 | if (ref->u.ar.as->rank == 0) |
| 5410 | { |
| 5411 | current_part_dimension = 0; |
| 5412 | break; |
| 5413 | } |
| 5414 | /* Fall through. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5415 | case AR_SECTION: |
| 5416 | current_part_dimension = 1; |
| 5417 | break; |
| 5418 | |
| 5419 | case AR_ELEMENT: |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5420 | array_ref = NULL; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5421 | 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 Edelmann | 51f824b | 2006-11-19 21:27:16 +0000 | [diff] [blame] | 5431 | if (current_part_dimension || seen_part_dimension) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5432 | { |
Janus Weil | ef2bbc8 | 2009-11-11 23:37:31 +0100 | [diff] [blame] | 5433 | /* F03:C614. */ |
| 5434 | if (ref->u.c.component->attr.pointer |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 5435 | || 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5438 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5442 | return false; |
Erik Edelmann | 51f824b | 2006-11-19 21:27:16 +0000 | [diff] [blame] | 5443 | } |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 5444 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5448 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5452 | return false; |
Erik Edelmann | 51f824b | 2006-11-19 21:27:16 +0000 | [diff] [blame] | 5453 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5454 | } |
| 5455 | |
| 5456 | n_components++; |
| 5457 | break; |
| 5458 | |
| 5459 | case REF_SUBSTRING: |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5460 | break; |
| 5461 | |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 5462 | case REF_INQUIRY: |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5463 | /* Implement requirement in note 9.7 of F2018 that the result of the |
| 5464 | LEN inquiry be a scalar. */ |
Mark Eggleston | b0d84ec | 2020-03-23 14:42:20 +0000 | [diff] [blame] | 5465 | if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred) |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5466 | { |
| 5467 | array_ref->u.ar.type = AR_ELEMENT; |
| 5468 | expr->rank = 0; |
Jakub Jelinek | 700d4cb | 2020-03-17 13:52:19 +0100 | [diff] [blame] | 5469 | /* INQUIRY_LEN is not evaluated from the rest of the expr |
Paul Thomas | 9de42a8 | 2020-03-08 18:52:35 +0000 | [diff] [blame] | 5470 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5487 | break; |
| 5488 | } |
| 5489 | |
| 5490 | if (((ref->type == REF_COMPONENT && n_components > 1) |
| 5491 | || ref->next == NULL) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5492 | && current_part_dimension |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5493 | && seen_part_dimension) |
| 5494 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5495 | gfc_error ("Two or more part references with nonzero rank must " |
| 5496 | "not be specified at %L", &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5497 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5498 | } |
| 5499 | |
| 5500 | if (ref->type == REF_COMPONENT) |
| 5501 | { |
| 5502 | if (current_part_dimension) |
| 5503 | seen_part_dimension = 1; |
| 5504 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5505 | /* reset to make sure */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5506 | current_part_dimension = 0; |
| 5507 | } |
| 5508 | } |
| 5509 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5510 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5511 | } |
| 5512 | |
| 5513 | |
| 5514 | /* Given an expression, determine its shape. This is easier than it sounds. |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 5515 | Leaves the shape array NULL if it is not possible to determine the shape. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5516 | |
| 5517 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5518 | expression_shape (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5519 | { |
| 5520 | mpz_t array[GFC_MAX_DIMENSIONS]; |
| 5521 | int i; |
| 5522 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5523 | if (e->rank <= 0 || e->shape != NULL) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5524 | return; |
| 5525 | |
| 5526 | for (i = 0; i < e->rank; i++) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5527 | if (!gfc_array_dimen_size (e, i, &array[i])) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5528 | 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 | |
| 5536 | fail: |
| 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 Vehreschild | 76fe932 | 2016-02-11 17:48:45 +0100 | [diff] [blame] | 5545 | void |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 5546 | gfc_expression_rank (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5547 | { |
| 5548 | gfc_ref *ref; |
| 5549 | int i, rank; |
| 5550 | |
Daniel Kraft | 00ca664 | 2008-09-09 20:08:08 +0200 | [diff] [blame] | 5551 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5555 | if (e->ref == NULL) |
| 5556 | { |
| 5557 | if (e->expr_type == EXPR_ARRAY) |
| 5558 | goto done; |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 5559 | /* Constructors can have a rank different from one via RESHAPE(). */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5560 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 5561 | e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL) |
| 5562 | ? 0 : e->symtree->n.sym->as->rank); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5563 | goto done; |
| 5564 | } |
| 5565 | |
| 5566 | rank = 0; |
| 5567 | |
| 5568 | for (ref = e->ref; ref; ref = ref->next) |
| 5569 | { |
Janus Weil | 2d300fa | 2011-01-18 23:40:33 +0100 | [diff] [blame] | 5570 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5574 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5585 | /* Figure out the rank of the section. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5586 | if (rank != 0) |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 5587 | gfc_internal_error ("gfc_expression_rank(): Two array specs"); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5588 | |
| 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 | |
| 5600 | done: |
| 5601 | expression_shape (e); |
| 5602 | } |
| 5603 | |
| 5604 | |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 5605 | static void |
| 5606 | add_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 | |
| 5635 | static void |
| 5636 | remove_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 Burnus | b511626 | 2014-06-17 22:54:14 +0200 | [diff] [blame] | 5641 | e->value.function.actual->expr = NULL; |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 5642 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5649 | /* Resolve a variable expression. */ |
| 5650 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5651 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5652 | resolve_variable (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5653 | { |
| 5654 | gfc_symbol *sym; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5655 | bool t; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5656 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5657 | t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5658 | |
Paul Thomas | 3e978d3 | 2006-08-20 05:45:43 +0000 | [diff] [blame] | 5659 | if (e->symtree == NULL) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5660 | return false; |
Daniel Kraft | 52bf62f | 2010-08-15 21:46:21 +0200 | [diff] [blame] | 5661 | sym = e->symtree->n.sym; |
| 5662 | |
Tobias Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 5663 | /* 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 Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5674 | /* TS 29113, 407b. */ |
Tobias Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 5675 | else if (e->ts.type == BT_ASSUMED) |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5676 | { |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5677 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5681 | return false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5682 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5692 | return false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5693 | } |
| 5694 | } |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5695 | /* TS 29113, C535b. */ |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 5696 | else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 5697 | && sym->ts.u.derived && CLASS_DATA (sym) |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 5698 | && 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5703 | { |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 5704 | if (!actual_arg |
| 5705 | && !(cs_base && cs_base->current |
| 5706 | && cs_base->current->op == EXEC_SELECT_RANK)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5707 | { |
| 5708 | gfc_error ("Assumed-rank variable %s at %L may only be used as " |
| 5709 | "actual argument", sym->name, &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5710 | return false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5711 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5721 | return false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5722 | } |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5723 | } |
| 5724 | |
Tobias Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 5725 | if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5726 | && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5727 | && e->ref->next == NULL)) |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5728 | { |
Tobias Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 5729 | 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5738 | gfc_error ("Assumed-type variable %s at %L shall not have a subobject " |
| 5739 | "reference", sym->name, &e->ref->u.ar.where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5740 | return false; |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 5741 | } |
| 5742 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5743 | /* TS 29113, C535b. */ |
| 5744 | if (((sym->ts.type == BT_CLASS && sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 5745 | && sym->ts.u.derived && CLASS_DATA (sym) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5746 | && 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5756 | return false; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5757 | } |
| 5758 | |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 5759 | /* 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 Thomas | 51a025fb | 2018-11-24 09:07:23 +0000 | [diff] [blame] | 5764 | && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS |
Harald Anlauf | d8f6c48 | 2021-12-27 23:06:18 +0100 | [diff] [blame] | 5765 | && sym->assoc->target->ts.u.derived |
| 5766 | && CLASS_DATA (sym->assoc->target) |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 5767 | && 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 5785 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 5786 | /* If this is an associate-name, it may be parsed with an array reference |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 5787 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5794 | return false; |
Paul Thomas | ece6652 | 2018-10-17 07:16:16 +0000 | [diff] [blame] | 5795 | 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 Thomas | ece6652 | 2018-10-17 07:16:16 +0000 | [diff] [blame] | 5802 | 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 Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 5812 | } |
Daniel Kraft | 52bf62f | 2010-08-15 21:46:21 +0200 | [diff] [blame] | 5813 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 5814 | 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 Kraft | 52bf62f | 2010-08-15 21:46:21 +0200 | [diff] [blame] | 5817 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5826 | |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 5827 | /* 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 Anlauf | d8f6c48 | 2021-12-27 23:06:18 +0100 | [diff] [blame] | 5830 | if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived |
| 5831 | && CLASS_DATA (sym) |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 5832 | && 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 Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 5871 | if (e->ref && !gfc_resolve_ref (e)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5872 | return false; |
Francois-Xavier Coudert | 009e94d | 2005-04-19 09:10:05 +0200 | [diff] [blame] | 5873 | |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 5874 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5879 | { |
| 5880 | e->ts.type = BT_PROCEDURE; |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 5881 | goto resolve_procedure; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5882 | } |
| 5883 | |
| 5884 | if (sym->ts.type != BT_UNKNOWN) |
| 5885 | gfc_variable_attr (e, &e->ts); |
Paul Thomas | 871267e | 2016-10-17 17:52:05 +0000 | [diff] [blame] | 5886 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5891 | else |
| 5892 | { |
| 5893 | /* Must be a simple variable reference. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5894 | if (!gfc_set_default_type (sym, 1, sym->ns)) |
| 5895 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 5896 | e->ts = sym->ts; |
| 5897 | } |
| 5898 | |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 5899 | if (check_assumed_size_reference (sym, e)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5900 | return false; |
Paul Thomas | 4847414 | 2006-01-07 14:14:08 +0000 | [diff] [blame] | 5901 | |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 5902 | /* Deal with forward references to entries during gfc_resolve_code, to |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5903 | satisfy, at least partially, 12.5.2.5. */ |
| 5904 | if (gfc_current_ns->entries |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 5905 | && current_entry_id == sym->entry_id |
| 5906 | && cs_base |
| 5907 | && cs_base->current |
| 5908 | && cs_base->current->op != EXEC_ENTRY) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5909 | { |
| 5910 | gfc_entry_list *entry; |
| 5911 | gfc_formal_arglist *formal; |
| 5912 | int n; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 5913 | bool seen, saved_specification_expr; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5914 | |
| 5915 | /* If the symbol is a dummy... */ |
Tobias Burnus | 70365b5 | 2007-10-20 13:34:21 +0200 | [diff] [blame] | 5916 | if (sym->attr.dummy && sym->ns == gfc_current_ns) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5917 | { |
| 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 Chang | 502af49 | 2013-07-29 13:08:03 -0600 | [diff] [blame] | 5926 | { |
| 5927 | seen = true; |
| 5928 | break; |
| 5929 | } |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5930 | } |
| 5931 | |
| 5932 | /* If it has not been seen as a dummy, this is an error. */ |
| 5933 | if (!seen) |
| 5934 | { |
| 5935 | if (specification_expr) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 5936 | gfc_error ("Variable %qs, used in a specification expression" |
Tobias Burnus | 70365b5 | 2007-10-20 13:34:21 +0200 | [diff] [blame] | 5937 | ", is referenced at %L before the ENTRY statement " |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5938 | "in which it is a parameter", |
| 5939 | sym->name, &cs_base->current->loc); |
| 5940 | else |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 5941 | gfc_error ("Variable %qs is used at %L before the ENTRY " |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5942 | "statement in which it is a parameter", |
| 5943 | sym->name, &cs_base->current->loc); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5944 | t = false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5945 | } |
| 5946 | } |
| 5947 | |
| 5948 | /* Now do the same check on the specification expressions. */ |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 5949 | saved_specification_expr = specification_expr; |
| 5950 | specification_expr = true; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5951 | if (sym->ts.type == BT_CHARACTER |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5952 | && !gfc_resolve_expr (sym->ts.u.cl->length)) |
| 5953 | t = false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5954 | |
| 5955 | if (sym->as) |
| 5956 | for (n = 0; n < sym->as->rank; n++) |
| 5957 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5958 | if (!gfc_resolve_expr (sym->as->lower[n])) |
| 5959 | t = false; |
| 5960 | if (!gfc_resolve_expr (sym->as->upper[n])) |
| 5961 | t = false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5962 | } |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 5963 | specification_expr = saved_specification_expr; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5964 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5965 | if (t) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 5966 | /* Update the symbol's entry level. */ |
| 5967 | sym->entry_id = current_entry_id + 1; |
| 5968 | } |
| 5969 | |
Paul Thomas | 022e30c | 2010-07-10 14:57:25 +0000 | [diff] [blame] | 5970 | /* 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 Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 5979 | 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 Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 5986 | resolve_procedure: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 5987 | if (t && !resolve_procedure_expression (e)) |
| 5988 | t = false; |
Daniel Kraft | a03826d | 2008-11-24 14:10:37 +0100 | [diff] [blame] | 5989 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 5990 | /* 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 5996 | 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 Burnus | a70de21 | 2010-12-11 23:04:06 +0100 | [diff] [blame] | 6008 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6013 | t = false; |
Tobias Burnus | a70de21 | 2010-12-11 23:04:06 +0100 | [diff] [blame] | 6014 | } |
| 6015 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 6016 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6026 | t = false; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 6027 | break; |
| 6028 | } |
| 6029 | } |
| 6030 | } |
| 6031 | |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 6032 | if (t) |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 6033 | gfc_expression_rank (e); |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 6034 | |
Tobias Burnus | f19626c | 2014-12-17 07:29:30 +0100 | [diff] [blame] | 6035 | if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 6036 | add_caf_get_intrinsic (e); |
| 6037 | |
Tobias Burnus | 0caf400 | 2020-11-03 09:55:58 +0100 | [diff] [blame] | 6038 | 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 Koenig | 06e8d82 | 2018-04-09 21:05:13 +0000 | [diff] [blame] | 6042 | /* 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 Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 6052 | return t; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 6053 | } |
| 6054 | |
| 6055 | |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6056 | /* 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 Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6059 | 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 Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6062 | static bool |
| 6063 | check_host_association (gfc_expr *e) |
| 6064 | { |
| 6065 | gfc_symbol *sym, *old_sym; |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6066 | gfc_symtree *st; |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6067 | int n; |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6068 | gfc_ref *ref; |
Steve Ellcey | e4bf01a | 2009-05-11 15:23:25 +0000 | [diff] [blame] | 6069 | gfc_actual_arglist *arg, *tail = NULL; |
Paul Thomas | 8de10a6 | 2007-06-25 18:27:59 +0000 | [diff] [blame] | 6070 | bool retval = e->expr_type == EXPR_FUNCTION; |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6071 | |
Paul Thomas | a1ab666 | 2009-01-04 23:17:37 +0000 | [diff] [blame] | 6072 | /* If the expression is the result of substitution in |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 6073 | interface.cc(gfc_extend_expr) because there is no way in |
Paul Thomas | a1ab666 | 2009-01-04 23:17:37 +0000 | [diff] [blame] | 6074 | which the host association can be wrong. */ |
| 6075 | if (e->symtree == NULL |
| 6076 | || e->symtree->n.sym == NULL |
| 6077 | || e->user_operator) |
Paul Thomas | 8de10a6 | 2007-06-25 18:27:59 +0000 | [diff] [blame] | 6078 | return retval; |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6079 | |
| 6080 | old_sym = e->symtree->n.sym; |
Paul Thomas | 8de10a6 | 2007-06-25 18:27:59 +0000 | [diff] [blame] | 6081 | |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6082 | if (gfc_current_ns->parent |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6083 | && old_sym->ns != gfc_current_ns) |
| 6084 | { |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6085 | /* Use the 'USE' name so that renamed module symbols are |
| 6086 | correctly handled. */ |
Paul Thomas | 9be3684 | 2009-01-10 00:11:18 +0000 | [diff] [blame] | 6087 | gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym); |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6088 | |
Paul Thomas | a944c79 | 2007-10-18 12:48:37 +0000 | [diff] [blame] | 6089 | if (sym && old_sym != sym |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 6090 | && sym->ts.type == old_sym->ts.type |
Paul Thomas | a944c79 | 2007-10-18 12:48:37 +0000 | [diff] [blame] | 6091 | && sym->attr.flavor == FL_PROCEDURE |
| 6092 | && sym->attr.contained) |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6093 | { |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6094 | /* Clear the shape, since it might not be valid. */ |
Mikael Morin | d54e80c | 2011-08-25 19:10:06 +0000 | [diff] [blame] | 6095 | gfc_free_shape (&e->shape, e->rank); |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6096 | |
Paul Thomas | 1aafbf9 | 2009-07-09 16:48:50 +0000 | [diff] [blame] | 6097 | /* Give the expression the right symtree! */ |
| 6098 | gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); |
| 6099 | gcc_assert (st != NULL); |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6100 | |
Paul Thomas | 1aafbf9 | 2009-07-09 16:48:50 +0000 | [diff] [blame] | 6101 | if (old_sym->attr.flavor == FL_PROCEDURE |
| 6102 | || e->expr_type == EXPR_FUNCTION) |
| 6103 | { |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6104 | /* Original was function so point to the new symbol, since |
| 6105 | the actual argument list is already attached to the |
Joost VandeVondele | 1cc0e19 | 2014-09-20 11:48:00 +0000 | [diff] [blame] | 6106 | expression. */ |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6107 | 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 Burnus | d8155bf | 2011-07-18 08:48:19 +0200 | [diff] [blame] | 6114 | since resolve_function will take care of it. */ |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6115 | e->value.function.actual = NULL; |
| 6116 | e->expr_type = EXPR_FUNCTION; |
| 6117 | e->symtree = st; |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6118 | |
Paul Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6119 | /* 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 Thomas | 359815a | 2020-08-10 06:19:25 +0100 | [diff] [blame] | 6125 | 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 Thomas | 5b3b1d0 | 2009-01-20 21:56:49 +0000 | [diff] [blame] | 6135 | 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 Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6159 | sym->refs++; |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6160 | } |
| 6161 | } |
Paul Thomas | 8de10a6 | 2007-06-25 18:27:59 +0000 | [diff] [blame] | 6162 | /* This might have changed! */ |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 6163 | return e->expr_type == EXPR_FUNCTION; |
| 6164 | } |
| 6165 | |
| 6166 | |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6167 | static void |
| 6168 | gfc_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. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 6175 | gcc_assert (e->value.op.op == INTRINSIC_CONCAT); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6176 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 6177 | if (op1->ts.u.cl && op1->ts.u.cl->length) |
| 6178 | e1 = gfc_copy_expr (op1->ts.u.cl->length); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6179 | else if (op1->expr_type == EXPR_CONSTANT) |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 6180 | e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 6181 | op1->value.character.length); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6182 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 6183 | if (op2->ts.u.cl && op2->ts.u.cl->length) |
| 6184 | e2 = gfc_copy_expr (op2->ts.u.cl->length); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6185 | else if (op2->expr_type == EXPR_CONSTANT) |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 6186 | e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 6187 | op2->value.character.length); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6188 | |
Janus Weil | b76e28c | 2009-08-17 11:11:00 +0200 | [diff] [blame] | 6189 | e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6190 | |
| 6191 | if (!e1 || !e2) |
Tobias Burnus | d7920cf | 2012-08-27 22:51:52 +0200 | [diff] [blame] | 6192 | { |
| 6193 | gfc_free_expr (e1); |
| 6194 | gfc_free_expr (e2); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 6195 | |
Tobias Burnus | d7920cf | 2012-08-27 22:51:52 +0200 | [diff] [blame] | 6196 | return; |
| 6197 | } |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6198 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 6199 | 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 Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6204 | |
| 6205 | return; |
| 6206 | } |
| 6207 | |
| 6208 | |
| 6209 | /* Ensure that an character expression has a charlen and, if possible, a |
| 6210 | length expression. */ |
| 6211 | |
| 6212 | static void |
| 6213 | fixup_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 Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 6222 | /* FALLTHRU */ |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6223 | |
| 6224 | case EXPR_ARRAY: |
| 6225 | if (e->expr_type == EXPR_ARRAY) |
| 6226 | gfc_resolve_character_array_constructor (e); |
Marek Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 6227 | /* FALLTHRU */ |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6228 | |
| 6229 | case EXPR_SUBSTRING: |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 6230 | if (!e->ts.u.cl && e->ref) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6231 | gfc_resolve_substring_charlen (e); |
Marek Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 6232 | /* FALLTHRU */ |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6233 | |
| 6234 | default: |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 6235 | if (!e->ts.u.cl) |
Janus Weil | b76e28c | 2009-08-17 11:11:00 +0200 | [diff] [blame] | 6236 | e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 6237 | |
| 6238 | break; |
| 6239 | } |
| 6240 | } |
| 6241 | |
| 6242 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6243 | /* Update an actual argument to include the passed-object for type-bound |
| 6244 | procedures at the right position. */ |
| 6245 | |
| 6246 | static gfc_actual_arglist* |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6247 | update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, |
| 6248 | const char *name) |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6249 | { |
Daniel Kraft | b82657f | 2008-10-05 08:39:37 +0200 | [diff] [blame] | 6250 | gcc_assert (argpos > 0); |
| 6251 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6252 | 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 Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6259 | if (name) |
| 6260 | result->name = name; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6261 | |
| 6262 | return result; |
| 6263 | } |
| 6264 | |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6265 | 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 Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6269 | return lst; |
| 6270 | } |
| 6271 | |
| 6272 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6273 | /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */ |
| 6274 | |
| 6275 | static gfc_expr* |
| 6276 | extract_compcall_passed_object (gfc_expr* e) |
| 6277 | { |
| 6278 | gfc_expr* po; |
| 6279 | |
Thomas Koenig | 7e703f0 | 2019-03-18 07:28:42 +0000 | [diff] [blame] | 6280 | 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6287 | gcc_assert (e->expr_type == EXPR_COMPCALL); |
| 6288 | |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 6289 | 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 Weil | 63894de | 2010-01-19 23:21:35 +0100 | [diff] [blame] | 6297 | po->where = e->where; |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 6298 | } |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6299 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6300 | if (!gfc_resolve_expr (po)) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6301 | return NULL; |
| 6302 | |
| 6303 | return po; |
| 6304 | } |
| 6305 | |
| 6306 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6307 | /* Update the arglist of an EXPR_COMPCALL expression to include the |
| 6308 | passed-object. */ |
| 6309 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6310 | static bool |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6311 | update_compcall_arglist (gfc_expr* e) |
| 6312 | { |
| 6313 | gfc_expr* po; |
| 6314 | gfc_typebound_proc* tbp; |
| 6315 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6316 | tbp = e->value.compcall.tbp; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6317 | |
Daniel Kraft | b82657f | 2008-10-05 08:39:37 +0200 | [diff] [blame] | 6318 | if (tbp->error) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6319 | return false; |
Daniel Kraft | b82657f | 2008-10-05 08:39:37 +0200 | [diff] [blame] | 6320 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6321 | po = extract_compcall_passed_object (e); |
| 6322 | if (!po) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6323 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6324 | |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 6325 | if (tbp->nopass || e->value.compcall.ignore_pass) |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6326 | { |
| 6327 | gfc_free_expr (po); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6328 | return true; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6329 | } |
| 6330 | |
Janus Weil | 859e309 | 2017-11-11 22:54:41 +0100 | [diff] [blame] | 6331 | if (tbp->pass_arg_num <= 0) |
| 6332 | return false; |
| 6333 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6334 | e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6335 | tbp->pass_arg_num, |
| 6336 | tbp->pass_arg); |
| 6337 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6338 | return true; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6339 | } |
| 6340 | |
| 6341 | |
| 6342 | /* Extract the passed object from a PPC call (a copy of it). */ |
| 6343 | |
| 6344 | static gfc_expr* |
| 6345 | extract_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 Weil | 63894de | 2010-01-19 23:21:35 +0100 | [diff] [blame] | 6354 | po->where = e->where; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6355 | |
| 6356 | /* Remove PPC reference. */ |
| 6357 | ref = &po->ref; |
| 6358 | while ((*ref)->next) |
Janus Weil | 63894de | 2010-01-19 23:21:35 +0100 | [diff] [blame] | 6359 | ref = &(*ref)->next; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6360 | gfc_free_ref_list (*ref); |
| 6361 | *ref = NULL; |
| 6362 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6363 | if (!gfc_resolve_expr (po)) |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6364 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6373 | static bool |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6374 | update_ppc_arglist (gfc_expr* e) |
| 6375 | { |
| 6376 | gfc_expr* po; |
| 6377 | gfc_component *ppc; |
| 6378 | gfc_typebound_proc* tb; |
| 6379 | |
Mikael Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 6380 | ppc = gfc_get_proc_ptr_comp (e); |
| 6381 | if (!ppc) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6382 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6383 | |
| 6384 | tb = ppc->tb; |
| 6385 | |
| 6386 | if (tb->error) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6387 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6388 | else if (tb->nopass) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6389 | return true; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6390 | |
| 6391 | po = extract_ppc_passed_object (e); |
| 6392 | if (!po) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6393 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6394 | |
Janus Weil | 8b29bd2 | 2010-11-28 21:22:29 +0100 | [diff] [blame] | 6395 | /* F08:R739. */ |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 6396 | if (po->rank != 0) |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6397 | { |
| 6398 | gfc_error ("Passed-object at %L must be scalar", &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6399 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6400 | } |
| 6401 | |
Janus Weil | 8b29bd2 | 2010-11-28 21:22:29 +0100 | [diff] [blame] | 6402 | /* 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 6406 | " ABSTRACT type %qs", &e->where, po->ts.u.derived->name); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6407 | return false; |
Janus Weil | 8b29bd2 | 2010-11-28 21:22:29 +0100 | [diff] [blame] | 6408 | } |
| 6409 | |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6410 | 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 Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6414 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6415 | return true; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6416 | } |
| 6417 | |
| 6418 | |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6419 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6422 | static bool |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6423 | check_typebound_baseobject (gfc_expr* e) |
| 6424 | { |
| 6425 | gfc_expr* base; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6426 | bool return_value = false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6427 | |
| 6428 | base = extract_compcall_passed_object (e); |
| 6429 | if (!base) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6430 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6431 | |
Thomas Koenig | 7e703f0 | 2019-03-18 07:28:42 +0000 | [diff] [blame] | 6432 | 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 Burnus | e56817d | 2009-09-30 22:45:07 +0200 | [diff] [blame] | 6437 | |
Janus Weil | 0b2d443 | 2012-08-16 00:11:03 +0200 | [diff] [blame] | 6438 | if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6439 | return false; |
Janus Weil | 0b2d443 | 2012-08-16 00:11:03 +0200 | [diff] [blame] | 6440 | |
Janus Weil | 8b29bd2 | 2010-11-28 21:22:29 +0100 | [diff] [blame] | 6441 | /* F08:C611. */ |
Tobias Burnus | e56817d | 2009-09-30 22:45:07 +0200 | [diff] [blame] | 6442 | if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6443 | { |
| 6444 | gfc_error ("Base object for type-bound procedure call at %L is of" |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 6445 | " ABSTRACT type %qs", &e->where, base->ts.u.derived->name); |
Mikael Morin | 99b41d5 | 2010-10-06 14:52:02 +0000 | [diff] [blame] | 6446 | goto cleanup; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6447 | } |
| 6448 | |
Janus Weil | 8b29bd2 | 2010-11-28 21:22:29 +0100 | [diff] [blame] | 6449 | /* F08:C1230. If the procedure called is NOPASS, |
| 6450 | the base object must be scalar. */ |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 6451 | if (e->value.compcall.tbp->nopass && base->rank != 0) |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 6452 | { |
| 6453 | gfc_error ("Base object for NOPASS type-bound procedure call at %L must" |
| 6454 | " be scalar", &e->where); |
Mikael Morin | 99b41d5 | 2010-10-06 14:52:02 +0000 | [diff] [blame] | 6455 | goto cleanup; |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 6456 | } |
| 6457 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6458 | return_value = true; |
Mikael Morin | 99b41d5 | 2010-10-06 14:52:02 +0000 | [diff] [blame] | 6459 | |
| 6460 | cleanup: |
| 6461 | gfc_free_expr (base); |
| 6462 | return return_value; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6463 | } |
| 6464 | |
| 6465 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6466 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6470 | static bool |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6471 | resolve_typebound_static (gfc_expr* e, gfc_symtree** target, |
| 6472 | gfc_actual_arglist** actual) |
| 6473 | { |
| 6474 | gcc_assert (e->expr_type == EXPR_COMPCALL); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6475 | gcc_assert (!e->value.compcall.tbp->is_generic); |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6476 | |
| 6477 | /* Update the actual arglist for PASS. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6478 | if (!update_compcall_arglist (e)) |
| 6479 | return false; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6480 | |
| 6481 | *actual = e->value.compcall.actual; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6482 | *target = e->value.compcall.tbp->u.specific; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6483 | |
| 6484 | gfc_free_ref_list (e->ref); |
| 6485 | e->ref = NULL; |
| 6486 | e->value.compcall.actual = NULL; |
| 6487 | |
Paul Thomas | 003e0ad | 2012-01-05 21:15:52 +0000 | [diff] [blame] | 6488 | /* If we find a deferred typebound procedure, check for derived types |
Tobias Burnus | e3a2ec5 | 2012-05-07 10:35:17 +0200 | [diff] [blame] | 6489 | 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 Thomas | 003e0ad | 2012-01-05 21:15:52 +0000 | [diff] [blame] | 6494 | { |
| 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 Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 6502 | /* If necessary, go through the inheritance chain. */ |
Paul Thomas | 003e0ad | 2012-01-05 21:15:52 +0000 | [diff] [blame] | 6503 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6520 | return true; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6521 | } |
| 6522 | |
| 6523 | |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6524 | /* Get the ultimate declared type from an expression. In addition, |
| 6525 | return the last class/derived type reference and the copy of the |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6526 | reference list. If check_types is set true, derived types are |
| 6527 | identified as well as class references. */ |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6528 | static gfc_symbol* |
| 6529 | get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6530 | gfc_expr *e, bool check_types) |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6531 | { |
| 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 Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6546 | if ((ref->u.c.component->ts.type == BT_CLASS |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6547 | || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6548 | && ref->u.c.component->attr.flavor != FL_PROCEDURE) |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6549 | { |
| 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6563 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6567 | static bool |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6568 | resolve_typebound_generic_call (gfc_expr* e, const char **name) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6569 | { |
| 6570 | gfc_typebound_proc* genproc; |
| 6571 | const char* genname; |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6572 | gfc_symtree *st; |
| 6573 | gfc_symbol *derived; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6574 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6580 | return true; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6581 | |
| 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 Kraft | b82657f | 2008-10-05 08:39:37 +0200 | [diff] [blame] | 6595 | |
| 6596 | if (g->specific->error) |
| 6597 | continue; |
| 6598 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6599 | 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 Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6608 | { |
| 6609 | gfc_free_actual_arglist (args); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6610 | return false; |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6611 | } |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6612 | |
Daniel Kraft | b82657f | 2008-10-05 08:39:37 +0200 | [diff] [blame] | 6613 | gcc_assert (g->specific->pass_arg_num > 0); |
| 6614 | gcc_assert (!g->specific->error); |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 6615 | args = update_arglist_pass (args, po, g->specific->pass_arg_num, |
| 6616 | g->specific->pass_arg); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6617 | } |
Daniel Kraft | f0ac18b | 2008-09-23 16:26:47 +0200 | [diff] [blame] | 6618 | resolve_actual_arglist (args, target->attr.proc, |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 6619 | is_external_proc (target) |
| 6620 | && gfc_sym_get_dummy_args (target) == NULL); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6621 | |
| 6622 | /* Check if this arglist matches the formal. */ |
Daniel Kraft | f0ac18b | 2008-09-23 16:26:47 +0200 | [diff] [blame] | 6623 | matches = gfc_arglist_matches_symbol (&args, target); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6624 | |
| 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 Weil | ab7306e | 2010-07-15 15:36:28 +0200 | [diff] [blame] | 6630 | genname = g->specific_st->name; |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6631 | /* Pass along the name for CLASS methods, where the vtab |
| 6632 | procedure pointer component has to be referenced. */ |
| 6633 | if (name) |
Janus Weil | ab7306e | 2010-07-15 15:36:28 +0200 | [diff] [blame] | 6634 | *name = genname; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6635 | 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 6642 | " %qs at %L", genname, &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6643 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6644 | |
| 6645 | success: |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6646 | /* Make sure that we have the right specific instance for the name. */ |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6647 | derived = get_declared_from_expr (NULL, NULL, e, true); |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6648 | |
Tobias Burnus | 12578be | 2011-04-29 18:49:53 +0200 | [diff] [blame] | 6649 | st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); |
Paul Thomas | 15d774f | 2010-06-06 02:04:04 +0000 | [diff] [blame] | 6650 | if (st) |
| 6651 | e->value.compcall.tbp = st->n.tb; |
| 6652 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6653 | return true; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6654 | } |
| 6655 | |
| 6656 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6657 | /* Resolve a call to a type-bound subroutine. */ |
| 6658 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6659 | static bool |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6660 | resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6661 | { |
| 6662 | gfc_actual_arglist* newactual; |
| 6663 | gfc_symtree* target; |
| 6664 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6665 | /* Check that's really a SUBROUTINE. */ |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 6666 | if (!c->expr1->value.compcall.tbp->subroutine) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6667 | { |
Paul Thomas | 6ab6c0c | 2018-08-23 06:27:54 +0000 | [diff] [blame] | 6668 | 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6679 | } |
| 6680 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6681 | if (!check_typebound_baseobject (c->expr1)) |
| 6682 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6683 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6684 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6689 | if (!resolve_typebound_generic_call (c->expr1, name)) |
| 6690 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6691 | |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6692 | /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */ |
| 6693 | if (overridable) |
| 6694 | *overridable = !c->expr1->value.compcall.tbp->non_overridable; |
| 6695 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6696 | /* Transform into an ordinary EXEC_CALL for now. */ |
| 6697 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6698 | if (!resolve_typebound_static (c->expr1, &target, &newactual)) |
| 6699 | return false; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6700 | |
| 6701 | c->ext.actual = newactual; |
| 6702 | c->symtree = target; |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 6703 | c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6704 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 6705 | gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6706 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 6707 | gfc_free_expr (c->expr1); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6708 | c->expr1 = gfc_get_expr (); |
| 6709 | c->expr1->expr_type = EXPR_FUNCTION; |
| 6710 | c->expr1->symtree = target; |
| 6711 | c->expr1->where = c->loc; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6712 | |
| 6713 | return resolve_call (c); |
| 6714 | } |
| 6715 | |
| 6716 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6717 | /* Resolve a component-call expression. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6718 | static bool |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6719 | resolve_compcall (gfc_expr* e, const char **name) |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6720 | { |
| 6721 | gfc_actual_arglist* newactual; |
| 6722 | gfc_symtree* target; |
| 6723 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6724 | /* Check that's really a FUNCTION. */ |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6725 | if (!e->value.compcall.tbp->function) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6726 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 6727 | gfc_error ("%qs at %L should be a FUNCTION", |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6728 | e->value.compcall.name, &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6729 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6730 | } |
| 6731 | |
Steven G. Kargl | 878f88b | 2019-08-10 18:26:13 +0000 | [diff] [blame] | 6732 | |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 6733 | /* These must not be assign-calls! */ |
| 6734 | gcc_assert (!e->value.compcall.assign); |
| 6735 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6736 | if (!check_typebound_baseobject (e)) |
| 6737 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 6738 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6739 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6744 | if (!resolve_typebound_generic_call (e, name)) |
| 6745 | return false; |
Daniel Kraft | 00ca664 | 2008-09-09 20:08:08 +0200 | [diff] [blame] | 6746 | 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6751 | |
| 6752 | /* For now, we simply transform it into an EXPR_FUNCTION call with the same |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6753 | arglist to the TBP's binding target. */ |
| 6754 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6755 | if (!resolve_typebound_static (e, &target, &newactual)) |
| 6756 | return false; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6757 | |
| 6758 | e->value.function.actual = newactual; |
Janus Weil | b3d286b | 2010-03-08 10:35:04 +0100 | [diff] [blame] | 6759 | e->value.function.name = NULL; |
Paul Thomas | 37a40b5 | 2009-07-05 19:13:59 +0000 | [diff] [blame] | 6760 | e->value.function.esym = target->n.sym; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 6761 | e->value.function.isym = NULL; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6762 | e->symtree = target; |
Daniel Kraft | f0ac18b | 2008-09-23 16:26:47 +0200 | [diff] [blame] | 6763 | e->ts = target->n.sym->ts; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 6764 | e->expr_type = EXPR_FUNCTION; |
| 6765 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6766 | /* 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 Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6770 | } |
| 6771 | |
| 6772 | |
Janus Weil | f005126 | 2013-07-25 23:41:22 +0200 | [diff] [blame] | 6773 | static bool resolve_fl_derived (gfc_symbol *sym); |
| 6774 | |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6775 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6776 | /* Resolve a typebound function, or 'method'. First separate all |
| 6777 | the non-CLASS references by calling resolve_compcall directly. */ |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6778 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6779 | static bool |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6780 | resolve_typebound_function (gfc_expr* e) |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6781 | { |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6782 | gfc_symbol *declared; |
| 6783 | gfc_component *c; |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6784 | gfc_ref *new_ref; |
| 6785 | gfc_ref *class_ref; |
| 6786 | gfc_symtree *st; |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6787 | const char *name; |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6788 | gfc_typespec ts; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6789 | gfc_expr *expr; |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6790 | bool overridable; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6791 | |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6792 | st = e->symtree; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6793 | |
| 6794 | /* Deal with typebound operators for CLASS objects. */ |
| 6795 | expr = e->value.compcall.base_object; |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6796 | overridable = !e->value.compcall.tbp->non_overridable; |
Janus Weil | 061e60b | 2010-10-07 19:35:18 +0200 | [diff] [blame] | 6797 | if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6798 | { |
| 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 Weil | 061e60b | 2010-10-07 19:35:18 +0200 | [diff] [blame] | 6802 | ts = expr->ts; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6803 | declared = ts.u.derived; |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6804 | c = gfc_find_component (declared, "_vptr", true, true, NULL); |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6805 | if (c->ts.u.derived == NULL) |
| 6806 | c->ts.u.derived = gfc_find_derived_vtab (declared); |
| 6807 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6808 | if (!resolve_compcall (e, &name)) |
| 6809 | return false; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6810 | |
| 6811 | /* Use the generic name if it is there. */ |
| 6812 | name = name ? name : e->value.function.esym->name; |
| 6813 | e->symtree = expr->symtree; |
Janus Weil | d373547 | 2010-10-10 23:35:10 +0200 | [diff] [blame] | 6814 | e->ref = gfc_copy_ref (expr->ref); |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6815 | get_declared_from_expr (&class_ref, NULL, e, false); |
| 6816 | |
| 6817 | /* Trim away the extraneous references that emerge from nested |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 6818 | use of interface.cc (extend_expr). */ |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6819 | if (class_ref && class_ref->next) |
| 6820 | { |
| 6821 | gfc_free_ref_list (class_ref->next); |
| 6822 | class_ref->next = NULL; |
| 6823 | } |
Andre Vehreschild | 8294f55 | 2016-11-20 15:21:43 +0100 | [diff] [blame] | 6824 | else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6825 | { |
| 6826 | gfc_free_ref_list (e->ref); |
| 6827 | e->ref = NULL; |
| 6828 | } |
| 6829 | |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 6830 | gfc_add_vptr_component (e); |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6831 | gfc_add_component_ref (e, name); |
| 6832 | e->value.function.esym = NULL; |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6833 | if (expr->expr_type != EXPR_VARIABLE) |
| 6834 | e->base_expr = expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6835 | return true; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6836 | } |
| 6837 | |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6838 | if (st == NULL) |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6839 | return resolve_compcall (e, NULL); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6840 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 6841 | if (!gfc_resolve_ref (e)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6842 | return false; |
Janus Weil | f1a0b75 | 2010-06-09 16:14:08 +0200 | [diff] [blame] | 6843 | |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6844 | /* Get the CLASS declared type. */ |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6845 | declared = get_declared_from_expr (&class_ref, &new_ref, e, true); |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 6846 | |
Janus Weil | f005126 | 2013-07-25 23:41:22 +0200 | [diff] [blame] | 6847 | if (!resolve_fl_derived (declared)) |
| 6848 | return false; |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6849 | |
| 6850 | /* Weed out cases of the ultimate component being a derived type. */ |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6851 | if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6852 | || (!class_ref && st->n.sym->ts.type != BT_CLASS)) |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6853 | { |
| 6854 | gfc_free_ref_list (new_ref); |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6855 | return resolve_compcall (e, NULL); |
Paul Thomas | f116b2f | 2009-10-20 04:16:02 +0000 | [diff] [blame] | 6856 | } |
| 6857 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6858 | c = gfc_find_component (declared, "_data", true, true, NULL); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6859 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6860 | /* Treat the call as if it is a typebound procedure, in order to roll |
| 6861 | out the correct name for the specific function. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6862 | if (!resolve_compcall (e, &name)) |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6863 | { |
| 6864 | gfc_free_ref_list (new_ref); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6865 | return false; |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6866 | } |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6867 | ts = e->ts; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 6868 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6869 | if (overridable) |
| 6870 | { |
| 6871 | /* Convert the expression to a procedure pointer component call. */ |
| 6872 | e->value.function.esym = NULL; |
| 6873 | e->symtree = st; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6874 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 6875 | if (new_ref) |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6876 | e->ref = new_ref; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6877 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6878 | /* '_vptr' points to the vtab, which contains the procedure pointers. */ |
| 6879 | gfc_add_vptr_component (e); |
| 6880 | gfc_add_component_ref (e, name); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6881 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6882 | /* 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 Burnus | 36abe89 | 2013-04-18 20:59:38 +0200 | [diff] [blame] | 6888 | else if (new_ref) |
| 6889 | gfc_free_ref_list (new_ref); |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6890 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6891 | return true; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6892 | } |
| 6893 | |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6894 | /* Resolve a typebound subroutine, or 'method'. First separate all |
| 6895 | the non-CLASS references by calling resolve_typebound_call |
| 6896 | directly. */ |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6897 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6898 | static bool |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6899 | resolve_typebound_subroutine (gfc_code *code) |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6900 | { |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6901 | gfc_symbol *declared; |
| 6902 | gfc_component *c; |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6903 | gfc_ref *new_ref; |
| 6904 | gfc_ref *class_ref; |
| 6905 | gfc_symtree *st; |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6906 | const char *name; |
| 6907 | gfc_typespec ts; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6908 | gfc_expr *expr; |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6909 | bool overridable; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6910 | |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6911 | st = code->expr1->symtree; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6912 | |
| 6913 | /* Deal with typebound operators for CLASS objects. */ |
| 6914 | expr = code->expr1->value.compcall.base_object; |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6915 | overridable = !code->expr1->value.compcall.tbp->non_overridable; |
Janus Weil | b6c77bc | 2011-01-31 19:11:32 +0100 | [diff] [blame] | 6916 | if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6917 | { |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6918 | /* 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 Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6932 | /* 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 Weil | b6c77bc | 2011-01-31 19:11:32 +0100 | [diff] [blame] | 6935 | declared = expr->ts.u.derived; |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6936 | c = gfc_find_component (declared, "_vptr", true, true, NULL); |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6937 | if (c->ts.u.derived == NULL) |
| 6938 | c->ts.u.derived = gfc_find_derived_vtab (declared); |
| 6939 | |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6940 | if (!resolve_typebound_call (code, &name, NULL)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6941 | return false; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6942 | |
| 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 Weil | b6c77bc | 2011-01-31 19:11:32 +0100 | [diff] [blame] | 6946 | code->expr1->ref = gfc_copy_ref (expr->ref); |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6947 | |
| 6948 | /* Trim away the extraneous references that emerge from nested |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 6949 | use of interface.cc (extend_expr). */ |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6950 | 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 Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 6963 | gfc_add_vptr_component (code->expr1); |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6964 | gfc_add_component_ref (code->expr1, name); |
| 6965 | code->expr1->value.function.esym = NULL; |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6966 | if (expr->expr_type != EXPR_VARIABLE) |
| 6967 | code->expr1->base_expr = expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6968 | return true; |
Paul Thomas | 974df0f | 2010-07-19 18:48:44 +0000 | [diff] [blame] | 6969 | } |
| 6970 | |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 6971 | if (st == NULL) |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6972 | return resolve_typebound_call (code, NULL, NULL); |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 6973 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 6974 | if (!gfc_resolve_ref (code->expr1)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6975 | return false; |
Janus Weil | f1a0b75 | 2010-06-09 16:14:08 +0200 | [diff] [blame] | 6976 | |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6977 | /* Get the CLASS declared type. */ |
Paul Thomas | 94fae14 | 2012-01-02 12:46:08 +0000 | [diff] [blame] | 6978 | get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6979 | |
| 6980 | /* Weed out cases of the ultimate component being a derived type. */ |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 6981 | if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6982 | || (!class_ref && st->n.sym->ts.type != BT_CLASS)) |
Paul Thomas | 2818874 | 2009-10-16 06:07:09 +0000 | [diff] [blame] | 6983 | { |
| 6984 | gfc_free_ref_list (new_ref); |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6985 | return resolve_typebound_call (code, NULL, NULL); |
Janus Weil | ab7306e | 2010-07-15 15:36:28 +0200 | [diff] [blame] | 6986 | } |
Paul Thomas | f116b2f | 2009-10-20 04:16:02 +0000 | [diff] [blame] | 6987 | |
Janus Weil | 744868a | 2014-12-16 09:15:38 +0100 | [diff] [blame] | 6988 | if (!resolve_typebound_call (code, &name, &overridable)) |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6989 | { |
| 6990 | gfc_free_ref_list (new_ref); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 6991 | return false; |
Tobias Burnus | efb6336 | 2012-10-04 19:32:06 +0200 | [diff] [blame] | 6992 | } |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 6993 | ts = code->expr1->ts; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 6994 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 6995 | 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 Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 7000 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 7001 | if (new_ref) |
| 7002 | code->expr1->ref = new_ref; |
Paul Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 7003 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 7004 | /* '_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 Thomas | 7cf078d | 2009-10-05 18:19:55 +0000 | [diff] [blame] | 7007 | |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 7008 | /* 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 Burnus | adede54 | 2013-04-15 11:40:28 +0200 | [diff] [blame] | 7014 | else if (new_ref) |
| 7015 | gfc_free_ref_list (new_ref); |
Janus Weil | fd83db3 | 2011-11-07 19:41:12 +0100 | [diff] [blame] | 7016 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7017 | return true; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 7018 | } |
| 7019 | |
| 7020 | |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7021 | /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ |
| 7022 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7023 | static bool |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7024 | resolve_ppc_call (gfc_code* c) |
| 7025 | { |
| 7026 | gfc_component *comp; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7027 | |
Mikael Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 7028 | comp = gfc_get_proc_ptr_comp (c->expr1); |
| 7029 | gcc_assert (comp != NULL); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7030 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 7031 | c->resolved_sym = c->expr1->symtree->n.sym; |
| 7032 | c->expr1->expr_type = EXPR_VARIABLE; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7033 | |
| 7034 | if (!comp->attr.subroutine) |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 7035 | gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7036 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7037 | if (!gfc_resolve_ref (c->expr1)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7038 | return false; |
Janus Weil | e35bbb2 | 2009-05-18 16:44:55 +0200 | [diff] [blame] | 7039 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7040 | if (!update_ppc_arglist (c->expr1)) |
| 7041 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 7042 | |
| 7043 | c->ext.actual = c->expr1->value.compcall.actual; |
| 7044 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7045 | if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, |
| 7046 | !(comp->ts.interface |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7047 | && comp->ts.interface->formal))) |
| 7048 | return false; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7049 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 7050 | if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) |
| 7051 | return false; |
| 7052 | |
Janus Weil | 7e196f8 | 2009-06-24 12:59:56 +0200 | [diff] [blame] | 7053 | gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7054 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7055 | return true; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7056 | } |
| 7057 | |
| 7058 | |
| 7059 | /* Resolve a Function Call to a Procedure Pointer Component (Function). */ |
| 7060 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7061 | static bool |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7062 | resolve_expr_ppc (gfc_expr* e) |
| 7063 | { |
| 7064 | gfc_component *comp; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7065 | |
Mikael Morin | 2a57357 | 2012-08-14 16:28:29 +0000 | [diff] [blame] | 7066 | comp = gfc_get_proc_ptr_comp (e); |
| 7067 | gcc_assert (comp != NULL); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7068 | |
| 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 Weil | c74b74a | 2009-05-25 16:48:24 +0200 | [diff] [blame] | 7074 | if (comp->as != NULL) |
| 7075 | e->rank = comp->as->rank; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7076 | |
| 7077 | if (!comp->attr.function) |
| 7078 | gfc_add_function (&comp->attr, comp->name, &e->where); |
| 7079 | |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7080 | if (!gfc_resolve_ref (e)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7081 | return false; |
Janus Weil | e35bbb2 | 2009-05-18 16:44:55 +0200 | [diff] [blame] | 7082 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7083 | if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, |
| 7084 | !(comp->ts.interface |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7085 | && comp->ts.interface->formal))) |
| 7086 | return false; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7087 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7088 | if (!update_ppc_arglist (e)) |
| 7089 | return false; |
Janus Weil | 90661f2 | 2009-07-25 13:56:35 +0200 | [diff] [blame] | 7090 | |
Janus Weil | 5930876 | 2014-12-14 13:04:49 +0100 | [diff] [blame] | 7091 | if (!check_pure_function(e)) |
| 7092 | return false; |
| 7093 | |
Janus Weil | 7e196f8 | 2009-06-24 12:59:56 +0200 | [diff] [blame] | 7094 | gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7095 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7096 | return true; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7097 | } |
| 7098 | |
| 7099 | |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7100 | static bool |
| 7101 | gfc_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 DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 7110 | con = gfc_constructor_first (e->value.constructor); |
| 7111 | for (; con; con = gfc_constructor_next (con)) |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7112 | { |
| 7113 | if (con->expr->expr_type == EXPR_VARIABLE |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 7114 | && con->expr->symtree |
| 7115 | && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7116 | || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) |
| 7117 | return true; |
| 7118 | if (con->expr->expr_type == EXPR_ARRAY |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 7119 | && gfc_is_expandable_expr (con->expr)) |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7120 | return true; |
| 7121 | } |
| 7122 | } |
| 7123 | |
| 7124 | return false; |
| 7125 | } |
| 7126 | |
Paul Thomas | dea71ad | 2017-02-19 18:27:14 +0000 | [diff] [blame] | 7127 | |
| 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 | |
| 7133 | static void |
| 7134 | fixup_unique_dummy (gfc_expr *e) |
| 7135 | { |
| 7136 | gfc_symtree *st = NULL; |
| 7137 | gfc_symbol *s = NULL; |
| 7138 | |
Harald Anlauf | c1a2cf8 | 2021-01-14 19:17:05 +0100 | [diff] [blame] | 7139 | if (e->symtree->n.sym->ns->proc_name |
Paul Thomas | dea71ad | 2017-02-19 18:27:14 +0000 | [diff] [blame] | 7140 | && 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7152 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7156 | bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7157 | gfc_resolve_expr (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7158 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7159 | bool t; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 7160 | bool inquiry_save, actual_arg_save, first_actual_arg_save; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7161 | |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 7162 | if (e == NULL || e->do_not_resolve_again) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7163 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7164 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7165 | /* inquiry_argument only applies to variables. */ |
| 7166 | inquiry_save = inquiry_argument; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 7167 | actual_arg_save = actual_arg; |
| 7168 | first_actual_arg_save = first_actual_arg; |
| 7169 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7170 | if (e->expr_type != EXPR_VARIABLE) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 7171 | { |
| 7172 | inquiry_argument = false; |
| 7173 | actual_arg = false; |
| 7174 | first_actual_arg = false; |
| 7175 | } |
Paul Thomas | dea71ad | 2017-02-19 18:27:14 +0000 | [diff] [blame] | 7176 | else if (e->symtree != NULL |
Harald Anlauf | c1a2cf8 | 2021-01-14 19:17:05 +0100 | [diff] [blame] | 7177 | && *e->symtree->name == '@' |
| 7178 | && e->symtree->n.sym->attr.dummy) |
Paul Thomas | dea71ad | 2017-02-19 18:27:14 +0000 | [diff] [blame] | 7179 | { |
| 7180 | /* Deal with submodule specification expressions that are not |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 7181 | found to be referenced in module.cc(read_cleanup). */ |
Paul Thomas | dea71ad | 2017-02-19 18:27:14 +0000 | [diff] [blame] | 7182 | fixup_unique_dummy (e); |
| 7183 | } |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7184 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7185 | switch (e->expr_type) |
| 7186 | { |
| 7187 | case EXPR_OP: |
| 7188 | t = resolve_operator (e); |
| 7189 | break; |
| 7190 | |
| 7191 | case EXPR_FUNCTION: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7192 | case EXPR_VARIABLE: |
Paul Thomas | eb77cdd | 2007-05-12 06:19:43 +0000 | [diff] [blame] | 7193 | |
| 7194 | if (check_host_association (e)) |
| 7195 | t = resolve_function (e); |
| 7196 | else |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 7197 | t = resolve_variable (e); |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 7198 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 7199 | if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 7200 | && e->ref->type != REF_SUBSTRING) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 7201 | gfc_resolve_substring_charlen (e); |
| 7202 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7203 | break; |
| 7204 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 7205 | case EXPR_COMPCALL: |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 7206 | t = resolve_typebound_function (e); |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 7207 | break; |
| 7208 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7209 | case EXPR_SUBSTRING: |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7210 | t = gfc_resolve_ref (e); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7211 | break; |
| 7212 | |
| 7213 | case EXPR_CONSTANT: |
| 7214 | case EXPR_NULL: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7215 | t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7216 | break; |
| 7217 | |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 7218 | case EXPR_PPC: |
| 7219 | t = resolve_expr_ppc (e); |
| 7220 | break; |
| 7221 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7222 | case EXPR_ARRAY: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7223 | t = false; |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7224 | if (!gfc_resolve_ref (e)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7225 | break; |
| 7226 | |
| 7227 | t = gfc_resolve_array_constructor (e); |
| 7228 | /* Also try to expand a constructor. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7229 | if (t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7230 | { |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7231 | gfc_expression_rank (e); |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7232 | if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) |
Tobias Burnus | 928f049 | 2010-07-06 22:56:07 +0200 | [diff] [blame] | 7233 | gfc_expand_constructor (e, false); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7234 | } |
| 7235 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7236 | /* This provides the opportunity for the length of constructors with |
Kazu Hirata | 86bf520 | 2007-07-07 13:15:40 +0000 | [diff] [blame] | 7237 | character valued function elements to propagate the string length |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7238 | to the expression. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7239 | if (t && e->ts.type == BT_CHARACTER) |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7240 | { |
| 7241 | /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 7242 | here rather then add a duplicate test for it above. */ |
Tobias Burnus | 928f049 | 2010-07-06 22:56:07 +0200 | [diff] [blame] | 7243 | gfc_expand_constructor (e, false); |
Jerry DeLisle | f2ff577 | 2010-01-09 17:47:04 +0000 | [diff] [blame] | 7244 | t = gfc_resolve_character_array_constructor (e); |
| 7245 | } |
Paul Thomas | 1855915 | 2006-07-04 20:15:52 +0000 | [diff] [blame] | 7246 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7247 | break; |
| 7248 | |
| 7249 | case EXPR_STRUCTURE: |
Tobias Burnus | de89b57 | 2019-12-20 11:35:20 +0000 | [diff] [blame] | 7250 | t = gfc_resolve_ref (e); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7251 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7252 | break; |
| 7253 | |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 7254 | t = resolve_structure_cons (e, 0); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7255 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7256 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7265 | if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) |
Paul Thomas | 07368af | 2007-08-30 22:10:55 +0000 | [diff] [blame] | 7266 | fixup_charlen (e); |
| 7267 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7268 | inquiry_argument = inquiry_save; |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 7269 | actual_arg = actual_arg_save; |
| 7270 | first_actual_arg = first_actual_arg_save; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7271 | |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 7272 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7279 | return t; |
| 7280 | } |
| 7281 | |
| 7282 | |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7283 | /* Resolve an expression from an iterator. They must be scalar and have |
| 7284 | INTEGER or (optionally) REAL type. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7285 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7286 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7287 | gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, |
| 7288 | const char *name_msgid) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7289 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7290 | if (!gfc_resolve_expr (expr)) |
| 7291 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7292 | |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7293 | if (expr->rank != 0) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7294 | { |
Francois-Xavier Coudert | 31043f6 | 2005-09-17 20:58:01 +0200 | [diff] [blame] | 7295 | gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7296 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7297 | } |
| 7298 | |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7299 | if (expr->ts.type != BT_INTEGER) |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7300 | { |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7301 | if (expr->ts.type == BT_REAL) |
| 7302 | { |
| 7303 | if (real_ok) |
| 7304 | return gfc_notify_std (GFC_STD_F95_DEL, |
Janus Weil | 9717f7a | 2012-07-17 23:51:20 +0200 | [diff] [blame] | 7305 | "%s at %L must be integer", |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7306 | _(name_msgid), &expr->where); |
| 7307 | else |
| 7308 | { |
| 7309 | gfc_error ("%s at %L must be INTEGER", _(name_msgid), |
| 7310 | &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7311 | return false; |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7312 | } |
| 7313 | } |
Francois-Xavier Coudert | 31043f6 | 2005-09-17 20:58:01 +0200 | [diff] [blame] | 7314 | else |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7315 | { |
| 7316 | gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7317 | return false; |
Jerry DeLisle | 79e7840 | 2007-06-22 01:50:09 +0000 | [diff] [blame] | 7318 | } |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7319 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7320 | return true; |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7321 | } |
| 7322 | |
| 7323 | |
| 7324 | /* Resolve the expressions in an iterator structure. If REAL_OK is |
Tobias Burnus | 57bf28ea | 2012-10-28 17:57:12 +0100 | [diff] [blame] | 7325 | 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. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7328 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7329 | bool |
Tobias Burnus | 57bf28ea | 2012-10-28 17:57:12 +0100 | [diff] [blame] | 7330 | gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7331 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7332 | if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) |
| 7333 | return false; |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7334 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7335 | if (!gfc_check_vardef_context (iter->var, false, false, own_scope, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7336 | _("iterator variable"))) |
| 7337 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7338 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7339 | if (!gfc_resolve_iterator_expr (iter->start, real_ok, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7340 | "Start expression in DO loop")) |
| 7341 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7342 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7343 | if (!gfc_resolve_iterator_expr (iter->end, real_ok, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7344 | "End expression in DO loop")) |
| 7345 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7346 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7347 | if (!gfc_resolve_iterator_expr (iter->step, real_ok, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7348 | "Step expression in DO loop")) |
| 7349 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7350 | |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7351 | /* 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. Kargl | c851722 | 2016-07-28 19:04:12 +0000 | [diff] [blame] | 7354 | gfc_convert_type (iter->start, &iter->var->ts, 1); |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7355 | |
| 7356 | if (iter->end->ts.kind != iter->var->ts.kind |
| 7357 | || iter->end->ts.type != iter->var->ts.type) |
Steven G. Kargl | c851722 | 2016-07-28 19:04:12 +0000 | [diff] [blame] | 7358 | gfc_convert_type (iter->end, &iter->var->ts, 1); |
Steven G. Kargl | 8d5cfa2 | 2004-12-12 20:27:02 +0000 | [diff] [blame] | 7359 | |
| 7360 | if (iter->step->ts.kind != iter->var->ts.kind |
| 7361 | || iter->step->ts.type != iter->var->ts.type) |
Steven G. Kargl | c851722 | 2016-07-28 19:04:12 +0000 | [diff] [blame] | 7362 | gfc_convert_type (iter->step, &iter->var->ts, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7363 | |
Thomas Koenig | 3e0679c | 2019-09-15 14:57:48 +0000 | [diff] [blame] | 7364 | 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 Burnus | dc18696 | 2009-03-28 14:06:30 +0100 | [diff] [blame] | 7377 | 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 Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 7392 | if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 7393 | gfc_warning (OPT_Wzerotrip, |
| 7394 | "DO loop at %L will be executed zero times", |
Tobias Burnus | dc18696 | 2009-03-28 14:06:30 +0100 | [diff] [blame] | 7395 | &iter->step->where); |
| 7396 | } |
| 7397 | |
Martin Liska | 1c12209 | 2016-07-07 15:15:39 +0200 | [diff] [blame] | 7398 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7421 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7422 | } |
| 7423 | |
| 7424 | |
Paul Thomas | 640670c | 2007-10-29 14:13:44 +0000 | [diff] [blame] | 7425 | /* Traversal function for find_forall_index. f == 2 signals that |
| 7426 | that variable itself is not to be checked - only the references. */ |
| 7427 | |
| 7428 | static bool |
| 7429 | forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) |
| 7430 | { |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 7431 | if (expr->expr_type != EXPR_VARIABLE) |
| 7432 | return false; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 7433 | |
Paul Thomas | 640670c | 2007-10-29 14:13:44 +0000 | [diff] [blame] | 7434 | /* 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üter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7449 | /* Check whether the FORALL index appears in the expression or not. |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7450 | Returns true if SYM is found in EXPR. */ |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7451 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7452 | bool |
Paul Thomas | 640670c | 2007-10-29 14:13:44 +0000 | [diff] [blame] | 7453 | find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7454 | { |
Paul Thomas | 640670c | 2007-10-29 14:13:44 +0000 | [diff] [blame] | 7455 | if (gfc_traverse_expr (expr, sym, forall_index, f)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7456 | return true; |
Paul Thomas | 640670c | 2007-10-29 14:13:44 +0000 | [diff] [blame] | 7457 | else |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7458 | return false; |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7459 | } |
| 7460 | |
| 7461 | |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7462 | /* 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üter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7464 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7468 | |
| 7469 | static void |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7470 | resolve_forall_iterators (gfc_forall_iterator *it) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7471 | { |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7472 | gfc_forall_iterator *iter, *iter2; |
| 7473 | |
| 7474 | for (iter = it; iter; iter = iter->next) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7475 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7476 | if (gfc_resolve_expr (iter->var) |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7477 | && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) |
| 7478 | gfc_error ("FORALL index-name at %L must be a scalar INTEGER", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7479 | &iter->var->where); |
| 7480 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7481 | if (gfc_resolve_expr (iter->start) |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7482 | && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) |
| 7483 | gfc_error ("FORALL start expression at %L must be a scalar INTEGER", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7484 | &iter->start->where); |
| 7485 | if (iter->var->ts.kind != iter->start->ts.kind) |
Francois-Xavier Coudert | 7298eef | 2011-11-09 09:51:49 +0000 | [diff] [blame] | 7486 | gfc_convert_type (iter->start, &iter->var->ts, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7487 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7488 | if (gfc_resolve_expr (iter->end) |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7489 | && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) |
| 7490 | gfc_error ("FORALL end expression at %L must be a scalar INTEGER", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7491 | &iter->end->where); |
| 7492 | if (iter->var->ts.kind != iter->end->ts.kind) |
Francois-Xavier Coudert | 7298eef | 2011-11-09 09:51:49 +0000 | [diff] [blame] | 7493 | gfc_convert_type (iter->end, &iter->var->ts, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7494 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7495 | if (gfc_resolve_expr (iter->stride)) |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7496 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7499 | &iter->stride->where, "INTEGER"); |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7500 | |
| 7501 | if (iter->stride->expr_type == EXPR_CONSTANT |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7502 | && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) |
Steven G. Kargl | 1c54741 | 2006-01-03 22:01:10 +0000 | [diff] [blame] | 7503 | gfc_error ("FORALL stride expression at %L cannot be zero", |
| 7504 | &iter->stride->where); |
| 7505 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7506 | if (iter->var->ts.kind != iter->stride->ts.kind) |
Francois-Xavier Coudert | 7298eef | 2011-11-09 09:51:49 +0000 | [diff] [blame] | 7507 | gfc_convert_type (iter->stride, &iter->var->ts, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7508 | } |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7509 | |
| 7510 | for (iter = it; iter; iter = iter->next) |
| 7511 | for (iter2 = iter; iter2; iter2 = iter2->next) |
| 7512 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7513 | 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 7516 | gfc_error ("FORALL index %qs may not appear in triplet " |
Tobias Schlüter | ac5ba37 | 2007-10-06 10:55:30 +0200 | [diff] [blame] | 7517 | "specification at %L", iter->var->symtree->name, |
| 7518 | &iter2->start->where); |
| 7519 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7520 | } |
| 7521 | |
| 7522 | |
Erik Edelmann | 8451584 | 2005-09-23 00:52:09 +0300 | [diff] [blame] | 7523 | /* 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 | |
| 7528 | static int |
| 7529 | derived_inaccessible (gfc_symbol *sym) |
| 7530 | { |
| 7531 | gfc_component *c; |
| 7532 | |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 7533 | if (sym->attr.use_assoc && sym->attr.private_comp) |
Erik Edelmann | 8451584 | 2005-09-23 00:52:09 +0300 | [diff] [blame] | 7534 | return 1; |
| 7535 | |
| 7536 | for (c = sym->components; c; c = c->next) |
| 7537 | { |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 7538 | /* 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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 7543 | if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7544 | return 1; |
Erik Edelmann | 8451584 | 2005-09-23 00:52:09 +0300 | [diff] [blame] | 7545 | } |
| 7546 | |
| 7547 | return 0; |
| 7548 | } |
| 7549 | |
| 7550 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7551 | /* Resolve the argument of a deallocate expression. The expression must be |
| 7552 | a pointer or a full array. */ |
| 7553 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7554 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7555 | resolve_deallocate_expr (gfc_expr *e) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7556 | { |
| 7557 | symbol_attribute attr; |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 7558 | int allocatable, pointer; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7559 | gfc_ref *ref; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7560 | gfc_symbol *sym; |
| 7561 | gfc_component *c; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7562 | bool unlimited; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7563 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7564 | if (!gfc_resolve_expr (e)) |
| 7565 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7566 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7567 | if (e->expr_type != EXPR_VARIABLE) |
| 7568 | goto bad; |
| 7569 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7570 | sym = e->symtree->n.sym; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7571 | unlimited = UNLIMITED_POLY(sym); |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7572 | |
| 7573 | if (sym->ts.type == BT_CLASS) |
| 7574 | { |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7575 | allocatable = CLASS_DATA (sym)->attr.allocatable; |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 7576 | pointer = CLASS_DATA (sym)->attr.class_pointer; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7577 | } |
| 7578 | else |
| 7579 | { |
| 7580 | allocatable = sym->attr.allocatable; |
| 7581 | pointer = sym->attr.pointer; |
| 7582 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7583 | for (ref = e->ref; ref; ref = ref->next) |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7584 | { |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7585 | switch (ref->type) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7586 | { |
| 7587 | case REF_ARRAY: |
Tobias Burnus | badd9e6 | 2011-07-16 19:31:13 +0200 | [diff] [blame] | 7588 | 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 Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7591 | allocatable = 0; |
| 7592 | break; |
| 7593 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7594 | case REF_COMPONENT: |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7595 | c = ref->u.c.component; |
| 7596 | if (c->ts.type == BT_CLASS) |
| 7597 | { |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7598 | allocatable = CLASS_DATA (c)->attr.allocatable; |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 7599 | pointer = CLASS_DATA (c)->attr.class_pointer; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7600 | } |
| 7601 | else |
| 7602 | { |
| 7603 | allocatable = c->attr.allocatable; |
| 7604 | pointer = c->attr.pointer; |
| 7605 | } |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7606 | break; |
| 7607 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7608 | case REF_SUBSTRING: |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 7609 | case REF_INQUIRY: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7610 | allocatable = 0; |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7611 | break; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7612 | } |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7613 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7614 | |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7615 | attr = gfc_expr_attr (e); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7616 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7617 | if (allocatable == 0 && attr.pointer == 0 && !unlimited) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7618 | { |
| 7619 | bad: |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 7620 | gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", |
| 7621 | &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7622 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7623 | } |
| 7624 | |
Tobias Burnus | 5aacb11 | 2011-05-27 23:29:19 +0200 | [diff] [blame] | 7625 | /* F2008, C644. */ |
| 7626 | if (gfc_is_coindexed (e)) |
| 7627 | { |
| 7628 | gfc_error ("Coindexed allocatable object at %L", &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7629 | return false; |
Tobias Burnus | 5aacb11 | 2011-05-27 23:29:19 +0200 | [diff] [blame] | 7630 | } |
| 7631 | |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 7632 | if (pointer |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7633 | && !gfc_check_vardef_context (e, true, true, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7634 | _("DEALLOCATE object"))) |
| 7635 | return false; |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 7636 | if (!gfc_check_vardef_context (e, false, true, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7637 | _("DEALLOCATE object"))) |
| 7638 | return false; |
Erik Edelmann | aa08038 | 2006-03-05 19:24:48 +0000 | [diff] [blame] | 7639 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7640 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7641 | } |
| 7642 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7643 | |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 7644 | /* Returns true if the expression e contains a reference to the symbol sym. */ |
| 7645 | static bool |
| 7646 | sym_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 Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 7654 | bool |
| 7655 | gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 7656 | { |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 7657 | return gfc_traverse_expr (e, sym, sym_in_expr, 0); |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 7658 | } |
| 7659 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7660 | |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7661 | /* 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 Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 7663 | derived types with default initializers, and derived types with allocatable |
| 7664 | components that need nullification.) */ |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7665 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7666 | gfc_expr * |
| 7667 | gfc_expr_to_initialize (gfc_expr *e) |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7668 | { |
| 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 Thomas | 56b070e | 2019-09-29 10:12:42 +0000 | [diff] [blame] | 7679 | if (ref->u.ar.dimen == 0 |
| 7680 | && ref->u.ar.as && ref->u.ar.as->corank) |
| 7681 | return result; |
| 7682 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7683 | ref->u.ar.type = AR_FULL; |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7684 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7685 | 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 Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7687 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7688 | break; |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7689 | } |
| 7690 | |
Mikael Morin | 7d7212e | 2011-08-22 14:07:30 +0000 | [diff] [blame] | 7691 | gfc_free_shape (&result->shape, result->rank); |
| 7692 | |
| 7693 | /* Recalculate rank, shape, etc. */ |
| 7694 | gfc_resolve_expr (result); |
Erik Edelmann | 68577e5 | 2005-10-20 01:18:07 +0300 | [diff] [blame] | 7695 | return result; |
| 7696 | } |
| 7697 | |
| 7698 | |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 7699 | /* 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 | |
| 7705 | static gfc_expr* |
| 7706 | remove_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 Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7724 | /* Used in resolve_allocate_expr to check that a allocation-object and |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 7725 | a source-expr are conformable. This does not catch all possible |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7726 | cases; in particular a runtime checking is needed. */ |
| 7727 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7728 | static bool |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7729 | conformable_arrays (gfc_expr *e1, gfc_expr *e2) |
| 7730 | { |
Janus Weil | 66051b6 | 2010-06-11 03:42:38 +0200 | [diff] [blame] | 7731 | gfc_ref *tail; |
| 7732 | for (tail = e2->ref; tail && tail->next; tail = tail->next); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 7733 | |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7734 | /* First compare rank. */ |
Steven G. Kargl | e6e3aa0 | 2019-09-15 17:49:44 +0000 | [diff] [blame] | 7735 | if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) |
Janus Weil | 2ccd6f7 | 2013-12-11 15:02:44 +0100 | [diff] [blame] | 7736 | || (!tail && e1->rank != e2->rank)) |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7737 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7741 | return false; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7742 | } |
| 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 Burnus | f0470cc | 2013-05-05 16:04:07 +0200 | [diff] [blame] | 7753 | if (tail->u.ar.start[i] == NULL) |
| 7754 | break; |
| 7755 | |
Janus Weil | 66051b6 | 2010-06-11 03:42:38 +0200 | [diff] [blame] | 7756 | if (tail->u.ar.end[i]) |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7757 | { |
Janus Weil | 66051b6 | 2010-06-11 03:42:38 +0200 | [diff] [blame] | 7758 | mpz_set (s, tail->u.ar.end[i]->value.integer); |
| 7759 | mpz_sub (s, s, tail->u.ar.start[i]->value.integer); |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7760 | mpz_add_ui (s, s, 1); |
| 7761 | } |
| 7762 | else |
| 7763 | { |
Janus Weil | 66051b6 | 2010-06-11 03:42:38 +0200 | [diff] [blame] | 7764 | mpz_set (s, tail->u.ar.start[i]->value.integer); |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7765 | } |
| 7766 | |
| 7767 | if (mpz_cmp (e1->shape[i], s) != 0) |
| 7768 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 7769 | gfc_error ("Source-expr at %L and allocate-object at %L must " |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7770 | "have the same shape", &e1->where, &e2->where); |
| 7771 | mpz_clear (s); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7772 | return false; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7773 | } |
| 7774 | } |
| 7775 | |
| 7776 | mpz_clear (s); |
| 7777 | } |
| 7778 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7779 | return true; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7780 | } |
| 7781 | |
| 7782 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7783 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7787 | static bool |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 7788 | resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7789 | { |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 7790 | int i, pointer, allocatable, dimension, is_abstract; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7791 | int codimension; |
Tobias Burnus | c49eaa2 | 2011-04-23 12:26:38 +0200 | [diff] [blame] | 7792 | bool coindexed; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7793 | bool unlimited; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7794 | symbol_attribute attr; |
| 7795 | gfc_ref *ref, *ref2; |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 7796 | gfc_expr *e2; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7797 | gfc_array_ref *ar; |
Kai Tietz | 0d7d495 | 2010-06-09 11:39:33 +0000 | [diff] [blame] | 7798 | gfc_symbol *sym = NULL; |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 7799 | gfc_alloc *a; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7800 | gfc_component *c; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7801 | bool t; |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7802 | |
Tobias Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 7803 | /* Mark the utmost array component as being in allocate to allow DIMEN_STAR |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7804 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 7812 | if (!gfc_resolve_expr (e)) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7813 | goto failure; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7814 | |
| 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7819 | if (e->symtree) |
| 7820 | sym = e->symtree->n.sym; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7821 | |
Tobias Burnus | d0a9804 | 2009-10-09 22:34:35 +0200 | [diff] [blame] | 7822 | /* Check whether ultimate component is abstract and CLASS. */ |
| 7823 | is_abstract = 0; |
| 7824 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7825 | /* Is the allocate-object unlimited polymorphic? */ |
| 7826 | unlimited = UNLIMITED_POLY(e); |
| 7827 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7828 | if (e->expr_type != EXPR_VARIABLE) |
| 7829 | { |
| 7830 | allocatable = 0; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7831 | attr = gfc_expr_attr (e); |
| 7832 | pointer = attr.pointer; |
| 7833 | dimension = attr.dimension; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7834 | codimension = attr.codimension; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7835 | } |
| 7836 | else |
| 7837 | { |
Paul Thomas | c49ea23 | 2011-12-11 20:42:23 +0000 | [diff] [blame] | 7838 | if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7839 | { |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7840 | allocatable = CLASS_DATA (sym)->attr.allocatable; |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 7841 | pointer = CLASS_DATA (sym)->attr.class_pointer; |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7842 | dimension = CLASS_DATA (sym)->attr.dimension; |
| 7843 | codimension = CLASS_DATA (sym)->attr.codimension; |
| 7844 | is_abstract = CLASS_DATA (sym)->attr.abstract; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7845 | } |
| 7846 | else |
| 7847 | { |
| 7848 | allocatable = sym->attr.allocatable; |
| 7849 | pointer = sym->attr.pointer; |
| 7850 | dimension = sym->attr.dimension; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7851 | codimension = sym->attr.codimension; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7852 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7853 | |
Tobias Burnus | c49eaa2 | 2011-04-23 12:26:38 +0200 | [diff] [blame] | 7854 | coindexed = false; |
| 7855 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7856 | for (ref = e->ref; ref; ref2 = ref, ref = ref->next) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7857 | { |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7858 | switch (ref->type) |
| 7859 | { |
| 7860 | case REF_ARRAY: |
Tobias Burnus | c49eaa2 | 2011-04-23 12:26:38 +0200 | [diff] [blame] | 7861 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7873 | if (ref->next != NULL) |
| 7874 | pointer = 0; |
| 7875 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7876 | |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7877 | case REF_COMPONENT: |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7878 | /* F2008, C644. */ |
Tobias Burnus | c49eaa2 | 2011-04-23 12:26:38 +0200 | [diff] [blame] | 7879 | if (coindexed) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7880 | { |
| 7881 | gfc_error ("Coindexed allocatable object at %L", |
| 7882 | &e->where); |
| 7883 | goto failure; |
| 7884 | } |
| 7885 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7886 | c = ref->u.c.component; |
| 7887 | if (c->ts.type == BT_CLASS) |
| 7888 | { |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7889 | allocatable = CLASS_DATA (c)->attr.allocatable; |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 7890 | pointer = CLASS_DATA (c)->attr.class_pointer; |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 7891 | dimension = CLASS_DATA (c)->attr.dimension; |
| 7892 | codimension = CLASS_DATA (c)->attr.codimension; |
| 7893 | is_abstract = CLASS_DATA (c)->attr.abstract; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7894 | } |
| 7895 | else |
| 7896 | { |
| 7897 | allocatable = c->attr.allocatable; |
| 7898 | pointer = c->attr.pointer; |
| 7899 | dimension = c->attr.dimension; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7900 | codimension = c->attr.codimension; |
Tobias Burnus | d0a9804 | 2009-10-09 22:34:35 +0200 | [diff] [blame] | 7901 | is_abstract = c->attr.abstract; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 7902 | } |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7903 | break; |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7904 | |
| 7905 | case REF_SUBSTRING: |
Paul Thomas | a5fbc2f | 2018-11-01 19:36:08 +0000 | [diff] [blame] | 7906 | case REF_INQUIRY: |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 7907 | allocatable = 0; |
| 7908 | pointer = 0; |
| 7909 | break; |
Tobias Burnus | f17faca | 2007-01-05 10:08:37 +0100 | [diff] [blame] | 7910 | } |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 7911 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7912 | } |
| 7913 | |
Harald Anlauf | 9213ff1 | 2021-08-30 22:41:01 +0200 | [diff] [blame] | 7914 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7917 | { |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 7918 | gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", |
| 7919 | &e->where); |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7920 | goto failure; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 7921 | } |
| 7922 | |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7923 | /* 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 7929 | gfc_error ("Type of entity at %L is type incompatible with " |
| 7930 | "source-expr at %L", &e->where, &code->expr3->where); |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7931 | goto failure; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7932 | } |
| 7933 | |
| 7934 | /* Check F03:C632 and restriction following Note 6.18. */ |
Janus Weil | 2ccd6f7 | 2013-12-11 15:02:44 +0100 | [diff] [blame] | 7935 | if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7936 | goto failure; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7937 | |
| 7938 | /* Check F03:C633. */ |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 7939 | if (code->expr3->ts.kind != e->ts.kind && !unlimited) |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7940 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 7941 | 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7944 | goto failure; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7945 | } |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 7946 | |
| 7947 | /* Check F2008, C642. */ |
| 7948 | if (code->expr3->ts.type == BT_DERIVED |
Tobias Burnus | 3b6fa7a | 2011-08-18 17:10:25 +0200 | [diff] [blame] | 7949 | && ((codimension && gfc_expr_attr (code->expr3).lock_comp) |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 7950 | || (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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 7955 | gfc_error ("The source-expr at %L shall neither be of type " |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 7956 | "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 Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 7961 | |
| 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 Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 7976 | } |
Janus Weil | 94bff63 | 2010-06-15 20:33:58 +0200 | [diff] [blame] | 7977 | |
| 7978 | /* Check F08:C629. */ |
| 7979 | if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN |
| 7980 | && !code->expr3) |
Tobias Burnus | d0a9804 | 2009-10-09 22:34:35 +0200 | [diff] [blame] | 7981 | { |
| 7982 | gcc_assert (e->ts.type == BT_CLASS); |
| 7983 | gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " |
Janus Weil | 94bff63 | 2010-06-15 20:33:58 +0200 | [diff] [blame] | 7984 | "type-spec or source-expr", sym->name, &e->where); |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 7985 | goto failure; |
Tobias Burnus | d0a9804 | 2009-10-09 22:34:35 +0200 | [diff] [blame] | 7986 | } |
| 7987 | |
Andre Vehreschild | e3a7c6c | 2015-02-06 12:22:54 +0100 | [diff] [blame] | 7988 | /* Check F08:C632. */ |
| 7989 | if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred |
| 7990 | && !UNLIMITED_POLY (e)) |
Tobias Burnus | 2e0bffa | 2012-01-10 12:22:16 +0100 | [diff] [blame] | 7991 | { |
Steven G. Kargl | bdd82c9 | 2018-01-10 23:26:15 +0000 | [diff] [blame] | 7992 | 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 Burnus | 2e0bffa | 2012-01-10 12:22:16 +0100 | [diff] [blame] | 7999 | 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 Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 8008 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8012 | t = true; |
| 8013 | if (t && pointer) |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 8014 | t = gfc_check_vardef_context (e2, true, true, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8015 | _("ALLOCATE object")); |
| 8016 | if (t) |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 8017 | t = gfc_check_vardef_context (e2, false, true, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8018 | _("ALLOCATE object")); |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 8019 | gfc_free_expr (e2); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8020 | if (!t) |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 8021 | goto failure; |
Erik Edelmann | aa08038 | 2006-03-05 19:24:48 +0000 | [diff] [blame] | 8022 | |
Paul Thomas | c49ea23 | 2011-12-11 20:42:23 +0000 | [diff] [blame] | 8023 | 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 8030 | code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); |
Paul Thomas | c49ea23 | 2011-12-11 20:42:23 +0000 | [diff] [blame] | 8031 | } |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 8032 | 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 Weil | b6ff812 | 2010-09-04 11:29:11 +0200 | [diff] [blame] | 8039 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 8040 | if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) |
Janus Weil | e10f52d | 2010-08-04 21:49:19 +0200 | [diff] [blame] | 8041 | { |
| 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 Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 8049 | |
Andre Vehreschild | cc03bf7 | 2016-11-06 17:10:22 +0100 | [diff] [blame] | 8050 | /* Finding the vtab also publishes the type's symbol. Therefore this |
| 8051 | statement is necessary. */ |
Janus Weil | e10f52d | 2010-08-04 21:49:19 +0200 | [diff] [blame] | 8052 | gfc_find_derived_vtab (ts.u.derived); |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 8053 | } |
| 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 Vehreschild | cc03bf7 | 2016-11-06 17:10:22 +0100 | [diff] [blame] | 8066 | /* Finding the vtab also publishes the type's symbol. Therefore this |
| 8067 | statement is necessary. */ |
Janus Weil | 7289d1c | 2013-12-18 23:00:53 +0100 | [diff] [blame] | 8068 | gfc_find_vtab (ts); |
Janus Weil | e10f52d | 2010-08-04 21:49:19 +0200 | [diff] [blame] | 8069 | } |
| 8070 | |
Janus Weil | b21a544 | 2011-07-19 14:38:59 +0200 | [diff] [blame] | 8071 | if (dimension == 0 && codimension == 0) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8072 | goto success; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8073 | |
Tobias Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 8074 | /* Make sure the last reference node is an array specification. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8075 | |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 8076 | if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8077 | || (dimension && ref2->u.ar.dimen == 0)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8078 | { |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8079 | /* 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 Vehreschild | 7a85da8 | 2016-04-04 12:32:32 +0200 | [diff] [blame] | 8085 | 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 Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8094 | } |
| 8095 | else |
| 8096 | { |
| 8097 | gfc_error ("Array specification required in ALLOCATE statement " |
| 8098 | "at %L", &e->where); |
| 8099 | goto failure; |
| 8100 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8101 | } |
| 8102 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8103 | /* Make sure that the array section reference makes sense in the |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8104 | context of an ALLOCATE specification. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8105 | |
| 8106 | ar = &ref2->u.ar; |
| 8107 | |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 8108 | if (codimension) |
| 8109 | for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) |
Thomas Koenig | b450b08 | 2019-03-03 13:16:40 +0000 | [diff] [blame] | 8110 | { |
| 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8117 | |
Thomas Koenig | b450b08 | 2019-03-03 13:16:40 +0000 | [diff] [blame] | 8118 | case DIMEN_RANGE: |
Harald Anlauf | 54c5e06 | 2022-04-06 22:24:21 +0200 | [diff] [blame] | 8119 | /* 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 Koenig | b450b08 | 2019-03-03 13:16:40 +0000 | [diff] [blame] | 8123 | { |
Harald Anlauf | 54c5e06 | 2022-04-06 22:24:21 +0200 | [diff] [blame] | 8124 | gfc_error ("Bad coarray specification in ALLOCATE statement " |
| 8125 | "at %L", &e->where); |
Thomas Koenig | b450b08 | 2019-03-03 13:16:40 +0000 | [diff] [blame] | 8126 | 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 Jelinek | 0d7bac6 | 2019-03-08 11:51:28 +0100 | [diff] [blame] | 8143 | "of 1 at %L", &ar->start[i]->where); |
Thomas Koenig | b450b08 | 2019-03-03 13:16:40 +0000 | [diff] [blame] | 8144 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8159 | for (i = 0; i < ar->dimen; i++) |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8160 | { |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8161 | if (ar->type == AR_ELEMENT || ar->type == AR_FULL) |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8162 | goto check_symbols; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8163 | |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8164 | switch (ar->dimen_type[i]) |
| 8165 | { |
| 8166 | case DIMEN_ELEMENT: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8167 | break; |
| 8168 | |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8169 | case DIMEN_RANGE: |
| 8170 | if (ar->start[i] != NULL |
| 8171 | && ar->end[i] != NULL |
| 8172 | && ar->stride[i] == NULL) |
| 8173 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8174 | |
Marek Polacek | 191816a | 2016-08-12 10:30:47 +0000 | [diff] [blame] | 8175 | /* Fall through. */ |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8176 | |
| 8177 | case DIMEN_UNKNOWN: |
| 8178 | case DIMEN_VECTOR: |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8179 | case DIMEN_STAR: |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 8180 | case DIMEN_THIS_IMAGE: |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8181 | gfc_error ("Bad array specification in ALLOCATE statement at %L", |
| 8182 | &e->where); |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8183 | goto failure; |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8184 | } |
| 8185 | |
| 8186 | check_symbols: |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8187 | for (a = code->ext.alloc.list; a; a = a->next) |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8188 | { |
| 8189 | sym = a->expr->symtree->n.sym; |
Paul Thomas | 25e8cb2 | 2006-10-04 16:54:19 +0000 | [diff] [blame] | 8190 | |
| 8191 | /* TODO - check derived type components. */ |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 8192 | if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) |
Paul Thomas | 25e8cb2 | 2006-10-04 16:54:19 +0000 | [diff] [blame] | 8193 | continue; |
| 8194 | |
Jakub Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 8195 | 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 Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8199 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 8200 | gfc_error ("%qs must not appear in the array specification at " |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8201 | "%L in the same ALLOCATE statement where it is " |
| 8202 | "itself allocated", sym->name, &ar->where); |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8203 | goto failure; |
Paul Thomas | 7772657 | 2006-10-03 21:40:24 +0000 | [diff] [blame] | 8204 | } |
| 8205 | } |
| 8206 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8207 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8208 | 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 Burnus | c6423ef | 2012-09-17 12:13:12 +0200 | [diff] [blame] | 8219 | continue; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8220 | } |
| 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8231 | success: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8232 | return true; |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 8233 | |
| 8234 | failure: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8235 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8236 | } |
| 8237 | |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8238 | |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8239 | static void |
| 8240 | resolve_allocate_deallocate (gfc_code *code, const char *fcn) |
| 8241 | { |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8242 | gfc_expr *stat, *errmsg, *pe, *qe; |
| 8243 | gfc_alloc *a, *p, *q; |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8244 | |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 8245 | stat = code->expr1; |
| 8246 | errmsg = code->expr2; |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8247 | |
| 8248 | /* Check the stat variable. */ |
| 8249 | if (stat) |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8250 | { |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8251 | if (!gfc_check_vardef_context (stat, false, false, false, |
| 8252 | _("STAT variable"))) |
| 8253 | goto done_stat; |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8254 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8255 | if (stat->ts.type != BT_INTEGER |
Thomas Koenig | 6c14525 | 2009-09-07 15:23:15 +0000 | [diff] [blame] | 8256 | || stat->rank > 0) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8257 | gfc_error ("Stat-variable at %L must be a scalar INTEGER " |
| 8258 | "variable", &stat->where); |
| 8259 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8260 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8266 | for (p = code->ext.alloc.list; p; p = p->next) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8267 | if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) |
Tobias Burnus | ddf58e4 | 2010-06-19 00:23:40 +0200 | [diff] [blame] | 8268 | { |
| 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 Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8291 | } |
| 8292 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8293 | done_stat: |
| 8294 | |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8295 | /* Check the errmsg variable. */ |
| 8296 | if (errmsg) |
| 8297 | { |
| 8298 | if (!stat) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 8299 | gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8300 | &errmsg->where); |
| 8301 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8302 | if (!gfc_check_vardef_context (errmsg, false, false, false, |
| 8303 | _("ERRMSG variable"))) |
| 8304 | goto done_errmsg; |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8305 | |
Steven G. Kargl | 20ce6ad | 2018-06-04 15:54:48 +0000 | [diff] [blame] | 8306 | /* 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 Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8310 | if (errmsg->ts.type != BT_CHARACTER |
Steven G. Kargl | 20ce6ad | 2018-06-04 15:54:48 +0000 | [diff] [blame] | 8311 | || 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. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8314 | "variable", &errmsg->where); |
| 8315 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8316 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8322 | for (p = code->ext.alloc.list; p; p = p->next) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8323 | if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) |
Tobias Burnus | ddf58e4 | 2010-06-19 00:23:40 +0200 | [diff] [blame] | 8324 | { |
| 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. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8347 | } |
| 8348 | |
Harald Anlauf | 7bf582e | 2021-07-28 19:11:27 +0200 | [diff] [blame] | 8349 | done_errmsg: |
| 8350 | |
Thomas Koenig | c2092de | 2012-07-16 20:58:04 +0000 | [diff] [blame] | 8351 | /* Check that an allocate-object appears only once in the statement. */ |
| 8352 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8353 | for (p = code->ext.alloc.list; p; p = p->next) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8354 | { |
| 8355 | pe = p->expr; |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8356 | for (q = p->next; q; q = q->next) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8357 | { |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8358 | qe = q->expr; |
| 8359 | if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8360 | { |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8361 | /* This is a potential collision. */ |
| 8362 | gfc_ref *pr = pe->ref; |
| 8363 | gfc_ref *qr = qe->ref; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 8364 | |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8365 | /* 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 8374 | gfc_error ("Allocate-object at %L also appears at %L", |
| 8375 | &pe->where, &qe->where); |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8376 | break; |
| 8377 | } |
| 8378 | else if (pr != NULL && qr == NULL) |
| 8379 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 8380 | gfc_error ("Allocate-object at %L is subobject of" |
| 8381 | " object at %L", &pe->where, &qe->where); |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8382 | break; |
| 8383 | } |
| 8384 | else if (pr == NULL && qr != NULL) |
| 8385 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 8386 | gfc_error ("Allocate-object at %L is subobject of" |
| 8387 | " object at %L", &qe->where, &pe->where); |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8388 | 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 Thomas | 474d486 | 2012-12-02 15:23:30 +0000 | [diff] [blame] | 8400 | int i; |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8401 | gfc_array_ref *par = &(pr->u.ar); |
| 8402 | gfc_array_ref *qar = &(qr->u.ar); |
Paul Thomas | 474d486 | 2012-12-02 15:23:30 +0000 | [diff] [blame] | 8403 | |
| 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 Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8412 | } |
| 8413 | } |
| 8414 | else |
| 8415 | { |
| 8416 | if (pr->u.c.component->name != qr->u.c.component->name) |
| 8417 | break; |
| 8418 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 8419 | |
Thomas Koenig | 75fee9f | 2011-01-05 10:03:15 +0000 | [diff] [blame] | 8420 | pr = pr->next; |
| 8421 | qr = qr->next; |
| 8422 | } |
Paul Thomas | 474d486 | 2012-12-02 15:23:30 +0000 | [diff] [blame] | 8423 | break_label: |
| 8424 | ; |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8425 | } |
| 8426 | } |
| 8427 | } |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8428 | |
| 8429 | if (strcmp (fcn, "ALLOCATE") == 0) |
| 8430 | { |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8431 | bool arr_alloc_wo_spec = false; |
Andre Vehreschild | cc03bf7 | 2016-11-06 17:10:22 +0100 | [diff] [blame] | 8432 | |
| 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8448 | for (a = code->ext.alloc.list; a; a = a->next) |
Andre Vehreschild | 1792349 | 2015-06-15 12:08:04 +0200 | [diff] [blame] | 8449 | 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 Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8457 | } |
| 8458 | else |
| 8459 | { |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 8460 | for (a = code->ext.alloc.list; a; a = a->next) |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 8461 | resolve_deallocate_expr (a->expr); |
| 8462 | } |
| 8463 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8464 | |
Steven G. Kargl | 3759634 | 2009-03-31 04:38:12 +0000 | [diff] [blame] | 8465 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8466 | /************ 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 8470 | op1 > op2. Assumes we're not dealing with the default case. |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8471 | We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). |
| 8472 | There are nine situations to check. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8473 | |
| 8474 | static int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8475 | compare_cases (const gfc_case *op1, const gfc_case *op2) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8476 | { |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8477 | int retval; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8478 | |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8479 | if (op1->low == NULL) /* op1 = (:L) */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8480 | { |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8481 | /* op2 = (:N), so overlap. */ |
| 8482 | retval = 0; |
| 8483 | /* op2 = (M:) or (M:N), L < M */ |
| 8484 | if (op2->low != NULL |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8485 | && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8486 | 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 Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8494 | && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8495 | retval = 1; |
| 8496 | } |
| 8497 | else /* op1 = (K:L) */ |
| 8498 | { |
| 8499 | if (op2->low == NULL) /* op2 = (:N), K > N */ |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8500 | retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) |
| 8501 | ? 1 : 0; |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8502 | else if (op2->high == NULL) /* op2 = (M:), L < M */ |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8503 | retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) |
| 8504 | ? -1 : 0; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8505 | else /* op2 = (M:N) */ |
| 8506 | { |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8507 | retval = 0; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8508 | /* L < M */ |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8509 | if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8510 | retval = -1; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8511 | /* K > N */ |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8512 | else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8513 | retval = 1; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8514 | } |
| 8515 | } |
| 8516 | |
Steven G. Kargl | c224550 | 2005-01-14 11:55:12 +0000 | [diff] [blame] | 8517 | return retval; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8518 | } |
| 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 | |
| 8526 | static gfc_case * |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8527 | check_case_overlap (gfc_case *list) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8528 | { |
| 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. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8558 | /* Cut the list in two pieces by stepping INSIZE places |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8559 | forward in the list, starting from P. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8560 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8574 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8595 | one for Q. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8596 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8603 | the case range for P. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8604 | 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 8614 | gfc_error ("CASE label at %L overlaps with CASE " |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8615 | "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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8633 | they're the same. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8634 | p = q; |
| 8635 | } |
| 8636 | tail->right = NULL; |
| 8637 | |
| 8638 | /* If we have done only one merge or none at all, we've |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8639 | finished sorting the cases. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8640 | if (nmerges <= 1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8641 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8642 | 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. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8654 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8656 | type. Return false if anything is wrong. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8657 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8658 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8659 | validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8660 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8661 | if (e == NULL) return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8662 | |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8663 | if (e->ts.type != case_expr->ts.type) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8664 | { |
| 8665 | gfc_error ("Expression in CASE statement at %L must be of type %s", |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8666 | &e->where, gfc_basic_typename (case_expr->ts.type)); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8667 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8668 | } |
| 8669 | |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8670 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8675 | { |
Francois-Xavier Coudert | d393bbd | 2008-05-18 22:45:05 +0000 | [diff] [blame] | 8676 | gfc_error ("Expression in CASE statement at %L must be of kind %d", |
| 8677 | &e->where, case_expr->ts.kind); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8678 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8679 | } |
| 8680 | |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8681 | /* Convert the case value kind to that of case expression kind, |
| 8682 | if needed */ |
| 8683 | |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8684 | if (e->ts.kind != case_expr->ts.kind) |
| 8685 | gfc_convert_type_warn (e, &case_expr->ts, 2, 0); |
| 8686 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8687 | if (e->rank != 0) |
| 8688 | { |
| 8689 | gfc_error ("Expression in CASE statement at %L must be scalar", |
| 8690 | &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8691 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8692 | } |
| 8693 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8694 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8695 | } |
| 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 Hirata | 1f2959f | 2004-09-16 16:00:45 +0000 | [diff] [blame] | 8712 | been a computed GOTO in the source code. Fortunately we can fairly |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8713 | 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 | |
| 8718 | static void |
Janus Weil | ad3e2ad | 2013-01-23 22:38:40 +0100 | [diff] [blame] | 8719 | resolve_select (gfc_code *code, bool select_type) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8720 | { |
| 8721 | gfc_code *body; |
| 8722 | gfc_expr *case_expr; |
| 8723 | gfc_case *cp, *default_case, *tail, *head; |
| 8724 | int seen_unreachable; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 8725 | int seen_logical; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8726 | int ncases; |
| 8727 | bt type; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8728 | bool t; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8729 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 8730 | if (code->expr1 == NULL) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8731 | { |
| 8732 | /* This was actually a computed GOTO statement. */ |
| 8733 | case_expr = code->expr2; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8734 | if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8735 | 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. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 8743 | code->expr1 = code->expr2; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8744 | code->expr2 = NULL; |
| 8745 | return; |
| 8746 | } |
| 8747 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 8748 | case_expr = code->expr1; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8749 | type = case_expr->ts.type; |
Janus Weil | ad3e2ad | 2013-01-23 22:38:40 +0100 | [diff] [blame] | 8750 | |
| 8751 | /* F08:C830. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8752 | if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) |
| 8753 | { |
| 8754 | gfc_error ("Argument of SELECT statement at %L cannot be %s", |
Mark Eggleston | f61e54e | 2019-10-03 09:40:23 +0000 | [diff] [blame] | 8755 | &case_expr->where, gfc_typename (case_expr)); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8756 | |
| 8757 | /* Punt. Going on here just produce more garbage error messages. */ |
| 8758 | return; |
| 8759 | } |
| 8760 | |
Janus Weil | ad3e2ad | 2013-01-23 22:38:40 +0100 | [diff] [blame] | 8761 | /* 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 Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8771 | /* 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 Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8777 | for (cp = body->ext.block.case_list; cp; cp = cp->next) |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8778 | { |
| 8779 | if (cp->low |
| 8780 | && gfc_check_integer_range (cp->low->value.integer, |
| 8781 | case_expr->ts.kind) != ARITH_OK) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 8782 | gfc_warning (0, "Expression in CASE statement at %L is " |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8783 | "not in the range of %s", &cp->low->where, |
Mark Eggleston | f61e54e | 2019-10-03 09:40:23 +0000 | [diff] [blame] | 8784 | gfc_typename (case_expr)); |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8785 | |
| 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 Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 8790 | gfc_warning (0, "Expression in CASE statement at %L is " |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8791 | "not in the range of %s", &cp->high->where, |
Mark Eggleston | f61e54e | 2019-10-03 09:40:23 +0000 | [diff] [blame] | 8792 | gfc_typename (case_expr)); |
Daniel Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8793 | } |
| 8794 | |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8795 | /* 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 Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8805 | for (cp = body->ext.block.case_list; cp; cp = cp->next) |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8806 | { |
| 8807 | /* Intercept the DEFAULT case. It does not have a kind. */ |
| 8808 | if (cp->low == NULL && cp->high == NULL) |
| 8809 | continue; |
| 8810 | |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 8811 | /* Unreachable case ranges are discarded, so ignore. */ |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8812 | if (cp->low != NULL && cp->high != NULL |
| 8813 | && cp->low != cp->high |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8814 | && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8815 | continue; |
| 8816 | |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8817 | if (cp->low != NULL |
| 8818 | && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) |
Steve Kargl | d18e4cc | 2021-10-30 18:22:19 +0200 | [diff] [blame] | 8819 | gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0); |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8820 | |
| 8821 | if (cp->high != NULL |
| 8822 | && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high)) |
Steve Kargl | d18e4cc | 2021-10-30 18:22:19 +0200 | [diff] [blame] | 8823 | gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0); |
Steven G. Kargl | 5352b89 | 2005-01-16 12:51:04 +0000 | [diff] [blame] | 8824 | } |
| 8825 | } |
| 8826 | } |
| 8827 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8828 | /* Assume there is no DEFAULT case. */ |
| 8829 | default_case = NULL; |
| 8830 | head = tail = NULL; |
| 8831 | ncases = 0; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 8832 | seen_logical = 0; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8833 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8837 | t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8838 | seen_unreachable = 0; |
| 8839 | |
| 8840 | /* Walk the case label list, making sure that all case labels |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8841 | are legal. */ |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8842 | for (cp = body->ext.block.case_list; cp; cp = cp->next) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8843 | { |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8851 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 8852 | gfc_error ("The DEFAULT CASE at %L cannot be followed " |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8853 | "by a second DEFAULT CASE at %L", |
| 8854 | &default_case->where, &cp->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8855 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8856 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8866 | issued from the validation function. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8867 | if (!validate_case_label_expr (cp->low, case_expr) |
| 8868 | || !validate_case_label_expr (cp->high, case_expr)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8869 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8870 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8871 | break; |
| 8872 | } |
| 8873 | |
| 8874 | if (type == BT_LOGICAL |
| 8875 | && ((cp->low == NULL || cp->high == NULL) |
| 8876 | || cp->low != cp->high)) |
| 8877 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8878 | gfc_error ("Logical range in CASE statement at %L is not " |
Harald Anlauf | 3b3c993 | 2021-11-16 21:06:06 +0100 | [diff] [blame] | 8879 | "allowed", |
| 8880 | cp->low ? &cp->low->where : &cp->high->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8881 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8882 | break; |
| 8883 | } |
| 8884 | |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 8885 | 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 Franke | ad1614a | 2010-05-11 11:43:16 -0400 | [diff] [blame] | 8891 | gfc_error ("Constant logical value in CASE statement " |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 8892 | "is repeated at %L", |
| 8893 | &cp->low->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8894 | t = false; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 8895 | break; |
| 8896 | } |
| 8897 | seen_logical |= value; |
| 8898 | } |
| 8899 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8900 | if (cp->low != NULL && cp->high != NULL |
| 8901 | && cp->low != cp->high |
Tobias Burnus | 7b4c5f8 | 2007-12-05 14:42:32 +0100 | [diff] [blame] | 8902 | && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8903 | { |
Tobias Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 8904 | if (warn_surprising) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 8905 | gfc_warning (OPT_Wsurprising, |
| 8906 | "Range specification at %L can never be matched", |
| 8907 | &cp->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8908 | |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8919 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8920 | head = tail = cp; |
| 8921 | head->right = head->left = NULL; |
| 8922 | } |
| 8923 | else |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8924 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8925 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 8935 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8936 | 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 Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8945 | while (body->ext.block.case_list != NULL |
| 8946 | && body->ext.block.case_list->unreachable) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8947 | { |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8948 | gfc_case *n = body->ext.block.case_list; |
| 8949 | body->ext.block.case_list = body->ext.block.case_list->next; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8950 | n->next = NULL; |
| 8951 | gfc_free_case_list (n); |
| 8952 | } |
| 8953 | |
| 8954 | /* Strip all other unreachable cases. */ |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8955 | if (body->ext.block.case_list) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8956 | { |
Steven Bosscher | f172301 | 2014-08-22 18:43:50 +0000 | [diff] [blame] | 8957 | for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8958 | { |
| 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 Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 8993 | if (body->block->ext.block.case_list == NULL) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 8994 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 8995 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 9002 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 9003 | } |
| 9004 | |
| 9005 | /* More than two cases is legal but insane for logical selects. |
| 9006 | Issue a warning for it. */ |
Tobias Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 9007 | if (warn_surprising && type == BT_LOGICAL && ncases > 2) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 9008 | gfc_warning (OPT_Wsurprising, |
| 9009 | "Logical SELECT CASE block at %L has more that two cases", |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 9010 | &code->loc); |
| 9011 | } |
| 9012 | |
| 9013 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9014 | /* Check if a derived type is extensible. */ |
| 9015 | |
| 9016 | bool |
| 9017 | gfc_type_is_extensible (gfc_symbol *sym) |
| 9018 | { |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9019 | return !(sym->attr.is_bind_c || sym->attr.sequence |
| 9020 | || (sym->attr.is_class |
| 9021 | && sym->components->ts.u.derived->attr.unlimited_polymorphic)); |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9022 | } |
| 9023 | |
| 9024 | |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9025 | static void |
| 9026 | resolve_types (gfc_namespace *ns); |
| 9027 | |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 9028 | /* Resolve an associate-name: Resolve target and ensure the type-spec is |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9029 | correct as well as possibly the array-spec. */ |
| 9030 | |
| 9031 | static void |
| 9032 | resolve_assoc_var (gfc_symbol* sym, bool resolve_target) |
| 9033 | { |
| 9034 | gfc_expr* target; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9035 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 9047 | if (resolve_target && !gfc_resolve_expr (target)) |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9048 | return; |
| 9049 | |
| 9050 | /* For variable targets, we get some attributes from the target. */ |
| 9051 | if (target->expr_type == EXPR_VARIABLE) |
| 9052 | { |
Tobias Burnus | a76ff30 | 2020-03-27 10:56:25 +0100 | [diff] [blame] | 9053 | gfc_symbol *tsym, *dsym; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9054 | |
| 9055 | gcc_assert (target->symtree); |
| 9056 | tsym = target->symtree->n.sym; |
Tobias Burnus | 4d12437 | 2020-01-03 08:08:30 +0000 | [diff] [blame] | 9057 | |
Tobias Burnus | 4d12437 | 2020-01-03 08:08:30 +0000 | [diff] [blame] | 9058 | if (gfc_expr_attr (target).proc_pointer) |
| 9059 | { |
| 9060 | gfc_error ("Associating entity %qs at %L is a procedure pointer", |
Thomas Koenig | c212316 | 2019-12-08 13:42:42 +0000 | [diff] [blame] | 9061 | tsym->name, &target->where); |
| 9062 | return; |
| 9063 | } |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9064 | |
Tobias Burnus | a76ff30 | 2020-03-27 10:56:25 +0100 | [diff] [blame] | 9065 | 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9092 | sym->attr.asynchronous = tsym->attr.asynchronous; |
| 9093 | sym->attr.volatile_ = tsym->attr.volatile_; |
| 9094 | |
Tobias Burnus | 102344e | 2012-01-27 14:08:52 +0100 | [diff] [blame] | 9095 | sym->attr.target = tsym->attr.target |
| 9096 | || gfc_expr_attr (target).pointer; |
Paul Thomas | 68b1c5e | 2014-02-09 20:50:21 +0000 | [diff] [blame] | 9097 | if (is_subref_array (target)) |
| 9098 | sym->attr.subref_array_pointer = 1; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9099 | } |
Tobias Burnus | 4d12437 | 2020-01-03 08:08:30 +0000 | [diff] [blame] | 9100 | 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9106 | |
Paul Thomas | b89a63b | 2017-09-21 18:40:21 +0000 | [diff] [blame] | 9107 | 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 Kraft | 414e8be | 2010-09-26 21:25:52 +0200 | [diff] [blame] | 9118 | /* 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 Thomas | b89a63b | 2017-09-21 18:40:21 +0000 | [diff] [blame] | 9123 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9124 | gcc_assert (sym->ts.type != BT_UNKNOWN); |
| 9125 | |
| 9126 | /* See if this is a valid association-to-variable. */ |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 9127 | sym->assoc->variable = (target->expr_type == EXPR_VARIABLE |
| 9128 | && !gfc_has_vector_subscript (target)); |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9129 | |
| 9130 | /* Finally resolve if this is an array or not. */ |
Tobias Burnus | 102344e | 2012-01-27 14:08:52 +0100 | [diff] [blame] | 9131 | if (sym->attr.dimension && target->rank == 0) |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9132 | { |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 9133 | /* primary.cc makes the assumption that a reference to an associate |
Paul Thomas | e207c52 | 2015-01-18 12:21:38 +0000 | [diff] [blame] | 9134 | 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9138 | sym->attr.dimension = 0; |
| 9139 | return; |
| 9140 | } |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 9141 | |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9142 | |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 9143 | /* 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 Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9152 | if (target->ts.type == BT_CLASS) |
Paul Thomas | 8f75db9 | 2012-05-05 08:49:43 +0000 | [diff] [blame] | 9153 | gfc_fix_class_refs (target); |
| 9154 | |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 9155 | if (target->rank != 0 && !sym->attr.select_rank_temporary) |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9156 | { |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9157 | gfc_array_spec *as; |
Andre Vehreschild | 76fe932 | 2016-02-11 17:48:45 +0100 | [diff] [blame] | 9158 | /* 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 Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9161 | { |
Andre Vehreschild | 76fe932 | 2016-02-11 17:48:45 +0100 | [diff] [blame] | 9162 | if (!sym->as) |
| 9163 | sym->as = gfc_get_array_spec (); |
| 9164 | as = sym->as; |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9165 | 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 Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9171 | } |
Harald Anlauf | 8a0b69f | 2020-07-10 21:00:13 +0200 | [diff] [blame] | 9172 | else if (sym->ts.type == BT_CLASS |
| 9173 | && CLASS_DATA (sym) |
| 9174 | && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) |
Paul Thomas | e60f68e | 2018-10-15 16:31:15 +0000 | [diff] [blame] | 9175 | { |
| 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 Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9186 | } |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 9187 | else if (!sym->attr.select_rank_temporary) |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9188 | { |
| 9189 | /* target's rank is 0, but the type of the sym is still array valued, |
| 9190 | which has to be corrected. */ |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 9191 | if (sym->ts.type == BT_CLASS && sym->ts.u.derived |
Steven G. Kargl | 4874b4d | 2018-12-08 18:09:05 +0000 | [diff] [blame] | 9192 | && CLASS_DATA (sym) && CLASS_DATA (sym)->as) |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9193 | { |
| 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 Anlauf | 267f84c | 2020-06-30 23:36:56 +0200 | [diff] [blame] | 9224 | attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9225 | 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 9232 | c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); |
Andre Vehreschild | 76540ac | 2015-06-23 11:07:22 +0200 | [diff] [blame] | 9233 | 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9245 | } |
Paul Thomas | aa27186 | 2013-01-27 07:09:06 +0000 | [diff] [blame] | 9246 | |
| 9247 | /* Mark this as an associate variable. */ |
| 9248 | sym->attr.associate_var = 1; |
| 9249 | |
Steven G. Kargl | 50b01e1 | 2016-10-05 21:14:14 +0000 | [diff] [blame] | 9250 | /* 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 Thomas | 5c60dbc | 2018-02-19 22:09:13 +0000 | [diff] [blame] | 9254 | sym->ts.u.cl = target->ts.u.cl; |
Paul Thomas | a8399af | 2018-02-17 11:07:32 +0000 | [diff] [blame] | 9255 | |
Mikael Morin | 907811d | 2022-03-13 22:22:55 +0100 | [diff] [blame] | 9256 | if (sym->ts.deferred |
Paul Thomas | ca32d61 | 2018-09-17 07:18:17 +0000 | [diff] [blame] | 9257 | && 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 Thomas | 5c60dbc | 2018-02-19 22:09:13 +0000 | [diff] [blame] | 9263 | 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 Thomas | a8399af | 2018-02-17 11:07:32 +0000 | [diff] [blame] | 9270 | } |
Paul Thomas | 5c60dbc | 2018-02-19 22:09:13 +0000 | [diff] [blame] | 9271 | else if ((!sym->ts.u.cl->length |
| 9272 | || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
| 9273 | && target->expr_type != EXPR_VARIABLE) |
Janne Blomqvist | ae976c3 | 2018-02-01 21:47:15 +0200 | [diff] [blame] | 9274 | { |
Mikael Morin | 907811d | 2022-03-13 22:22:55 +0100 | [diff] [blame] | 9275 | if (!sym->ts.deferred) |
| 9276 | { |
| 9277 | sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); |
| 9278 | sym->ts.deferred = 1; |
| 9279 | } |
Paul Thomas | 5c60dbc | 2018-02-19 22:09:13 +0000 | [diff] [blame] | 9280 | |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 9281 | /* This is reset in trans-stmt.cc after the assignment |
Paul Thomas | 5c60dbc | 2018-02-19 22:09:13 +0000 | [diff] [blame] | 9282 | of the target expression to the associate name. */ |
| 9283 | sym->attr.allocatable = 1; |
Janne Blomqvist | ae976c3 | 2018-02-01 21:47:15 +0200 | [diff] [blame] | 9284 | } |
Steven G. Kargl | 50b01e1 | 2016-10-05 21:14:14 +0000 | [diff] [blame] | 9285 | } |
| 9286 | |
Paul Thomas | aa27186 | 2013-01-27 07:09:06 +0000 | [diff] [blame] | 9287 | /* 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9290 | } |
| 9291 | |
| 9292 | |
Paul Thomas | de514d4 | 2016-10-21 12:50:56 +0000 | [diff] [blame] | 9293 | /* 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 | |
| 9299 | static void |
| 9300 | fixup_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 Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9335 | static gfc_expr * |
| 9336 | build_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 Thomas | c8bd326 | 2018-03-03 13:34:10 +0000 | [diff] [blame] | 9341 | gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false); |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9342 | 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 Koenig | eb950bf | 2016-11-06 21:27:32 +0000 | [diff] [blame] | 9351 | loc_call->where = sym_expr->where; |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9352 | return loc_call; |
| 9353 | } |
| 9354 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9355 | /* Resolve a SELECT TYPE statement. */ |
| 9356 | |
| 9357 | static void |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 9358 | resolve_select_type (gfc_code *code, gfc_namespace *old_ns) |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9359 | { |
| 9360 | gfc_symbol *selector_type; |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9361 | gfc_code *body, *new_st, *if_st, *tail; |
| 9362 | gfc_code *class_is = NULL, *default_case = NULL; |
| 9363 | gfc_case *c; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9364 | gfc_symtree *st; |
Tobias Burnus | 0e792ee | 2021-03-22 09:49:48 +0100 | [diff] [blame] | 9365 | char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9366 | gfc_namespace *ns; |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9367 | int error = 0; |
Paul Thomas | de514d4 | 2016-10-21 12:50:56 +0000 | [diff] [blame] | 9368 | int rank = 0; |
| 9369 | gfc_ref* ref = NULL; |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9370 | gfc_expr *selector_expr = NULL; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9371 | |
Daniel Kraft | 03af1e4 | 2010-06-10 16:47:49 +0200 | [diff] [blame] | 9372 | ns = code->ext.block.ns; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9373 | gfc_resolve (ns); |
| 9374 | |
Janus Weil | f5dbb57 | 2010-05-10 14:54:25 +0200 | [diff] [blame] | 9375 | /* 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 Burnus | cd99c23 | 2011-12-19 16:30:23 +0100 | [diff] [blame] | 9384 | if (!code->expr1->symtree->n.sym->attr.class_ok) |
| 9385 | return; |
| 9386 | |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9387 | if (code->expr2) |
Janus Weil | f5dbb57 | 2010-05-10 14:54:25 +0200 | [diff] [blame] | 9388 | { |
Paul Thomas | e60f68e | 2018-10-15 16:31:15 +0000 | [diff] [blame] | 9389 | 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 Burnus | 91f9b2e | 2018-10-17 21:58:58 +0200 | [diff] [blame] | 9398 | code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts; |
Paul Thomas | e60f68e | 2018-10-15 16:31:15 +0000 | [diff] [blame] | 9399 | 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 Anlauf | f215122 | 2020-07-06 18:58:23 +0200 | [diff] [blame] | 9405 | selector_type = CLASS_DATA (code->expr2) |
| 9406 | ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived; |
Paul Thomas | e60f68e | 2018-10-15 16:31:15 +0000 | [diff] [blame] | 9407 | } |
Paul Thomas | e4821cd | 2013-01-04 20:50:15 +0000 | [diff] [blame] | 9408 | |
Mark Eggleston | 3d137b7 | 2020-06-01 08:15:31 +0100 | [diff] [blame] | 9409 | if (code->expr2->rank |
| 9410 | && code->expr1->ts.type == BT_CLASS |
| 9411 | && CLASS_DATA (code->expr1)->as) |
Paul Thomas | a6b22ee | 2017-11-19 19:50:50 +0000 | [diff] [blame] | 9412 | CLASS_DATA (code->expr1)->as->rank = code->expr2->rank; |
| 9413 | |
Paul Thomas | e4821cd | 2013-01-04 20:50:15 +0000 | [diff] [blame] | 9414 | /* 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 Weil | f5dbb57 | 2010-05-10 14:54:25 +0200 | [diff] [blame] | 9422 | } |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9423 | else |
Paul Thomas | e4821cd | 2013-01-04 20:50:15 +0000 | [diff] [blame] | 9424 | { |
| 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9434 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9435 | /* Loop over TYPE IS / CLASS IS cases. */ |
| 9436 | for (body = code->block; body; body = body->block) |
| 9437 | { |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9438 | c = body->ext.block.case_list; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9439 | |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9440 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9465 | /* Check F03:C815. */ |
| 9466 | if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) |
Harald Anlauf | d8f6c48 | 2021-12-27 23:06:18 +0100 | [diff] [blame] | 9467 | && selector_type |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9468 | && !selector_type->attr.unlimited_polymorphic |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9469 | && !gfc_type_is_extensible (c->ts.u.derived)) |
| 9470 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 9471 | gfc_error ("Derived type %qs at %L must be extensible", |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9472 | c->ts.u.derived->name, &c->where); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9473 | error++; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9474 | continue; |
| 9475 | } |
| 9476 | |
| 9477 | /* Check F03:C816. */ |
Harald Anlauf | d8f6c48 | 2021-12-27 23:06:18 +0100 | [diff] [blame] | 9478 | if (c->ts.type != BT_UNKNOWN |
| 9479 | && selector_type && !selector_type->attr.unlimited_polymorphic |
Tobias Burnus | 55d8631 | 2013-01-07 09:36:16 +0100 | [diff] [blame] | 9480 | && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) |
| 9481 | || !gfc_type_is_extension_of (selector_type, c->ts.u.derived))) |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9482 | { |
Tobias Burnus | 55d8631 | 2013-01-07 09:36:16 +0100 | [diff] [blame] | 9483 | if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 9484 | gfc_error ("Derived type %qs at %L must be an extension of %qs", |
Tobias Burnus | 55d8631 | 2013-01-07 09:36:16 +0100 | [diff] [blame] | 9485 | c->ts.u.derived->name, &c->where, selector_type->name); |
| 9486 | else |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 9487 | gfc_error ("Unexpected intrinsic type %qs at %L", |
Tobias Burnus | 55d8631 | 2013-01-07 09:36:16 +0100 | [diff] [blame] | 9488 | gfc_basic_typename (c->ts.type), &c->where); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9489 | error++; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9490 | continue; |
| 9491 | } |
| 9492 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9493 | /* Check F03:C814. */ |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9494 | if (c->ts.type == BT_CHARACTER |
| 9495 | && (c->ts.u.cl->length != NULL || c->ts.deferred)) |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9496 | { |
| 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9503 | /* Intercept the DEFAULT case. */ |
| 9504 | if (c->ts.type == BT_UNKNOWN) |
| 9505 | { |
| 9506 | /* Check F03:C818. */ |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9507 | if (default_case) |
| 9508 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 9509 | gfc_error ("The DEFAULT CASE at %L cannot be followed " |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9510 | "by a second DEFAULT CASE at %L", |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9511 | &default_case->ext.block.case_list->where, &c->where); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9512 | error++; |
| 9513 | continue; |
| 9514 | } |
Daniel Kraft | 414e8be | 2010-09-26 21:25:52 +0200 | [diff] [blame] | 9515 | |
| 9516 | default_case = body; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9517 | } |
| 9518 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9519 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9520 | if (error > 0) |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9521 | return; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9522 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9523 | /* Transform SELECT TYPE statement to BLOCK and associate selector to |
Daniel Kraft | e5ca969 | 2010-09-03 10:01:51 +0200 | [diff] [blame] | 9524 | 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9528 | code->op = EXEC_BLOCK; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9529 | if (code->expr2) |
| 9530 | { |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9531 | gfc_association_list* assoc; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9532 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9533 | assoc = gfc_get_association_list (); |
| 9534 | assoc->st = code->expr1->symtree; |
| 9535 | assoc->target = gfc_copy_expr (code->expr2); |
Paul Thomas | c49ea23 | 2011-12-11 20:42:23 +0000 | [diff] [blame] | 9536 | assoc->target->where = code->expr2->where; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9537 | /* assoc->variable will be set by resolve_assoc_var. */ |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9538 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9539 | 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 Thomas | de514d4 | 2016-10-21 12:50:56 +0000 | [diff] [blame] | 9547 | /* 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9572 | /* Add EXEC_SELECT to switch on type. */ |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9573 | new_st = gfc_get_code (code->op); |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9574 | new_st->expr1 = code->expr1; |
| 9575 | new_st->expr2 = code->expr2; |
| 9576 | new_st->block = code->block; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9577 | code->expr1 = code->expr2 = NULL; |
| 9578 | code->block = NULL; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9579 | if (!ns->code) |
| 9580 | ns->code = new_st; |
| 9581 | else |
| 9582 | ns->code->next = new_st; |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9583 | code = new_st; |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9584 | code->op = EXEC_SELECT_TYPE; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9585 | |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9586 | /* 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 Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 9589 | gfc_add_vptr_component (code->expr1); |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9590 | code->expr1->rank = 0; |
| 9591 | code->expr1 = build_loc_call (code->expr1); |
| 9592 | selector_expr = code->expr1->value.function.actual->expr; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9593 | |
| 9594 | /* Loop over TYPE IS / CLASS IS cases. */ |
| 9595 | for (body = code->block; body; body = body->block) |
| 9596 | { |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9597 | gfc_symbol *vtab; |
| 9598 | gfc_expr *e; |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9599 | c = body->ext.block.case_list; |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 9600 | |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9601 | /* 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 Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9605 | { |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9606 | 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 Koenig | 6ef1366 | 2018-02-25 09:02:32 +0000 | [diff] [blame] | 9610 | c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL, |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9611 | 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 Koenig | 6ef1366 | 2018-02-25 09:02:32 +0000 | [diff] [blame] | 9619 | 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 Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9626 | } |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9627 | |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9628 | e = gfc_lval_expr_from_sym (vtab); |
| 9629 | c->low = build_loc_call (e); |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9630 | } |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9631 | else |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9632 | continue; |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 9633 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9634 | /* 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 Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9639 | if (c->ts.type == BT_CLASS) |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 9640 | sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9641 | else if (c->ts.type == BT_DERIVED) |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 9642 | sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9643 | else if (c->ts.type == BT_CHARACTER) |
| 9644 | { |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 9645 | HOST_WIDE_INT charlen = 0; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9646 | if (c->ts.u.cl && c->ts.u.cl->length |
| 9647 | && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 9648 | 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 Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9652 | } |
| 9653 | else |
| 9654 | sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), |
| 9655 | c->ts.kind); |
| 9656 | |
Janus Weil | 93d7668 | 2009-10-07 12:54:35 +0200 | [diff] [blame] | 9657 | st = gfc_find_symtree (ns->sym_root, name); |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9658 | gcc_assert (st->n.sym->assoc); |
Paul Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9659 | st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); |
| 9660 | st->n.sym->assoc->target->where = selector_expr->where; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 9661 | if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) |
Paul Thomas | de514d4 | 2016-10-21 12:50:56 +0000 | [diff] [blame] | 9662 | { |
| 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 Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9668 | |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9669 | new_st = gfc_get_code (EXEC_BLOCK); |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9670 | new_st->ext.block.ns = gfc_build_block_ns (ns); |
| 9671 | new_st->ext.block.ns->code = body->next; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9672 | body->next = new_st; |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9673 | |
| 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 Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 9676 | the error is diagnosed elsewhere. */ |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 9677 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9684 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9685 | |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9686 | /* Take out CLASS IS cases for separate treatment. */ |
| 9687 | body = code; |
| 9688 | while (body && body->block) |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9689 | { |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9690 | if (body->block->ext.block.case_list->ts.type == BT_CLASS) |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9691 | { |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9692 | /* Add to class_is list. */ |
| 9693 | if (class_is == NULL) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9694 | { |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9695 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9707 | } |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9708 | else |
| 9709 | body = body->block; |
| 9710 | } |
| 9711 | |
| 9712 | if (class_is) |
| 9713 | { |
| 9714 | gfc_symbol *vtab; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9715 | |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9716 | 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 Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9720 | tail->block = gfc_get_code (EXEC_SELECT_TYPE); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9721 | tail = tail->block; |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9722 | tail->ext.block.case_list = gfc_get_case (); |
| 9723 | tail->ext.block.case_list->ts.type = BT_UNKNOWN; |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9724 | tail->next = NULL; |
| 9725 | default_case = tail; |
| 9726 | } |
Paul Thomas | eece1eb | 2010-04-29 19:10:48 +0000 | [diff] [blame] | 9727 | |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9728 | /* 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 Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9741 | if ((*c1)->ext.block.case_list->ts.u.derived->hash_value |
| 9742 | == c2->ext.block.case_list->ts.u.derived->hash_value) |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9743 | { |
| 9744 | gfc_error ("Double CLASS IS block in SELECT TYPE " |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9745 | "statement at %L", |
| 9746 | &c2->ext.block.case_list->where); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9747 | return; |
| 9748 | } |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9749 | if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension |
| 9750 | < c2->ext.block.case_list->ts.u.derived->attr.extension) |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9751 | { |
| 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9762 | |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9763 | /* Generate IF chain. */ |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9764 | if_st = gfc_get_code (EXEC_IF); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9765 | new_st = if_st; |
| 9766 | for (body = class_is; body; body = body->block) |
| 9767 | { |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9768 | new_st->block = gfc_get_code (EXEC_IF); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9769 | new_st = new_st->block; |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9770 | /* 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 Thomas | dfd6231 | 2016-10-23 18:09:14 +0000 | [diff] [blame] | 9780 | new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree); |
Janus Weil | 2c3d0cd | 2010-12-12 22:14:13 +0100 | [diff] [blame] | 9781 | new_st->expr1->value.function.actual->expr->where = code->loc; |
Thomas Koenig | ce38615 | 2016-11-07 15:25:21 +0000 | [diff] [blame] | 9782 | new_st->expr1->where = code->loc; |
Janus Weil | b04533a | 2010-11-09 11:39:46 +0100 | [diff] [blame] | 9783 | gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); |
Tobias Burnus | 29a63d6 | 2011-01-13 17:32:33 +0100 | [diff] [blame] | 9784 | vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9785 | 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 Koenig | 39b4b34 | 2016-11-07 19:33:27 +0000 | [diff] [blame] | 9788 | new_st->expr1->value.function.actual->next->expr->where = code->loc; |
Francois-Xavier Coudert | a502683d | 2020-09-07 09:36:29 +0200 | [diff] [blame] | 9789 | /* 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 Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9795 | new_st->next = body->next; |
| 9796 | } |
| 9797 | if (default_case->next) |
| 9798 | { |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 9799 | new_st->block = gfc_get_code (EXEC_IF); |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9800 | new_st = new_st->block; |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9801 | new_st->next = default_case->next; |
| 9802 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9803 | |
Janus Weil | 7c1dab0 | 2009-11-30 21:43:06 +0100 | [diff] [blame] | 9804 | /* Replace CLASS DEFAULT code by the IF chain. */ |
| 9805 | default_case->next = if_st; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9806 | } |
| 9807 | |
Sandra Loosemore | 6791469 | 2019-01-09 16:37:45 -0500 | [diff] [blame] | 9808 | /* Resolve the internal code. This cannot be done earlier because |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 9809 | 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 Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9813 | |
Paul Thomas | de514d4 | 2016-10-21 12:50:56 +0000 | [diff] [blame] | 9814 | if (ref) |
| 9815 | free (ref); |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 9816 | } |
| 9817 | |
| 9818 | |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 9819 | /* Resolve a SELECT RANK statement. */ |
| 9820 | |
| 9821 | static void |
| 9822 | resolve_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 Anlauf | 77d455e | 2020-06-25 20:34:48 +0200 | [diff] [blame] | 9827 | char tname[GFC_MAX_SYMBOL_LEN + 7]; |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 9828 | 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üter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 9988 | /* Resolve a transfer statement. This is making sure that: |
| 9989 | -- a derived type being transferred has only non-pointer components |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 9990 | -- a derived type being transferred doesn't have private components, unless |
Erik Edelmann | 8451584 | 2005-09-23 00:52:09 +0300 | [diff] [blame] | 9991 | it's being transferred from the module where the type was defined |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 9992 | -- we're not trying to transfer a whole assumed size array. */ |
| 9993 | |
| 9994 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 9995 | resolve_transfer (gfc_code *code) |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 9996 | { |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 9997 | gfc_symbol *sym, *derived; |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 9998 | gfc_ref *ref; |
| 9999 | gfc_expr *exp; |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10000 | bool write = false; |
| 10001 | bool formatted = false; |
| 10002 | gfc_dt *dt = code->ext.dt; |
| 10003 | gfc_symbol *dtio_sub = NULL; |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10004 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10005 | exp = code->expr1; |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10006 | |
Jerry DeLisle | 771c572 | 2010-08-19 02:35:45 +0000 | [diff] [blame] | 10007 | while (exp != NULL && exp->expr_type == EXPR_OP |
| 10008 | && exp->value.op.op == INTRINSIC_PARENTHESES) |
| 10009 | exp = exp->value.op.op1; |
| 10010 | |
Paul Thomas | 49560f0 | 2013-12-01 11:37:09 +0000 | [diff] [blame] | 10011 | if (exp && exp->expr_type == EXPR_NULL |
| 10012 | && code->ext.dt) |
Tobias Burnus | ea8ad3e | 2011-09-14 08:26:07 +0200 | [diff] [blame] | 10013 | { |
Paul Thomas | 49560f0 | 2013-12-01 11:37:09 +0000 | [diff] [blame] | 10014 | gfc_error ("Invalid context for NULL () intrinsic at %L", |
| 10015 | &exp->where); |
Tobias Burnus | ea8ad3e | 2011-09-14 08:26:07 +0200 | [diff] [blame] | 10016 | return; |
| 10017 | } |
| 10018 | |
Jerry DeLisle | 771c572 | 2010-08-19 02:35:45 +0000 | [diff] [blame] | 10019 | if (exp == NULL || (exp->expr_type != EXPR_VARIABLE |
Tobias Burnus | 2f72ca1 | 2015-02-05 22:58:38 +0100 | [diff] [blame] | 10020 | && exp->expr_type != EXPR_FUNCTION |
Harald Anlauf | 89f20c9 | 2022-10-09 20:43:32 +0200 | [diff] [blame] | 10021 | && exp->expr_type != EXPR_ARRAY |
Tobias Burnus | 2f72ca1 | 2015-02-05 22:58:38 +0100 | [diff] [blame] | 10022 | && exp->expr_type != EXPR_STRUCTURE)) |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10023 | return; |
| 10024 | |
Daniel Kraft | 8e8dc06 | 2010-09-25 16:27:20 +0200 | [diff] [blame] | 10025 | /* 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 Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10028 | if (dt && dt->dt_io_kind->value.iokind == M_READ |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 10029 | && !gfc_check_vardef_context (exp, false, false, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10030 | _("item in READ"))) |
Daniel Kraft | 8e8dc06 | 2010-09-25 16:27:20 +0200 | [diff] [blame] | 10031 | return; |
| 10032 | |
Janus Weil | 3d6fc62 | 2018-08-25 17:41:34 +0200 | [diff] [blame] | 10033 | const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE |
| 10034 | || exp->expr_type == EXPR_FUNCTION |
Harald Anlauf | 89f20c9 | 2022-10-09 20:43:32 +0200 | [diff] [blame] | 10035 | || exp->expr_type == EXPR_ARRAY |
Janus Weil | 3d6fc62 | 2018-08-25 17:41:34 +0200 | [diff] [blame] | 10036 | ? &exp->ts : &exp->symtree->n.sym->ts; |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10037 | |
| 10038 | /* Go to actual component transferred. */ |
Jerry DeLisle | 6cf860a | 2010-10-06 22:38:30 +0000 | [diff] [blame] | 10039 | for (ref = exp->ref; ref; ref = ref->next) |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10040 | if (ref->type == REF_COMPONENT) |
| 10041 | ts = &ref->u.c.component->ts; |
| 10042 | |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10043 | if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE |
| 10044 | && (ts->type == BT_DERIVED || ts->type == BT_CLASS)) |
Tobias Burnus | d565654 | 2010-11-12 00:07:23 +0100 | [diff] [blame] | 10045 | { |
Steven G. Kargl | fb2974d | 2018-12-17 02:19:58 +0000 | [diff] [blame] | 10046 | derived = ts->u.derived; |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10047 | |
Jerry DeLisle | f208c5c | 2018-01-13 20:41:00 +0000 | [diff] [blame] | 10048 | /* Determine when to use the formatted DTIO procedure. */ |
| 10049 | if (dt && (dt->format_expr || dt->format_label)) |
| 10050 | formatted = true; |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10051 | |
| 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 DeLisle | 4a8d442 | 2016-09-23 20:36:21 +0000 | [diff] [blame] | 10058 | dt->udtio = exp; |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10059 | 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 Burnus | d565654 | 2010-11-12 00:07:23 +0100 | [diff] [blame] | 10078 | 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üter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10084 | if (ts->type == BT_DERIVED) |
| 10085 | { |
| 10086 | /* Check that transferred derived type doesn't contain POINTER |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10087 | 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üter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10090 | { |
Tobias Burnus | d8155bf | 2011-07-18 08:48:19 +0200 | [diff] [blame] | 10091 | 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üter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10094 | return; |
| 10095 | } |
| 10096 | |
Janus Weil | 357f98e | 2011-02-18 13:23:56 +0100 | [diff] [blame] | 10097 | /* 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 Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10105 | if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL) |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 10106 | { |
Tobias Burnus | d8155bf | 2011-07-18 08:48:19 +0200 | [diff] [blame] | 10107 | 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 Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 10110 | return; |
| 10111 | } |
| 10112 | |
Sandra Loosemore | 6791469 | 2019-01-09 16:37:45 -0500 | [diff] [blame] | 10113 | /* C_PTR and C_FUNPTR have private components which means they cannot |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 10114 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10118 | if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " |
| 10119 | "cannot have PRIVATE components", &code->loc)) |
Tobias Burnus | cadddfd | 2013-03-25 16:40:26 +0100 | [diff] [blame] | 10120 | return; |
| 10121 | } |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10122 | else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL) |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10123 | { |
| 10124 | gfc_error ("Data transfer element at %L cannot have " |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 10125 | "PRIVATE components unless it is processed by " |
| 10126 | "a defined input/output procedure", &code->loc); |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10127 | return; |
| 10128 | } |
| 10129 | } |
Paul Thomas | 4f283c4 | 2015-09-26 17:52:24 +0000 | [diff] [blame] | 10130 | |
Tobias Burnus | 2f72ca1 | 2015-02-05 22:58:38 +0100 | [diff] [blame] | 10131 | if (exp->expr_type == EXPR_STRUCTURE) |
| 10132 | return; |
| 10133 | |
Harald Anlauf | 89f20c9 | 2022-10-09 20:43:32 +0200 | [diff] [blame] | 10134 | if (exp->expr_type == EXPR_ARRAY) |
| 10135 | return; |
| 10136 | |
Tobias Burnus | 2f72ca1 | 2015-02-05 22:58:38 +0100 | [diff] [blame] | 10137 | sym = exp->symtree->n.sym; |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10138 | |
Janus Weil | f2ce74d | 2011-09-15 19:48:27 +0200 | [diff] [blame] | 10139 | if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref |
Tobias Schlüter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 10140 | && 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10149 | /*********** Toplevel code resolution subroutines ***********/ |
| 10150 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10151 | /* Find the set of labels that are reachable from this block. We also |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10152 | record the last statement in each block. */ |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10153 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10154 | static void |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10155 | find_reachable_labels (gfc_code *block) |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10156 | { |
| 10157 | gfc_code *c; |
| 10158 | |
| 10159 | if (!block) |
| 10160 | return; |
| 10161 | |
Trevor Saunders | 3fe793d | 2017-07-29 01:39:31 +0000 | [diff] [blame] | 10162 | cs_base->reachable_labels = bitmap_alloc (&labels_obstack); |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10163 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10164 | /* 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üter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10167 | for (c = block; c; c = c->next) |
| 10168 | { |
Mikael Morin | df1a69f | 2011-08-19 00:42:38 +0200 | [diff] [blame] | 10169 | if (c->here && c->op != EXEC_END_NESTED_BLOCK) |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10170 | bitmap_set_bit (cs_base->reachable_labels, c->here->value); |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10171 | } |
| 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 Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10182 | |
| 10183 | static void |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10184 | resolve_lock_unlock_event (gfc_code *code) |
Tobias Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 10185 | { |
Tobias Burnus | b511626 | 2014-06-17 22:54:14 +0200 | [diff] [blame] | 10186 | 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 Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10191 | 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 Burnus | 3b6fa7a | 2011-08-18 17:10:25 +0200 | [diff] [blame] | 10199 | gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", |
| 10200 | &code->expr1->where); |
Steven G. Kargl | 6b2e46b | 2015-12-04 16:37:54 +0000 | [diff] [blame] | 10201 | else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT) |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10202 | && (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 Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 10218 | |
| 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 Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10226 | if (code->expr2 |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 10227 | && !gfc_check_vardef_context (code->expr2, false, false, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10228 | _("STAT variable"))) |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10229 | return; |
| 10230 | |
Tobias Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 10231 | /* 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 Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10238 | if (code->expr3 |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 10239 | && !gfc_check_vardef_context (code->expr3, false, false, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10240 | _("ERRMSG variable"))) |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10241 | return; |
| 10242 | |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10243 | /* Check for LOCK the ACQUIRED_LOCK. */ |
| 10244 | if (code->op != EXEC_EVENT_WAIT && code->expr4 |
Tobias Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 10245 | && (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 Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10249 | |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10250 | if (code->op != EXEC_EVENT_WAIT && code->expr4 |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 10251 | && !gfc_check_vardef_context (code->expr4, false, false, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10252 | _("ACQUIRED_LOCK variable"))) |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 10253 | return; |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 10254 | |
| 10255 | /* Check for EVENT WAIT the UNTIL_COUNT. */ |
Andre Vehreschild | eaed322 | 2017-01-13 11:39:52 +0100 | [diff] [blame] | 10256 | 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 Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 10263 | } |
| 10264 | |
| 10265 | |
| 10266 | static void |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10267 | resolve_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 Burnus | f19626c | 2014-12-17 07:29:30 +0100 | [diff] [blame] | 10274 | if (flag_coarray != GFC_FCOARRAY_LIB) |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10275 | return; |
| 10276 | |
Tobias Burnus | 9de8e7a | 2014-08-15 18:33:08 +0200 | [diff] [blame] | 10277 | symtree = gfc_find_symtree (gfc_current_ns->sym_root, |
| 10278 | GFC_PREFIX ("lock_type")); |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10279 | if (symtree) |
| 10280 | lock_type = symtree->n.sym; |
| 10281 | else |
| 10282 | { |
Tobias Burnus | 9de8e7a | 2014-08-15 18:33:08 +0200 | [diff] [blame] | 10283 | if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree, |
| 10284 | false) != 0) |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10285 | 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 Burnus | 9de8e7a | 2014-08-15 18:33:08 +0200 | [diff] [blame] | 10293 | sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++); |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10294 | 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 Fanfarillo | 1fceb21 | 2015-12-15 06:19:21 -0700 | [diff] [blame] | 10310 | gfc_commit_symbols(); |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 10311 | } |
| 10312 | |
| 10313 | |
| 10314 | static void |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10315 | resolve_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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10328 | && gfc_simplify_expr (code->expr1, 0)) |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10329 | { |
| 10330 | gfc_constructor *cons; |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 10331 | cons = gfc_constructor_first (code->expr1->value.constructor); |
| 10332 | for (; cons; cons = gfc_constructor_next (cons)) |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10333 | 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. Kargl | 8909fee | 2018-05-24 22:28:33 +0000 | [diff] [blame] | 10341 | gfc_resolve_expr (code->expr2); |
Harald Anlauf | bbf19f9 | 2021-08-15 20:13:11 +0200 | [diff] [blame] | 10342 | 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 Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10351 | |
| 10352 | /* Check ERRMSG. */ |
Steven G. Kargl | 8909fee | 2018-05-24 22:28:33 +0000 | [diff] [blame] | 10353 | gfc_resolve_expr (code->expr3); |
Harald Anlauf | bbf19f9 | 2021-08-15 20:13:11 +0200 | [diff] [blame] | 10354 | 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 Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10363 | } |
| 10364 | |
| 10365 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10366 | /* Given a branch to a label, see if the branch is conforming. |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10367 | The code node describes where the branch is located. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10368 | |
| 10369 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10370 | resolve_branch (gfc_st_label *label, gfc_code *code) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10371 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10372 | code_stack *stack; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10373 | |
| 10374 | if (label == NULL) |
| 10375 | return; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10376 | |
| 10377 | /* Step one: is this a valid branching target? */ |
| 10378 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10379 | if (label->defined == ST_LABEL_UNKNOWN) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10380 | { |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10381 | gfc_error ("Label %d referenced at %L is never defined", label->value, |
Steven G. Kargl | 712dff3 | 2016-07-30 18:18:49 +0000 | [diff] [blame] | 10382 | &code->loc); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10383 | return; |
| 10384 | } |
| 10385 | |
Tobias Burnus | f3e7b9d | 2012-08-14 12:26:11 +0200 | [diff] [blame] | 10386 | if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10387 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 10388 | gfc_error ("Statement at %L is not a valid branch target statement " |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10389 | "for the branch statement at %L", &label->where, &code->loc); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10390 | return; |
| 10391 | } |
| 10392 | |
| 10393 | /* Step two: make sure this branch is not a branch to itself ;-) */ |
| 10394 | |
| 10395 | if (code->here == label) |
| 10396 | { |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 10397 | gfc_warning (0, |
| 10398 | "Branch at %L may result in an infinite loop", &code->loc); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10399 | return; |
| 10400 | } |
| 10401 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10402 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10405 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10406 | if (bitmap_bit_p (cs_base->reachable_labels, label->value)) |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10407 | { |
| 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 Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10412 | { |
| 10413 | if (stack->current->op == EXEC_CRITICAL |
| 10414 | && bitmap_bit_p (stack->reachable_labels, label->value)) |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 10415 | gfc_error ("GOTO statement at %L leaves CRITICAL construct for " |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10416 | "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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 10419 | gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10420 | "for label at %L", &code->loc, &label->where); |
| 10421 | } |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10422 | |
| 10423 | return; |
| 10424 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10425 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10426 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10429 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10430 | for (stack = cs_base; stack; stack = stack->prev) |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10431 | { |
| 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 10438 | gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10439 | " at %L", &code->loc, &label->where); |
| 10440 | return; |
| 10441 | } |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10442 | else if (stack->current->op == EXEC_DO_CONCURRENT) |
| 10443 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 10444 | gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10445 | "label at %L", &code->loc, &label->where); |
| 10446 | return; |
| 10447 | } |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10448 | } |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10449 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10450 | if (stack) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10451 | { |
Mikael Morin | df1a69f | 2011-08-19 00:42:38 +0200 | [diff] [blame] | 10452 | gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10453 | return; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10454 | } |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 10455 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10456 | /* 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áñez | 2a2703a | 2015-05-16 12:31:00 +0000 | [diff] [blame] | 10459 | gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 10460 | "as the GOTO statement at %L", &label->where, |
| 10461 | &code->loc); |
| 10462 | return; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10463 | } |
| 10464 | |
| 10465 | |
| 10466 | /* Check whether EXPR1 has the same shape as EXPR2. */ |
| 10467 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10468 | static bool |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10469 | resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) |
| 10470 | { |
| 10471 | mpz_t shape[GFC_MAX_DIMENSIONS]; |
| 10472 | mpz_t shape2[GFC_MAX_DIMENSIONS]; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10473 | bool result = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10474 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10483 | if (!gfc_array_dimen_size (expr1, i, &shape[i])) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10484 | goto ignore; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10485 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10486 | if (!gfc_array_dimen_size (expr2, i, &shape2[i])) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10487 | goto ignore; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10488 | |
| 10489 | if (mpz_cmp (shape[i], shape2[i])) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10490 | goto over; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10491 | } |
| 10492 | |
| 10493 | /* When either of the two expression is an assumed size array, we |
| 10494 | ignore the comparison of dimension sizes. */ |
| 10495 | ignore: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10496 | result = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10497 | |
| 10498 | over: |
Mikael Morin | 7d7212e | 2011-08-22 14:07:30 +0000 | [diff] [blame] | 10499 | gfc_clear_shape (shape, i); |
| 10500 | gfc_clear_shape (shape2, i); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10501 | 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 | |
| 10508 | static void |
| 10509 | resolve_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. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10520 | e = cblock->expr1; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10521 | else /* inner WHERE */ |
| 10522 | e = mask; |
| 10523 | |
| 10524 | while (cblock) |
| 10525 | { |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10526 | if (cblock->expr1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10527 | { |
| 10528 | /* Check if the mask-expr has a consistent shape with the |
| 10529 | outmost WHERE mask-expr. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10530 | if (!resolve_where_shape (cblock->expr1, e)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10531 | gfc_error ("WHERE mask at %L has inconsistent shape", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10532 | &cblock->expr1->where); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10533 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10534 | |
| 10535 | /* the assignment statement of a WHERE statement, or the first |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10536 | statement in where-body-construct of a WHERE construct */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10537 | cnext = cblock->next; |
| 10538 | while (cnext) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10539 | { |
| 10540 | switch (cnext->op) |
| 10541 | { |
| 10542 | /* WHERE assignment statement */ |
| 10543 | case EXEC_ASSIGN: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10544 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10545 | /* Check shape consistent for WHERE assignment target. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10546 | if (e && !resolve_where_shape (cnext->expr1, e)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10547 | gfc_error ("WHERE assignment target at %L has " |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10548 | "inconsistent shape", &cnext->expr1->where); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10549 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10550 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10551 | |
Paul Thomas | a00b8d1 | 2007-01-27 18:23:14 +0000 | [diff] [blame] | 10552 | case EXEC_ASSIGN_CALL: |
| 10553 | resolve_call (cnext); |
Daniel Franke | 42cd23c | 2008-01-25 16:55:47 -0500 | [diff] [blame] | 10554 | if (!cnext->resolved_sym->attr.elemental) |
Daniel Franke | ba6e57b | 2008-02-04 17:29:35 -0500 | [diff] [blame] | 10555 | gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", |
Daniel Franke | 42cd23c | 2008-01-25 16:55:47 -0500 | [diff] [blame] | 10556 | &cnext->ext.actual->expr->where); |
Paul Thomas | a00b8d1 | 2007-01-27 18:23:14 +0000 | [diff] [blame] | 10557 | break; |
| 10558 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10559 | /* WHERE or WHERE construct is part of a where-body-construct */ |
| 10560 | case EXEC_WHERE: |
| 10561 | resolve_where (cnext, e); |
| 10562 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10563 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10564 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10570 | } |
| 10571 | /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ |
| 10572 | cblock = cblock->block; |
| 10573 | } |
| 10574 | } |
| 10575 | |
| 10576 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10577 | /* Resolve assignment in FORALL construct. |
| 10578 | NVAR is the number of FORALL index variables, and VAR_EXPR records the |
| 10579 | FORALL index variables. */ |
| 10580 | |
| 10581 | static void |
| 10582 | gfc_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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10593 | variable. */ |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10594 | if ((code->expr1->expr_type == EXPR_VARIABLE) |
| 10595 | && (code->expr1->symtree->n.sym == forall_index)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10596 | gfc_error ("Assignment to a FORALL index variable at %L", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10597 | &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10598 | else |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10599 | { |
| 10600 | /* If one of the FORALL index variables doesn't appear in the |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 10601 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10604 | if (!find_forall_index (code->expr1, forall_index, 0)) |
Joseph Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 10605 | gfc_warning (0, "The FORALL with index %qs is not used on the " |
Paul Thomas | 67cec81 | 2008-11-03 06:44:47 +0000 | [diff] [blame] | 10606 | "left side of the assignment at %L and so might " |
| 10607 | "cause multiple assignment to this object", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10608 | var_expr[n]->symtree->name, &code->expr1->where); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10609 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10610 | } |
| 10611 | } |
| 10612 | |
| 10613 | |
| 10614 | /* Resolve WHERE statement in FORALL construct. */ |
| 10615 | |
| 10616 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10617 | gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, |
| 10618 | gfc_expr **var_expr) |
| 10619 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10620 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10627 | statement in where-body-construct of a WHERE construct */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10628 | cnext = cblock->next; |
| 10629 | while (cnext) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10630 | { |
| 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10637 | |
Paul Thomas | a00b8d1 | 2007-01-27 18:23:14 +0000 | [diff] [blame] | 10638 | /* WHERE operator assignment statement */ |
| 10639 | case EXEC_ASSIGN_CALL: |
| 10640 | resolve_call (cnext); |
Daniel Franke | 42cd23c | 2008-01-25 16:55:47 -0500 | [diff] [blame] | 10641 | if (!cnext->resolved_sym->attr.elemental) |
Daniel Franke | ba6e57b | 2008-02-04 17:29:35 -0500 | [diff] [blame] | 10642 | gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", |
Daniel Franke | 42cd23c | 2008-01-25 16:55:47 -0500 | [diff] [blame] | 10643 | &cnext->ext.actual->expr->where); |
Paul Thomas | a00b8d1 | 2007-01-27 18:23:14 +0000 | [diff] [blame] | 10644 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10645 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10646 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10650 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10651 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10658 | /* 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 | |
| 10669 | static void |
| 10670 | gfc_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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10678 | { |
| 10679 | case EXEC_ASSIGN: |
| 10680 | case EXEC_POINTER_ASSIGN: |
| 10681 | gfc_resolve_assign_in_forall (c, nvar, var_expr); |
| 10682 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10683 | |
Paul Thomas | a00b8d1 | 2007-01-27 18:23:14 +0000 | [diff] [blame] | 10684 | case EXEC_ASSIGN_CALL: |
| 10685 | resolve_call (c); |
| 10686 | break; |
| 10687 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10688 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10698 | /* The next statement in the FORALL body. */ |
| 10699 | c = c->next; |
| 10700 | } |
| 10701 | } |
| 10702 | |
| 10703 | |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10704 | /* Counts the number of iterators needed inside a forall construct, including |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10705 | nested forall constructs. This is used to allocate the needed memory |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10706 | in gfc_resolve_forall. */ |
| 10707 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10708 | static int |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10709 | gfc_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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10720 | |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10721 | code = code->block->next; |
| 10722 | |
| 10723 | while (code) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 10724 | { |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10725 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10738 | /* Given a FORALL construct, first resolve the FORALL iterator, then call |
| 10739 | gfc_resolve_forall_body to resolve the FORALL body. */ |
| 10740 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10741 | static void |
| 10742 | gfc_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 Anlauf | 8dc998f | 2016-11-20 18:43:16 +0000 | [diff] [blame] | 10747 | int i, old_nvar, tmp; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10748 | gfc_forall_iterator *fa; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10749 | |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10750 | old_nvar = nvar; |
| 10751 | |
Janus Weil | 9143aa5 | 2018-05-25 08:09:10 +0200 | [diff] [blame] | 10752 | if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) |
| 10753 | return; |
| 10754 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10755 | /* Start to resolve a FORALL construct */ |
| 10756 | if (forall_save == 0) |
| 10757 | { |
Harald Anlauf | 8dc998f | 2016-11-20 18:43:16 +0000 | [diff] [blame] | 10758 | /* Count the total number of FORALL indices in the nested FORALL |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10759 | construct in order to allocate the VAR_EXPR with proper size. */ |
| 10760 | total_var = gfc_count_forall_iterators (code); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10761 | |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 10762 | /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ |
Janne Blomqvist | 93acb62 | 2011-04-19 20:42:51 +0300 | [diff] [blame] | 10763 | var_expr = XCNEWVEC (gfc_expr *, total_var); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10764 | } |
| 10765 | |
Harald Anlauf | 8dc998f | 2016-11-20 18:43:16 +0000 | [diff] [blame] | 10766 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10768 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) |
| 10769 | { |
Harald Anlauf | 8dc998f | 2016-11-20 18:43:16 +0000 | [diff] [blame] | 10770 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10778 | /* Check if any outer FORALL index name is the same as the current |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10779 | one. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10780 | for (i = 0; i < nvar; i++) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10781 | { |
| 10782 | if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) |
Harald Anlauf | 8dc998f | 2016-11-20 18:43:16 +0000 | [diff] [blame] | 10783 | gfc_error ("An outer FORALL construct already has an index " |
| 10784 | "with this name %L", &fa->var->where); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10785 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10786 | |
| 10787 | /* Record the current FORALL index. */ |
| 10788 | var_expr[nvar] = gfc_copy_expr (fa->var); |
| 10789 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10790 | nvar++; |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10791 | |
| 10792 | /* No memory leak. */ |
| 10793 | gcc_assert (nvar <= total_var); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10794 | } |
| 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 Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10800 | gfc_resolve_blocks (code->block, ns); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10801 | |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10802 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10807 | |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10808 | 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 Meyering | cede950 | 2011-04-18 19:20:53 +0000 | [diff] [blame] | 10814 | free (var_expr); |
Mikael Morin | 0e6834a | 2008-10-31 16:37:17 +0100 | [diff] [blame] | 10815 | total_var = 0; |
| 10816 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10817 | } |
| 10818 | |
| 10819 | |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 10820 | /* Resolve a BLOCK construct statement. */ |
| 10821 | |
| 10822 | static void |
| 10823 | resolve_block_construct (gfc_code* code) |
| 10824 | { |
Daniel Kraft | 03af1e4 | 2010-06-10 16:47:49 +0200 | [diff] [blame] | 10825 | /* Resolve the BLOCK's namespace. */ |
| 10826 | gfc_resolve (code->ext.block.ns); |
Daniel Kraft | 52bf62f | 2010-08-15 21:46:21 +0200 | [diff] [blame] | 10827 | |
| 10828 | /* For an ASSOCIATE block, the associations (and their targets) are already |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 10829 | resolved during resolve_symbol. */ |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 10830 | } |
| 10831 | |
| 10832 | |
| 10833 | /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10834 | DO code nodes. */ |
| 10835 | |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10836 | void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10837 | gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10838 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10839 | bool t; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10840 | |
| 10841 | for (; b; b = b->block) |
| 10842 | { |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10843 | t = gfc_resolve_expr (b->expr1); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10844 | if (!gfc_resolve_expr (b->expr2)) |
| 10845 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10846 | |
| 10847 | switch (b->op) |
| 10848 | { |
| 10849 | case EXEC_IF: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10850 | if (t && b->expr1 != NULL |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10851 | && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10852 | gfc_error ("IF clause at %L requires a scalar LOGICAL expression", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10853 | &b->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10854 | break; |
| 10855 | |
| 10856 | case EXEC_WHERE: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10857 | if (t |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10858 | && b->expr1 != NULL |
| 10859 | && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10860 | gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 10861 | &b->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10862 | break; |
| 10863 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10864 | case EXEC_GOTO: |
Steven G. Kargl | 79bd194 | 2009-05-13 16:17:59 +0000 | [diff] [blame] | 10865 | resolve_branch (b->label1, b); |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 10866 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10867 | |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 10868 | case EXEC_BLOCK: |
| 10869 | resolve_block_construct (b); |
| 10870 | break; |
| 10871 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10872 | case EXEC_SELECT: |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 10873 | case EXEC_SELECT_TYPE: |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 10874 | case EXEC_SELECT_RANK: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10875 | case EXEC_FORALL: |
| 10876 | case EXEC_DO: |
| 10877 | case EXEC_DO_WHILE: |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 10878 | case EXEC_DO_CONCURRENT: |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 10879 | case EXEC_CRITICAL: |
Jakub Jelinek | 5e805e4 | 2005-11-21 23:03:56 +0100 | [diff] [blame] | 10880 | case EXEC_READ: |
| 10881 | case EXEC_WRITE: |
| 10882 | case EXEC_IOLENGTH: |
Jerry DeLisle | 6f0f0b2 | 2008-04-05 22:23:27 +0000 | [diff] [blame] | 10883 | case EXEC_WAIT: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10884 | break; |
| 10885 | |
Jakub Jelinek | f25f40b | 2016-08-31 20:42:08 +0200 | [diff] [blame] | 10886 | case EXEC_OMP_ATOMIC: |
| 10887 | case EXEC_OACC_ATOMIC: |
| 10888 | { |
Jakub Jelinek | f25f40b | 2016-08-31 20:42:08 +0200 | [diff] [blame] | 10889 | /* Verify this before calling gfc_resolve_code, which might |
| 10890 | change it. */ |
Tobias Burnus | 689407e | 2021-12-04 19:39:43 +0100 | [diff] [blame] | 10891 | gcc_assert (b->op == EXEC_OMP_ATOMIC |
| 10892 | || (b->next && b->next->op == EXEC_ASSIGN)); |
Jakub Jelinek | f25f40b | 2016-08-31 20:42:08 +0200 | [diff] [blame] | 10893 | } |
| 10894 | break; |
| 10895 | |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 10896 | case EXEC_OACC_PARALLEL_LOOP: |
| 10897 | case EXEC_OACC_PARALLEL: |
| 10898 | case EXEC_OACC_KERNELS_LOOP: |
| 10899 | case EXEC_OACC_KERNELS: |
Maciej W. Rozycki | 62aee28 | 2019-11-12 08:45:35 +0000 | [diff] [blame] | 10900 | case EXEC_OACC_SERIAL_LOOP: |
| 10901 | case EXEC_OACC_SERIAL: |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 10902 | 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 Philippidis | db941d7 | 2015-11-30 11:09:33 -0800 | [diff] [blame] | 10910 | case EXEC_OACC_ROUTINE: |
Tobias Burnus | e2a2284 | 2022-10-05 19:25:27 +0200 | [diff] [blame] | 10911 | case EXEC_OMP_ASSUME: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10912 | case EXEC_OMP_CRITICAL: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10913 | 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 Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10917 | case EXEC_OMP_DO: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 10918 | case EXEC_OMP_DO_SIMD: |
Tobias Burnus | 7716719 | 2021-08-20 12:12:51 +0200 | [diff] [blame] | 10919 | case EXEC_OMP_ERROR: |
Tobias Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 10920 | case EXEC_OMP_LOOP: |
Tobias Burnus | 53d5b59 | 2021-08-16 09:26:26 +0200 | [diff] [blame] | 10921 | case EXEC_OMP_MASKED: |
| 10922 | case EXEC_OMP_MASKED_TASKLOOP: |
| 10923 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10924 | case EXEC_OMP_MASTER: |
Tobias Burnus | f6bf436 | 2021-06-01 12:46:37 +0200 | [diff] [blame] | 10925 | case EXEC_OMP_MASTER_TASKLOOP: |
| 10926 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10927 | case EXEC_OMP_ORDERED: |
| 10928 | case EXEC_OMP_PARALLEL: |
| 10929 | case EXEC_OMP_PARALLEL_DO: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 10930 | case EXEC_OMP_PARALLEL_DO_SIMD: |
Tobias Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 10931 | case EXEC_OMP_PARALLEL_LOOP: |
Tobias Burnus | 53d5b59 | 2021-08-16 09:26:26 +0200 | [diff] [blame] | 10932 | case EXEC_OMP_PARALLEL_MASKED: |
| 10933 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
| 10934 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
Tobias Burnus | 0e3702f | 2021-05-14 19:21:47 +0200 | [diff] [blame] | 10935 | case EXEC_OMP_PARALLEL_MASTER: |
Tobias Burnus | f6bf436 | 2021-06-01 12:46:37 +0200 | [diff] [blame] | 10936 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
| 10937 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10938 | case EXEC_OMP_PARALLEL_SECTIONS: |
| 10939 | case EXEC_OMP_PARALLEL_WORKSHARE: |
| 10940 | case EXEC_OMP_SECTIONS: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 10941 | case EXEC_OMP_SIMD: |
Tobias Burnus | f8d535f | 2021-08-17 15:50:11 +0200 | [diff] [blame] | 10942 | case EXEC_OMP_SCOPE: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10943 | case EXEC_OMP_SINGLE: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10944 | case EXEC_OMP_TARGET: |
| 10945 | case EXEC_OMP_TARGET_DATA: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 10946 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 10951 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 10952 | case EXEC_OMP_TARGET_SIMD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10953 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 10958 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10959 | case EXEC_OMP_TARGET_UPDATE: |
Jakub Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 10960 | case EXEC_OMP_TASK: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 10961 | case EXEC_OMP_TASKGROUP: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 10962 | case EXEC_OMP_TASKLOOP: |
| 10963 | case EXEC_OMP_TASKLOOP_SIMD: |
Jakub Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 10964 | case EXEC_OMP_TASKWAIT: |
Jakub Jelinek | 20906c6 | 2011-08-02 18:13:29 +0200 | [diff] [blame] | 10965 | case EXEC_OMP_TASKYIELD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10966 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 10970 | case EXEC_OMP_TEAMS_LOOP: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 10971 | case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 10972 | case EXEC_OMP_WORKSHARE: |
| 10973 | break; |
| 10974 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10975 | default: |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 10976 | gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10977 | } |
| 10978 | |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 10979 | gfc_resolve_code (b->next, ns); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 10980 | } |
| 10981 | } |
| 10982 | |
| 10983 | |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 10984 | /* Does everything to resolve an ordinary assignment. Returns true |
Ralf Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 10985 | if this is an interface assignment. */ |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 10986 | static bool |
| 10987 | resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) |
| 10988 | { |
| 10989 | bool rval = false; |
| 10990 | gfc_expr *lhs; |
| 10991 | gfc_expr *rhs; |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 10992 | int n; |
| 10993 | gfc_ref *ref; |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 10994 | symbol_attribute attr; |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 10995 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 10996 | if (gfc_extend_assign (code, ns)) |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 10997 | { |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 10998 | gfc_expr** rhsptr; |
| 10999 | |
| 11000 | if (code->op == EXEC_ASSIGN_CALL) |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11001 | { |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 11002 | lhs = code->ext.actual->expr; |
| 11003 | rhsptr = &code->ext.actual->next->expr; |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 11004 | } |
| 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 Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11018 | } |
| 11019 | |
| 11020 | /* Make a temporary rhs when there is a default initializer |
| 11021 | and rhs is the same symbol as the lhs. */ |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 11022 | if ((*rhsptr)->expr_type == EXPR_VARIABLE |
| 11023 | && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED |
Daniel Franke | 16e520b | 2010-05-19 09:07:25 -0400 | [diff] [blame] | 11024 | && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 11025 | && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) |
| 11026 | *rhsptr = gfc_get_parentheses (*rhsptr); |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11027 | |
| 11028 | return true; |
| 11029 | } |
| 11030 | |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 11031 | lhs = code->expr1; |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11032 | rhs = code->expr2; |
| 11033 | |
Mark Eggleston | 2afeb1c | 2019-11-08 14:28:57 +0000 | [diff] [blame] | 11034 | if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) |
| 11035 | && rhs->ts.type == BT_CHARACTER |
Mark Eggleston | 32bef8f | 2019-11-25 10:36:25 +0000 | [diff] [blame] | 11036 | && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) |
Mark Eggleston | 2afeb1c | 2019-11-08 14:28:57 +0000 | [diff] [blame] | 11037 | { |
| 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 Burnus | 00a4618 | 2007-12-08 22:46:56 +0100 | [diff] [blame] | 11046 | /* Handle the case of a BOZ literal on the RHS. */ |
Steven G. Kargl | 8dc6316 | 2019-07-23 21:43:21 +0000 | [diff] [blame] | 11047 | if (rhs->ts.type == BT_BOZ) |
Tobias Burnus | 00a4618 | 2007-12-08 22:46:56 +0100 | [diff] [blame] | 11048 | { |
Steven G. Kargl | 8dc6316 | 2019-07-23 21:43:21 +0000 | [diff] [blame] | 11049 | 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 Burnus | c7abc45 | 2007-12-20 09:13:09 +0100 | [diff] [blame] | 11053 | return false; |
Steven G. Kargl | 8dc6316 | 2019-07-23 21:43:21 +0000 | [diff] [blame] | 11054 | |
| 11055 | switch (lhs->ts.type) |
Tobias Burnus | 4956b1f | 2007-12-14 16:11:17 +0100 | [diff] [blame] | 11056 | { |
Steven G. Kargl | 8dc6316 | 2019-07-23 21:43:21 +0000 | [diff] [blame] | 11057 | 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 Burnus | 4956b1f | 2007-12-14 16:11:17 +0100 | [diff] [blame] | 11067 | return false; |
| 11068 | } |
Tobias Burnus | 00a4618 | 2007-12-08 22:46:56 +0100 | [diff] [blame] | 11069 | } |
| 11070 | |
Steven G. Kargl | 8dc6316 | 2019-07-23 21:43:21 +0000 | [diff] [blame] | 11071 | if (lhs->ts.type == BT_CHARACTER && warn_character_truncation) |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11072 | { |
Janne Blomqvist | 6b271a2 | 2018-01-22 15:31:08 +0200 | [diff] [blame] | 11073 | HOST_WIDE_INT llen = 0, rlen = 0; |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 11074 | if (lhs->ts.u.cl != NULL |
| 11075 | && lhs->ts.u.cl->length != NULL |
| 11076 | && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
Janne Blomqvist | 6b271a2 | 2018-01-22 15:31:08 +0200 | [diff] [blame] | 11077 | llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer); |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11078 | |
| 11079 | if (rhs->expr_type == EXPR_CONSTANT) |
| 11080 | rlen = rhs->value.character.length; |
| 11081 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 11082 | else if (rhs->ts.u.cl != NULL |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 11083 | && rhs->ts.u.cl->length != NULL |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 11084 | && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
Janne Blomqvist | 6b271a2 | 2018-01-22 15:31:08 +0200 | [diff] [blame] | 11085 | rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer); |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11086 | |
| 11087 | if (rlen && llen && rlen > llen) |
Tobias Burnus | 4daa149 | 2014-11-25 23:33:32 +0100 | [diff] [blame] | 11088 | gfc_warning_now (OPT_Wcharacter_truncation, |
| 11089 | "CHARACTER expression will be truncated " |
Janne Blomqvist | 6b271a2 | 2018-01-22 15:31:08 +0200 | [diff] [blame] | 11090 | "in assignment (%ld/%ld) at %L", |
| 11091 | (long) llen, (long) rlen, &code->loc); |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11092 | } |
| 11093 | |
| 11094 | /* Ensure that a vector index expression for the lvalue is evaluated |
Paul Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 11095 | to a temporary if the lvalue symbol is referenced in it. */ |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11096 | 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 Thomas | 908a223 | 2007-11-27 20:47:55 +0000 | [diff] [blame] | 11102 | if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR |
Jakub Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 11103 | && gfc_find_sym_in_expr (lhs->symtree->n.sym, |
| 11104 | ref->u.ar.start[n])) |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11105 | ref->u.ar.start[n] |
| 11106 | = gfc_get_parentheses (ref->u.ar.start[n]); |
| 11107 | } |
| 11108 | } |
| 11109 | |
| 11110 | if (gfc_pure (NULL)) |
| 11111 | { |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11112 | if (lhs->ts.type == BT_DERIVED |
| 11113 | && lhs->expr_type == EXPR_VARIABLE |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 11114 | && lhs->ts.u.derived->attr.pointer_comp |
Tobias Burnus | 4eceddd | 2010-03-14 14:18:28 +0100 | [diff] [blame] | 11115 | && rhs->expr_type == EXPR_VARIABLE |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11116 | && (gfc_impure_variable (rhs->symtree->n.sym) |
| 11117 | || gfc_is_coindexed (rhs))) |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11118 | { |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11119 | /* 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 Rouson | 51a6a40 | 2019-10-13 17:16:40 +0000 | [diff] [blame] | 11126 | /* 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 Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11132 | &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 Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11141 | return rval; |
| 11142 | } |
| 11143 | } |
| 11144 | |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 11145 | 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 Burnus | 9964e83 | 2014-03-20 07:53:01 +0100 | [diff] [blame] | 11150 | gfc_unset_implicit_pure (NULL); |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 11151 | |
| 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 Burnus | 9964e83 | 2014-03-20 07:53:01 +0100 | [diff] [blame] | 11158 | gfc_unset_implicit_pure (NULL); |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 11159 | |
| 11160 | /* Fortran 2008, C1283. */ |
| 11161 | if (gfc_is_coindexed (lhs)) |
Tobias Burnus | 9964e83 | 2014-03-20 07:53:01 +0100 | [diff] [blame] | 11162 | gfc_unset_implicit_pure (NULL); |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 11163 | } |
| 11164 | |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 11165 | /* F2008, 7.2.1.2. */ |
| 11166 | attr = gfc_expr_attr (lhs); |
| 11167 | if (lhs->ts.type == BT_CLASS && attr.allocatable) |
Janus Weil | 0ae278e | 2009-10-16 23:10:43 +0200 | [diff] [blame] | 11168 | { |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 11169 | 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 Burnus | 203c7eb | 2014-12-16 20:24:50 +0100 | [diff] [blame] | 11178 | if (!flag_realloc_lhs) |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 11179 | { |
| 11180 | gfc_error ("Assignment to an allocatable polymorphic variable at %L " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 11181 | "requires %<-frealloc-lhs%>", &lhs->where); |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 11182 | return false; |
| 11183 | } |
Tobias Burnus | 83ba23b | 2013-09-18 20:14:57 +0200 | [diff] [blame] | 11184 | } |
| 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 Weil | 0ae278e | 2009-10-16 23:10:43 +0200 | [diff] [blame] | 11190 | return false; |
| 11191 | } |
| 11192 | |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 11193 | bool lhs_coindexed = gfc_is_coindexed (lhs); |
| 11194 | |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11195 | /* F2008, Section 7.2.1.2. */ |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 11196 | if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11197 | { |
Benno Schulenberg | 6726b90 | 2014-02-07 17:52:59 +0000 | [diff] [blame] | 11198 | gfc_error ("Coindexed variable must not have an allocatable ultimate " |
Tobias Burnus | d3a9eea | 2010-04-09 07:54:29 +0200 | [diff] [blame] | 11199 | "component in assignment at %L", &lhs->where); |
| 11200 | return false; |
| 11201 | } |
| 11202 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 11203 | /* Assign the 'data' of a class object to a derived type. */ |
| 11204 | if (lhs->ts.type == BT_DERIVED |
Paul Thomas | 5233d45 | 2017-11-05 14:32:05 +0000 | [diff] [blame] | 11205 | && rhs->ts.type == BT_CLASS |
| 11206 | && rhs->expr_type != EXPR_ARRAY) |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 11207 | gfc_add_data_component (rhs); |
| 11208 | |
Paul Thomas | 75382a9 | 2018-06-21 17:34:31 +0000 | [diff] [blame] | 11209 | /* Make sure there is a vtable and, in particular, a _copy for the |
| 11210 | rhs type. */ |
Paul Thomas | ce8dcc9 | 2020-12-18 14:00:11 +0000 | [diff] [blame] | 11211 | if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS) |
Paul Thomas | 75382a9 | 2018-06-21 17:34:31 +0000 | [diff] [blame] | 11212 | gfc_find_vtab (&rhs->ts); |
| 11213 | |
Andre Vehreschild | 3c9f509 | 2016-09-19 15:45:40 +0200 | [diff] [blame] | 11214 | 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 Burnus | b511626 | 2014-06-17 22:54:14 +0200 | [diff] [blame] | 11225 | /* 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 Burnus | 5c75088 | 2014-06-25 22:31:32 +0200 | [diff] [blame] | 11228 | 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 Vehreschild | 3c9f509 | 2016-09-19 15:45:40 +0200 | [diff] [blame] | 11231 | if (caf_convert_to_send) |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 11232 | { |
Tobias Burnus | b511626 | 2014-06-17 22:54:14 +0200 | [diff] [blame] | 11233 | 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 Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 11237 | 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 Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 11253 | return false; |
| 11254 | } |
| 11255 | |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 11256 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11257 | /* Add a component reference onto an expression. */ |
| 11258 | |
| 11259 | static void |
| 11260 | add_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 | |
| 11284 | static gfc_code * |
| 11285 | build_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 Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 11290 | this_code = gfc_get_code (op); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11291 | 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 | |
| 11308 | static gfc_expr* |
| 11309 | get_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 Burnus | bbf38bc | 2013-05-22 21:24:29 +0200 | [diff] [blame] | 11318 | sprintf (name, GFC_PREFIX("DA%d"), serial++); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11319 | gfc_get_sym_tree (name, ns, &tmp, false); |
| 11320 | gfc_add_type (tmp->n.sym, &e->ts, NULL); |
| 11321 | |
Paul Thomas | 18246c4 | 2018-12-23 17:35:13 +0000 | [diff] [blame] | 11322 | 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11327 | as = NULL; |
| 11328 | ref = NULL; |
| 11329 | aref = NULL; |
| 11330 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11331 | /* Obtain the arrayspec for the temporary. */ |
Paul Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 11332 | if (e->rank && e->expr_type != EXPR_ARRAY |
| 11333 | && e->expr_type != EXPR_FUNCTION |
| 11334 | && e->expr_type != EXPR_OP) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11335 | { |
| 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 Burnus | 9d82744 | 2013-06-14 13:24:27 +0200 | [diff] [blame] | 11354 | tmp->n.sym->attr.function = 0; |
Tobias Burnus | 2b0df0a | 2020-09-07 12:29:05 +0200 | [diff] [blame] | 11355 | tmp->n.sym->attr.proc_pointer = 0; |
Tobias Burnus | 9d82744 | 2013-06-14 13:24:27 +0200 | [diff] [blame] | 11356 | tmp->n.sym->attr.result = 0; |
| 11357 | tmp->n.sym->attr.flavor = FL_VARIABLE; |
Paul Thomas | 9caa7e0 | 2018-05-10 10:48:50 +0000 | [diff] [blame] | 11358 | tmp->n.sym->attr.dummy = 0; |
Tobias Burnus | 2b0df0a | 2020-09-07 12:29:05 +0200 | [diff] [blame] | 11359 | tmp->n.sym->attr.use_assoc = 0; |
Paul Thomas | 9caa7e0 | 2018-05-10 10:48:50 +0000 | [diff] [blame] | 11360 | tmp->n.sym->attr.intent = INTENT_UNKNOWN; |
Tobias Burnus | 9d82744 | 2013-06-14 13:24:27 +0200 | [diff] [blame] | 11361 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11362 | 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 Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 11370 | 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11380 | else |
| 11381 | tmp->n.sym->attr.dimension = 0; |
| 11382 | |
| 11383 | gfc_set_sym_referenced (tmp->n.sym); |
Tobias Burnus | 28a595f | 2013-05-22 14:43:55 +0200 | [diff] [blame] | 11384 | gfc_commit_symbol (tmp->n.sym); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11385 | 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 | |
| 11401 | static void |
| 11402 | add_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 | |
| 11416 | static int |
| 11417 | nonscalar_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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 11424 | if ((!gfc_bt_struct (c->ts.type) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11425 | || 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. Kargl | 6ff560c | 2015-09-21 21:40:26 +0000 | [diff] [blame] | 11452 | each pointer component, defined assignment for each nonpointer |
| 11453 | nonallocatable component of a type that has a type-bound defined |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11454 | 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 Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 11460 | by calling gfc_resolve_code. |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11461 | |
| 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 | */ |
| 11494 | static int component_assignment_level = 0; |
| 11495 | static gfc_code *tmp_head = NULL, *tmp_tail = NULL; |
| 11496 | |
| 11497 | static void |
| 11498 | generate_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 Myers | db30e21 | 2015-02-01 00:29:54 +0000 | [diff] [blame] | 11518 | gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not " |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11519 | "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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 11564 | if (!gfc_bt_struct (comp1->ts.type) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11565 | || 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 Burnus | e3ca3e7 | 2022-03-07 17:20:52 +0100 | [diff] [blame] | 11572 | /* Make an assignment for this component. */ |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11573 | 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 Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 11578 | this type. Otherwise, using the call from gfc_resolve_code, |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11579 | recurse into its components. */ |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 11580 | gfc_resolve_code (this_code, ns); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11581 | |
| 11582 | if (this_code->op == EXEC_ASSIGN_CALL) |
| 11583 | { |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 11584 | gfc_formal_arglist *dummy_args; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11585 | 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 Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 11603 | dummy_args = gfc_sym_get_dummy_args (rsym); |
| 11604 | if (dummy_args |
| 11605 | && dummy_args->sym->attr.intent == INTENT_INOUT) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11606 | { |
| 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 Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11618 | |
Tobias Burnus | d14fc2c | 2013-09-16 08:42:02 +0200 | [diff] [blame] | 11619 | /* 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 Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11623 | { |
| 11624 | gfc_code *block; |
Tobias Burnus | d14fc2c | 2013-09-16 08:42:02 +0200 | [diff] [blame] | 11625 | gfc_expr *e = |
| 11626 | gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); |
Tobias Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11627 | 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 Burnus | d14fc2c | 2013-09-16 08:42:02 +0200 | [diff] [blame] | 11631 | GFC_ISYM_ALLOCATED, "allocated", |
| 11632 | (*code)->loc, 1, e); |
Tobias Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11633 | block->block->next = temp_code; |
| 11634 | temp_code = block; |
| 11635 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11636 | 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 Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11644 | |
Tobias Burnus | d14fc2c | 2013-09-16 08:42:02 +0200 | [diff] [blame] | 11645 | /* 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 Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11650 | { |
| 11651 | gfc_code *block; |
Tobias Burnus | 71e482d | 2013-09-25 21:54:12 +0200 | [diff] [blame] | 11652 | gfc_expr *cond; |
| 11653 | |
| 11654 | cond = gfc_get_expr (); |
Tobias Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11655 | 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 Burnus | d14fc2c | 2013-09-16 08:42:02 +0200 | [diff] [blame] | 11661 | GFC_ISYM_ALLOCATED, "allocated", |
| 11662 | (*code)->loc, 1, gfc_copy_expr (t1)); |
Tobias Burnus | 5ef7093 | 2013-09-15 12:54:10 +0200 | [diff] [blame] | 11663 | 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11671 | } |
Tobias Burnus | 71e482d | 2013-09-25 21:54:12 +0200 | [diff] [blame] | 11672 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11673 | 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11694 | /* 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 Burnus | 71e482d | 2013-09-25 21:54:12 +0200 | [diff] [blame] | 11702 | // 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11724 | /* 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 Burnus | 71e482d | 2013-09-25 21:54:12 +0200 | [diff] [blame] | 11733 | if (head != tail) |
| 11734 | free (head); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 11735 | *code = tail; |
| 11736 | |
| 11737 | component_assignment_level--; |
| 11738 | } |
| 11739 | |
| 11740 | |
Paul Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 11741 | /* 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 | |
| 11747 | static bool |
| 11748 | resolve_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 Burnus | 2b0df0a | 2020-09-07 12:29:05 +0200 | [diff] [blame] | 11779 | tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns); |
Paul Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 11780 | |
| 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 Thomas | 78ab526 | 2015-11-15 14:07:52 +0000 | [diff] [blame] | 11801 | /* 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 | |
| 11805 | static bool |
| 11806 | deferred_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 Anlauf | 7bd4deb | 2022-09-15 22:06:53 +0200 | [diff] [blame] | 11813 | && (*code)->expr2->ts.type == BT_CHARACTER |
Paul Thomas | 78ab526 | 2015-11-15 14:07:52 +0000 | [diff] [blame] | 11814 | && (*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 Thomas | 524cee4 | 2019-02-23 13:18:47 +0000 | [diff] [blame] | 11820 | if (gfc_expr_attr ((*code)->expr1).pointer) |
| 11821 | return false; |
| 11822 | |
Paul Thomas | 78ab526 | 2015-11-15 14:07:52 +0000 | [diff] [blame] | 11823 | 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 Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 11849 | static bool |
| 11850 | check_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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11866 | /* Given a block of code, recursively resolve everything pointed to by this |
| 11867 | code block. */ |
| 11868 | |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 11869 | void |
| 11870 | gfc_resolve_code (gfc_code *code, gfc_namespace *ns) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11871 | { |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11872 | int omp_workshare_save; |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 11873 | int forall_save, do_concurrent_save; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11874 | code_stack frame; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 11875 | bool t; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11876 | |
| 11877 | frame.prev = cs_base; |
| 11878 | frame.head = code; |
| 11879 | cs_base = &frame; |
| 11880 | |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 11881 | find_reachable_labels (code); |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 11882 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11883 | for (; code; code = code->next) |
| 11884 | { |
| 11885 | frame.current = code; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 11886 | forall_save = forall_flag; |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 11887 | do_concurrent_save = gfc_do_concurrent_flag; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11888 | |
| 11889 | if (code->op == EXEC_FORALL) |
| 11890 | { |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11891 | forall_flag = 1; |
| 11892 | gfc_resolve_forall (code, ns, forall_save); |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 11893 | forall_flag = 2; |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11894 | } |
| 11895 | else if (code->block) |
| 11896 | { |
| 11897 | omp_workshare_save = -1; |
| 11898 | switch (code->op) |
| 11899 | { |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 11900 | case EXEC_OACC_PARALLEL_LOOP: |
| 11901 | case EXEC_OACC_PARALLEL: |
| 11902 | case EXEC_OACC_KERNELS_LOOP: |
| 11903 | case EXEC_OACC_KERNELS: |
Maciej W. Rozycki | 62aee28 | 2019-11-12 08:45:35 +0000 | [diff] [blame] | 11904 | case EXEC_OACC_SERIAL_LOOP: |
| 11905 | case EXEC_OACC_SERIAL: |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 11906 | 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 Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11911 | 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 Burnus | 61c2d47 | 2020-09-09 09:33:51 +0200 | [diff] [blame] | 11916 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| 11917 | case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11918 | case EXEC_OMP_PARALLEL: |
| 11919 | case EXEC_OMP_PARALLEL_DO: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 11920 | case EXEC_OMP_PARALLEL_DO_SIMD: |
Tobias Burnus | 53d5b59 | 2021-08-16 09:26:26 +0200 | [diff] [blame] | 11921 | case EXEC_OMP_PARALLEL_MASKED: |
| 11922 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
| 11923 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
Tobias Burnus | 0e3702f | 2021-05-14 19:21:47 +0200 | [diff] [blame] | 11924 | case EXEC_OMP_PARALLEL_MASTER: |
Tobias Burnus | f6bf436 | 2021-06-01 12:46:37 +0200 | [diff] [blame] | 11925 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
| 11926 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11927 | case EXEC_OMP_PARALLEL_SECTIONS: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 11928 | case EXEC_OMP_TARGET_PARALLEL: |
| 11929 | case EXEC_OMP_TARGET_PARALLEL_DO: |
| 11930 | case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 11931 | 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 Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 11936 | case EXEC_OMP_TASK: |
Jakub Jelinek | cd30a0b | 2017-10-19 09:38:59 +0200 | [diff] [blame] | 11937 | case EXEC_OMP_TASKLOOP: |
| 11938 | case EXEC_OMP_TASKLOOP_SIMD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 11939 | 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 Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11944 | omp_workshare_save = omp_workshare_flag; |
| 11945 | omp_workshare_flag = 0; |
| 11946 | gfc_resolve_omp_parallel_blocks (code, ns); |
| 11947 | break; |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 11948 | case EXEC_OMP_DISTRIBUTE: |
| 11949 | case EXEC_OMP_DISTRIBUTE_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11950 | case EXEC_OMP_DO: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 11951 | case EXEC_OMP_DO_SIMD: |
| 11952 | case EXEC_OMP_SIMD: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 11953 | case EXEC_OMP_TARGET_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11954 | gfc_resolve_omp_do_blocks (code, ns); |
| 11955 | break; |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 11956 | case EXEC_SELECT_TYPE: |
Paul Thomas | c4a67898 | 2020-12-27 14:59:38 +0000 | [diff] [blame] | 11957 | 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 Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 11960 | break; |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 11961 | case EXEC_DO_CONCURRENT: |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 11962 | gfc_do_concurrent_flag = 1; |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 11963 | gfc_resolve_blocks (code->block, ns); |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 11964 | gfc_do_concurrent_flag = 2; |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 11965 | break; |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11966 | case EXEC_OMP_WORKSHARE: |
| 11967 | omp_workshare_save = omp_workshare_flag; |
| 11968 | omp_workshare_flag = 1; |
Tobias Burnus | eea58ad | 2012-05-30 08:26:09 +0200 | [diff] [blame] | 11969 | /* FALL THROUGH */ |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 11970 | 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 Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 11978 | start: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 11979 | t = true; |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 11980 | if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 11981 | t = gfc_resolve_expr (code->expr1); |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 11982 | forall_flag = forall_save; |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 11983 | gfc_do_concurrent_flag = do_concurrent_save; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 11984 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 11985 | if (!gfc_resolve_expr (code->expr2)) |
| 11986 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11987 | |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 11988 | if (code->op == EXEC_ALLOCATE |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 11989 | && !gfc_resolve_expr (code->expr3)) |
| 11990 | t = false; |
Janus Weil | 8460475b4 | 2009-10-23 13:01:38 +0200 | [diff] [blame] | 11991 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11992 | switch (code->op) |
| 11993 | { |
| 11994 | case EXEC_NOP: |
Tobias Schlüter | d80c695 | 2009-03-29 19:15:48 +0200 | [diff] [blame] | 11995 | case EXEC_END_BLOCK: |
Mikael Morin | df1a69f | 2011-08-19 00:42:38 +0200 | [diff] [blame] | 11996 | case EXEC_END_NESTED_BLOCK: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11997 | case EXEC_CYCLE: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 11998 | case EXEC_PAUSE: |
Harald Anlauf | 916b809 | 2022-02-23 23:08:29 +0100 | [diff] [blame] | 11999 | break; |
| 12000 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12001 | case EXEC_STOP: |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 12002 | case EXEC_ERROR_STOP: |
Harald Anlauf | 916b809 | 2022-02-23 23:08:29 +0100 | [diff] [blame] | 12003 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12010 | case EXEC_EXIT: |
| 12011 | case EXEC_CONTINUE: |
| 12012 | case EXEC_DT_END: |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 12013 | case EXEC_ASSIGN_CALL: |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 12014 | break; |
| 12015 | |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 12016 | case EXEC_CRITICAL: |
Tobias Burnus | bc0229f | 2014-08-14 20:39:15 +0200 | [diff] [blame] | 12017 | resolve_critical (code); |
Tobias Burnus | d0a4a61 | 2010-04-06 18:26:02 +0200 | [diff] [blame] | 12018 | break; |
| 12019 | |
| 12020 | case EXEC_SYNC_ALL: |
| 12021 | case EXEC_SYNC_IMAGES: |
| 12022 | case EXEC_SYNC_MEMORY: |
| 12023 | resolve_sync (code); |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12024 | break; |
| 12025 | |
Tobias Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 12026 | case EXEC_LOCK: |
| 12027 | case EXEC_UNLOCK: |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 12028 | case EXEC_EVENT_POST: |
| 12029 | case EXEC_EVENT_WAIT: |
| 12030 | resolve_lock_unlock_event (code); |
Tobias Burnus | 5493aa1 | 2011-06-08 08:28:41 +0200 | [diff] [blame] | 12031 | break; |
| 12032 | |
Andre Vehreschild | ef78bc3 | 2017-03-05 12:35:47 +0100 | [diff] [blame] | 12033 | case EXEC_FAIL_IMAGE: |
Harald Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 12034 | break; |
| 12035 | |
Damian Rouson | f8862a1 | 2018-01-26 20:14:09 +0000 | [diff] [blame] | 12036 | case EXEC_FORM_TEAM: |
Harald Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 12037 | 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 Rouson | f8862a1 | 2018-01-26 20:14:09 +0000 | [diff] [blame] | 12044 | case EXEC_CHANGE_TEAM: |
Harald Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 12045 | check_team (code->expr1, "CHANGE TEAM"); |
| 12046 | break; |
| 12047 | |
Damian Rouson | f8862a1 | 2018-01-26 20:14:09 +0000 | [diff] [blame] | 12048 | case EXEC_END_TEAM: |
Harald Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 12049 | break; |
| 12050 | |
Damian Rouson | f8862a1 | 2018-01-26 20:14:09 +0000 | [diff] [blame] | 12051 | case EXEC_SYNC_TEAM: |
Harald Anlauf | 5edd080 | 2022-05-09 22:14:21 +0200 | [diff] [blame] | 12052 | check_team (code->expr1, "SYNC TEAM"); |
Andre Vehreschild | ef78bc3 | 2017-03-05 12:35:47 +0100 | [diff] [blame] | 12053 | break; |
| 12054 | |
Paul Brook | 3d79abb | 2004-08-17 15:34:12 +0000 | [diff] [blame] | 12055 | case EXEC_ENTRY: |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12056 | /* Keep track of which entry we are up to. */ |
| 12057 | current_entry_id = code->ext.entry->id; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12058 | break; |
| 12059 | |
| 12060 | case EXEC_WHERE: |
| 12061 | resolve_where (code, NULL); |
| 12062 | break; |
| 12063 | |
| 12064 | case EXEC_GOTO: |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12065 | if (code->expr1 != NULL) |
Feng Wang | ce2df7c | 2005-03-15 02:52:38 +0000 | [diff] [blame] | 12066 | { |
Harald Anlauf | 824084e | 2020-07-06 18:52:39 +0200 | [diff] [blame] | 12067 | 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 12079 | gfc_error ("Variable %qs has not been assigned a target " |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12080 | "label at %L", code->expr1->symtree->n.sym->name, |
| 12081 | &code->expr1->where); |
Feng Wang | ce2df7c | 2005-03-15 02:52:38 +0000 | [diff] [blame] | 12082 | } |
| 12083 | else |
Steven G. Kargl | 79bd194 | 2009-05-13 16:17:59 +0000 | [diff] [blame] | 12084 | resolve_branch (code->label1, code); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12085 | break; |
| 12086 | |
| 12087 | case EXEC_RETURN: |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12088 | if (code->expr1 != NULL |
| 12089 | && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) |
Paul Thomas | b639882 | 2006-05-15 17:16:26 +0000 | [diff] [blame] | 12090 | gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12091 | "INTEGER return specifier", &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12092 | break; |
| 12093 | |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12094 | case EXEC_INIT_ASSIGN: |
Tobias Burnus | 5c71a5e | 2009-05-13 16:52:54 +0200 | [diff] [blame] | 12095 | case EXEC_END_PROCEDURE: |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12096 | break; |
| 12097 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12098 | case EXEC_ASSIGN: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12099 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12100 | break; |
| 12101 | |
Tobias Burnus | ba9fa68 | 2020-12-17 10:39:09 +0100 | [diff] [blame] | 12102 | if (code->expr1->ts.type == BT_CLASS) |
| 12103 | gfc_find_vtab (&code->expr2->ts); |
| 12104 | |
Tobias Burnus | b511626 | 2014-06-17 22:54:14 +0200 | [diff] [blame] | 12105 | /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on |
Joost VandeVondele | 1cc0e19 | 2014-09-20 11:48:00 +0000 | [diff] [blame] | 12106 | the LHS. */ |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 12107 | 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 Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 12112 | /* 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 Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 12120 | if (!gfc_check_vardef_context (code->expr1, false, false, false, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12121 | _("assignment"))) |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12122 | break; |
| 12123 | |
Paul Thomas | c542246 | 2007-10-21 18:10:00 +0000 | [diff] [blame] | 12124 | if (resolve_ordinary_assign (code, ns)) |
Janus Weil | 664e411 | 2009-09-11 00:47:03 +0200 | [diff] [blame] | 12125 | { |
Tobias Burnus | 582776e | 2021-05-17 13:20:27 +0200 | [diff] [blame] | 12126 | if (omp_workshare_flag) |
| 12127 | { |
| 12128 | gfc_error ("Expected intrinsic assignment in OMP WORKSHARE " |
| 12129 | "at %L", &code->loc); |
| 12130 | break; |
| 12131 | } |
Janus Weil | 664e411 | 2009-09-11 00:47:03 +0200 | [diff] [blame] | 12132 | if (code->op == EXEC_COMPCALL) |
| 12133 | goto compcall; |
| 12134 | else |
| 12135 | goto call; |
| 12136 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12137 | |
Paul Thomas | 78ab526 | 2015-11-15 14:07:52 +0000 | [diff] [blame] | 12138 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12143 | /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ |
Tobias Burnus | 8a8d1a1 | 2014-05-08 19:00:07 +0200 | [diff] [blame] | 12144 | if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED |
Paul Thomas | 7912411 | 2015-09-28 21:18:38 +0000 | [diff] [blame] | 12145 | && code->expr1->ts.u.derived |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12146 | && code->expr1->ts.u.derived->attr.defined_assign_comp) |
| 12147 | generate_component_assignments (&code, ns); |
| 12148 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12149 | break; |
| 12150 | |
| 12151 | case EXEC_LABEL_ASSIGN: |
Steven G. Kargl | 79bd194 | 2009-05-13 16:17:59 +0000 | [diff] [blame] | 12152 | if (code->label1->defined == ST_LABEL_UNKNOWN) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12153 | gfc_error ("Label %d referenced at %L is never defined", |
Steven G. Kargl | 79bd194 | 2009-05-13 16:17:59 +0000 | [diff] [blame] | 12154 | code->label1->value, &code->label1->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12155 | if (t |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12156 | && (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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12159 | != gfc_default_integer_kind |
Harald Anlauf | 1fa08dc | 2020-07-08 20:53:12 +0200 | [diff] [blame] | 12160 | || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12161 | || code->expr1->symtree->n.sym->as != NULL)) |
Tobias Schlüter | 40f2165 | 2004-12-08 13:27:54 +0100 | [diff] [blame] | 12162 | gfc_error ("ASSIGN statement at %L requires a scalar " |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12163 | "default INTEGER variable", &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12164 | break; |
| 12165 | |
| 12166 | case EXEC_POINTER_ASSIGN: |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12167 | { |
| 12168 | gfc_expr* e; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12169 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12170 | if (!t) |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12171 | 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 Burnus | 57bf28ea | 2012-10-28 17:57:12 +0100 | [diff] [blame] | 12178 | t = gfc_check_vardef_context (e, true, false, false, |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 12179 | _("pointer assignment")); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12180 | if (t) |
Tobias Burnus | 57bf28ea | 2012-10-28 17:57:12 +0100 | [diff] [blame] | 12181 | t = gfc_check_vardef_context (e, false, false, false, |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 12182 | _("pointer assignment")); |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12183 | gfc_free_expr (e); |
Thomas Koenig | 83fad92 | 2018-11-18 09:16:19 +0000 | [diff] [blame] | 12184 | |
| 12185 | t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; |
| 12186 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12187 | if (!t) |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12188 | break; |
| 12189 | |
Andre Vehreschild | 574284e | 2016-10-22 14:33:38 +0200 | [diff] [blame] | 12190 | /* Assigning a class object always is a regular assign. */ |
| 12191 | if (code->expr2->ts.type == BT_CLASS |
Paul Thomas | da3723a | 2017-10-02 18:17:39 +0000 | [diff] [blame] | 12192 | && code->expr1->ts.type == BT_CLASS |
José Rui Faustino de Sousa | 98c5b59 | 2021-04-16 16:17:21 +0000 | [diff] [blame] | 12193 | && CLASS_DATA (code->expr2) |
Andre Vehreschild | 574284e | 2016-10-22 14:33:38 +0200 | [diff] [blame] | 12194 | && !CLASS_DATA (code->expr2)->attr.dimension |
Andre Vehreschild | 574284e | 2016-10-22 14:33:38 +0200 | [diff] [blame] | 12195 | && !(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 Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12200 | break; |
| 12201 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12202 | |
| 12203 | case EXEC_ARITHMETIC_IF: |
Steven G. Kargl | e2eb080 | 2015-09-21 18:09:13 +0000 | [diff] [blame] | 12204 | { |
| 12205 | gfc_expr *e = code->expr1; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12206 | |
Steven G. Kargl | 2d2de60 | 2015-09-25 22:30:26 +0000 | [diff] [blame] | 12207 | gfc_resolve_expr (e); |
| 12208 | if (e->expr_type == EXPR_NULL) |
| 12209 | gfc_error ("Invalid NULL at %L", &e->where); |
| 12210 | |
Steven G. Kargl | e2eb080 | 2015-09-21 18:09:13 +0000 | [diff] [blame] | 12211 | 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. Kargl | 2d2de60 | 2015-09-25 22:30:26 +0000 | [diff] [blame] | 12214 | "REAL or INTEGER expression", &e->where); |
Steven G. Kargl | e2eb080 | 2015-09-21 18:09:13 +0000 | [diff] [blame] | 12215 | |
| 12216 | resolve_branch (code->label1, code); |
| 12217 | resolve_branch (code->label2, code); |
| 12218 | resolve_branch (code->label3, code); |
| 12219 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12220 | break; |
| 12221 | |
| 12222 | case EXEC_IF: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12223 | if (t && code->expr1 != NULL |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12224 | && (code->expr1->ts.type != BT_LOGICAL |
| 12225 | || code->expr1->rank != 0)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12226 | gfc_error ("IF clause at %L requires a scalar LOGICAL expression", |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12227 | &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12228 | break; |
| 12229 | |
| 12230 | case EXEC_CALL: |
| 12231 | call: |
| 12232 | resolve_call (code); |
| 12233 | break; |
| 12234 | |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 12235 | case EXEC_COMPCALL: |
Janus Weil | 664e411 | 2009-09-11 00:47:03 +0200 | [diff] [blame] | 12236 | compcall: |
Paul Thomas | 6a943ee | 2010-03-12 22:00:52 +0000 | [diff] [blame] | 12237 | resolve_typebound_subroutine (code); |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 12238 | break; |
| 12239 | |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 12240 | case EXEC_CALL_PPC: |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 12241 | resolve_ppc_call (code); |
Janus Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 12242 | break; |
| 12243 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12244 | case EXEC_SELECT: |
| 12245 | /* Select is complicated. Also, a SELECT construct could be |
| 12246 | a transformed computed GOTO. */ |
Janus Weil | ad3e2ad | 2013-01-23 22:38:40 +0100 | [diff] [blame] | 12247 | resolve_select (code, false); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12248 | break; |
| 12249 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 12250 | case EXEC_SELECT_TYPE: |
Daniel Kraft | 8c91ab3 | 2010-09-23 10:37:54 +0200 | [diff] [blame] | 12251 | resolve_select_type (code, ns); |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 12252 | break; |
| 12253 | |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 12254 | case EXEC_SELECT_RANK: |
| 12255 | resolve_select_rank (code, ns); |
| 12256 | break; |
| 12257 | |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 12258 | case EXEC_BLOCK: |
Daniel Kraft | 52bf62f | 2010-08-15 21:46:21 +0200 | [diff] [blame] | 12259 | resolve_block_construct (code); |
Daniel Kraft | 9abe5e5 | 2009-09-29 09:42:42 +0200 | [diff] [blame] | 12260 | break; |
| 12261 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12262 | case EXEC_DO: |
| 12263 | if (code->ext.iterator != NULL) |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12264 | { |
| 12265 | gfc_iterator *iter = code->ext.iterator; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12266 | if (gfc_resolve_iterator (iter, true, false)) |
Jakub Jelinek | cd30a0b | 2017-10-19 09:38:59 +0200 | [diff] [blame] | 12267 | gfc_resolve_do_iterator (code, iter->var->symtree->n.sym, |
| 12268 | true); |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12269 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12270 | break; |
| 12271 | |
| 12272 | case EXEC_DO_WHILE: |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12273 | if (code->expr1 == NULL) |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 12274 | gfc_internal_error ("gfc_resolve_code(): No expression on " |
| 12275 | "DO WHILE"); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12276 | if (t |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12277 | && (code->expr1->rank != 0 |
| 12278 | || code->expr1->ts.type != BT_LOGICAL)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12279 | gfc_error ("Exit condition of DO WHILE loop at %L must be " |
Steven G. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12280 | "a scalar LOGICAL expression", &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12281 | break; |
| 12282 | |
| 12283 | case EXEC_ALLOCATE: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12284 | if (t) |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 12285 | resolve_allocate_deallocate (code, "ALLOCATE"); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12286 | |
| 12287 | break; |
| 12288 | |
| 12289 | case EXEC_DEALLOCATE: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12290 | if (t) |
Paul Thomas | b9332b0 | 2008-02-03 11:29:27 +0000 | [diff] [blame] | 12291 | resolve_allocate_deallocate (code, "DEALLOCATE"); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12292 | |
| 12293 | break; |
| 12294 | |
| 12295 | case EXEC_OPEN: |
Fritz Reese | 44facdb | 2020-04-09 16:55:44 -0400 | [diff] [blame] | 12296 | if (!gfc_resolve_open (code->ext.open, &code->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12297 | break; |
| 12298 | |
| 12299 | resolve_branch (code->ext.open->err, code); |
| 12300 | break; |
| 12301 | |
| 12302 | case EXEC_CLOSE: |
Fritz Reese | 44facdb | 2020-04-09 16:55:44 -0400 | [diff] [blame] | 12303 | if (!gfc_resolve_close (code->ext.close, &code->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12304 | 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 Blomqvist | 6403ec5 | 2005-08-08 01:56:19 +0300 | [diff] [blame] | 12312 | case EXEC_FLUSH: |
Steven G. Kargl | 3d07fb2 | 2018-12-11 23:13:19 +0000 | [diff] [blame] | 12313 | if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12314 | break; |
| 12315 | |
| 12316 | resolve_branch (code->ext.filepos->err, code); |
| 12317 | break; |
| 12318 | |
| 12319 | case EXEC_INQUIRE: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12320 | if (!gfc_resolve_inquire (code->ext.inquire)) |
Janne Blomqvist | 8750f9c | 2004-06-22 03:43:55 +0300 | [diff] [blame] | 12321 | break; |
| 12322 | |
| 12323 | resolve_branch (code->ext.inquire->err, code); |
| 12324 | break; |
| 12325 | |
| 12326 | case EXEC_IOLENGTH: |
Paul Brook | 6e45f57 | 2004-09-08 14:33:03 +0000 | [diff] [blame] | 12327 | gcc_assert (code->ext.inquire != NULL); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12328 | if (!gfc_resolve_inquire (code->ext.inquire)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12329 | break; |
| 12330 | |
| 12331 | resolve_branch (code->ext.inquire->err, code); |
| 12332 | break; |
| 12333 | |
Jerry DeLisle | 6f0f0b2 | 2008-04-05 22:23:27 +0000 | [diff] [blame] | 12334 | case EXEC_WAIT: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12335 | if (!gfc_resolve_wait (code->ext.wait)) |
Jerry DeLisle | 6f0f0b2 | 2008-04-05 22:23:27 +0000 | [diff] [blame] | 12336 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12343 | case EXEC_READ: |
| 12344 | case EXEC_WRITE: |
Fritz Reese | 44facdb | 2020-04-09 16:55:44 -0400 | [diff] [blame] | 12345 | if (!gfc_resolve_dt (code, code->ext.dt, &code->loc)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12346 | 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üter | 0e6928d | 2004-09-01 23:07:39 +0200 | [diff] [blame] | 12353 | case EXEC_TRANSFER: |
| 12354 | resolve_transfer (code); |
| 12355 | break; |
| 12356 | |
Tobias Burnus | 8c6a85e | 2011-09-08 08:38:13 +0200 | [diff] [blame] | 12357 | case EXEC_DO_CONCURRENT: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12358 | case EXEC_FORALL: |
| 12359 | resolve_forall_iterators (code->ext.forall_iterator); |
| 12360 | |
Tobias Burnus | d565654 | 2010-11-12 00:07:23 +0100 | [diff] [blame] | 12361 | 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. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12364 | "expression", &code->expr1->where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12365 | break; |
| 12366 | |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 12367 | case EXEC_OACC_PARALLEL_LOOP: |
| 12368 | case EXEC_OACC_PARALLEL: |
| 12369 | case EXEC_OACC_KERNELS_LOOP: |
| 12370 | case EXEC_OACC_KERNELS: |
Maciej W. Rozycki | 62aee28 | 2019-11-12 08:45:35 +0000 | [diff] [blame] | 12371 | case EXEC_OACC_SERIAL_LOOP: |
| 12372 | case EXEC_OACC_SERIAL: |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 12373 | 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 Schwinge | 4bf9e5a | 2015-11-03 12:28:22 +0100 | [diff] [blame] | 12381 | case EXEC_OACC_ATOMIC: |
James Norris | dc7a8b4 | 2015-11-22 16:45:38 +0000 | [diff] [blame] | 12382 | case EXEC_OACC_DECLARE: |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 12383 | gfc_resolve_oacc_directive (code, ns); |
| 12384 | break; |
| 12385 | |
Tobias Burnus | e2a2284 | 2022-10-05 19:25:27 +0200 | [diff] [blame] | 12386 | case EXEC_OMP_ASSUME: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12387 | case EXEC_OMP_ATOMIC: |
| 12388 | case EXEC_OMP_BARRIER: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 12389 | case EXEC_OMP_CANCEL: |
| 12390 | case EXEC_OMP_CANCELLATION_POINT: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12391 | case EXEC_OMP_CRITICAL: |
| 12392 | case EXEC_OMP_FLUSH: |
Tobias Burnus | a61c496 | 2021-04-21 10:58:29 +0200 | [diff] [blame] | 12393 | case EXEC_OMP_DEPOBJ: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 12394 | 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 Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12398 | case EXEC_OMP_DO: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 12399 | case EXEC_OMP_DO_SIMD: |
Tobias Burnus | 7716719 | 2021-08-20 12:12:51 +0200 | [diff] [blame] | 12400 | case EXEC_OMP_ERROR: |
Tobias Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 12401 | case EXEC_OMP_LOOP: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12402 | case EXEC_OMP_MASTER: |
Tobias Burnus | f6bf436 | 2021-06-01 12:46:37 +0200 | [diff] [blame] | 12403 | case EXEC_OMP_MASTER_TASKLOOP: |
| 12404 | case EXEC_OMP_MASTER_TASKLOOP_SIMD: |
Tobias Burnus | 53d5b59 | 2021-08-16 09:26:26 +0200 | [diff] [blame] | 12405 | case EXEC_OMP_MASKED: |
| 12406 | case EXEC_OMP_MASKED_TASKLOOP: |
| 12407 | case EXEC_OMP_MASKED_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12408 | case EXEC_OMP_ORDERED: |
Tobias Burnus | 005cff4 | 2020-12-08 16:49:46 +0100 | [diff] [blame] | 12409 | case EXEC_OMP_SCAN: |
Tobias Burnus | f8d535f | 2021-08-17 15:50:11 +0200 | [diff] [blame] | 12410 | case EXEC_OMP_SCOPE: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12411 | case EXEC_OMP_SECTIONS: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 12412 | case EXEC_OMP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12413 | case EXEC_OMP_SINGLE: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 12414 | case EXEC_OMP_TARGET: |
| 12415 | case EXEC_OMP_TARGET_DATA: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 12416 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 12421 | case EXEC_OMP_TARGET_PARALLEL_LOOP: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 12422 | case EXEC_OMP_TARGET_SIMD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 12423 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 12428 | case EXEC_OMP_TARGET_TEAMS_LOOP: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 12429 | case EXEC_OMP_TARGET_UPDATE: |
| 12430 | case EXEC_OMP_TASK: |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 12431 | case EXEC_OMP_TASKGROUP: |
Jakub Jelinek | b4c3a85 | 2016-11-10 12:38:05 +0100 | [diff] [blame] | 12432 | case EXEC_OMP_TASKLOOP: |
| 12433 | case EXEC_OMP_TASKLOOP_SIMD: |
Jakub Jelinek | a68ab35 | 2008-06-06 15:01:54 +0200 | [diff] [blame] | 12434 | case EXEC_OMP_TASKWAIT: |
Jakub Jelinek | 20906c6 | 2011-08-02 18:13:29 +0200 | [diff] [blame] | 12435 | case EXEC_OMP_TASKYIELD: |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 12436 | 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 Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 12441 | case EXEC_OMP_TEAMS_LOOP: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12442 | 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 Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 12448 | case EXEC_OMP_PARALLEL_DO_SIMD: |
Tobias Burnus | 178191e | 2021-06-04 12:06:59 +0200 | [diff] [blame] | 12449 | case EXEC_OMP_PARALLEL_LOOP: |
Tobias Burnus | 53d5b59 | 2021-08-16 09:26:26 +0200 | [diff] [blame] | 12450 | case EXEC_OMP_PARALLEL_MASKED: |
| 12451 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
| 12452 | case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
Tobias Burnus | 0e3702f | 2021-05-14 19:21:47 +0200 | [diff] [blame] | 12453 | case EXEC_OMP_PARALLEL_MASTER: |
Tobias Burnus | f6bf436 | 2021-06-01 12:46:37 +0200 | [diff] [blame] | 12454 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
| 12455 | case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 12456 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12464 | default: |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 12465 | gfc_internal_error ("gfc_resolve_code(): Bad statement code"); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12466 | } |
| 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 | |
| 12476 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12477 | resolve_values (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12478 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12479 | bool t; |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 12480 | |
Tobias Burnus | 22c30bc | 2012-01-16 20:50:11 +0100 | [diff] [blame] | 12481 | if (sym->value == NULL) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12482 | return; |
| 12483 | |
Tobias Burnus | ece8b0f | 2021-10-06 08:47:40 +0200 | [diff] [blame] | 12484 | if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced) |
Tobias Burnus | 0caf400 | 2020-11-03 09:55:58 +0100 | [diff] [blame] | 12485 | gfc_warning (OPT_Wdeprecated_declarations, |
| 12486 | "Using parameter %qs declared at %L is deprecated", |
| 12487 | sym->name, &sym->declared_at); |
| 12488 | |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 12489 | if (sym->value->expr_type == EXPR_STRUCTURE) |
| 12490 | t= resolve_structure_cons (sym->value, 1); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12491 | else |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 12492 | t = gfc_resolve_expr (sym->value); |
| 12493 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12494 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12495 | return; |
| 12496 | |
Tobias Burnus | e35e87d | 2013-01-07 19:30:11 +0100 | [diff] [blame] | 12497 | gfc_check_assign_symbol (sym, NULL, sym->value); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 12498 | } |
| 12499 | |
| 12500 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12501 | /* 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 | |
| 12504 | static void |
| 12505 | resolve_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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12510 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12511 | return; |
| 12512 | } |
| 12513 | |
| 12514 | |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 12515 | /* 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 | |
| 12519 | static void |
| 12520 | gfc_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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12530 | /* Verify that any binding labels used in a given namespace do not collide |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12531 | with the names or binding labels of any global symbols. Multiple INTERFACE |
| 12532 | for the same procedure are permitted. */ |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12533 | |
| 12534 | static void |
| 12535 | gfc_verify_binding_labels (gfc_symbol *sym) |
| 12536 | { |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12537 | gfc_gsymbol *gsym; |
| 12538 | const char *module; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12539 | |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12540 | 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'Humieres | 9845246 | 2017-12-10 20:11:18 +0100 | [diff] [blame] | 12544 | gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label); |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12545 | |
| 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12561 | { |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12562 | if (!gsym) |
Thomas Koenig | 55b9c61 | 2019-03-13 07:21:33 +0000 | [diff] [blame] | 12563 | gsym = gfc_get_gsymbol (sym->binding_label, true); |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12564 | gsym->where = sym->declared_at; |
| 12565 | gsym->sym_name = sym->name; |
| 12566 | gsym->binding_label = sym->binding_label; |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12567 | 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12576 | } |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12577 | |
| 12578 | if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) |
| 12579 | { |
Dominique d'Humieres | 9845246 | 2017-12-10 20:11:18 +0100 | [diff] [blame] | 12580 | gfc_error ("Variable %qs with binding label %qs at %L uses the same global " |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12581 | "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. Kargl | 2642012 | 2019-01-13 04:02:46 +0000 | [diff] [blame] | 12585 | return; |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12586 | } |
Steven G. Kargl | 2642012 | 2019-01-13 04:02:46 +0000 | [diff] [blame] | 12587 | |
| 12588 | if (sym->attr.flavor == FL_VARIABLE && module |
| 12589 | && (strcmp (module, gsym->mod_name) != 0 |
| 12590 | || strcmp (sym->name, gsym->sym_name) != 0)) |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12591 | { |
| 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'Humieres | 9845246 | 2017-12-10 20:11:18 +0100 | [diff] [blame] | 12594 | 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 Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12596 | sym->name, module, sym->binding_label, |
| 12597 | &sym->declared_at, &gsym->where, gsym->mod_name); |
| 12598 | sym->binding_label = NULL; |
Steven G. Kargl | 2642012 | 2019-01-13 04:02:46 +0000 | [diff] [blame] | 12599 | return; |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12600 | } |
Steven G. Kargl | 2642012 | 2019-01-13 04:02:46 +0000 | [diff] [blame] | 12601 | |
| 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 Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12609 | { |
Janus Weil | 76d3d47 | 2014-01-08 16:25:22 +0100 | [diff] [blame] | 12610 | /* Print an error if the procedure is defined multiple times; we have to |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12611 | exclude references to the same procedure via module association or |
| 12612 | multiple checks for the same procedure. */ |
Dominique d'Humieres | 9845246 | 2017-12-10 20:11:18 +0100 | [diff] [blame] | 12613 | gfc_error ("Procedure %qs with binding label %qs at %L uses the same " |
Tobias Burnus | 77f8682 | 2013-05-20 22:08:05 +0200 | [diff] [blame] | 12614 | "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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 12618 | } |
| 12619 | |
| 12620 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12621 | /* Resolve an index expression. */ |
| 12622 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12623 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12624 | resolve_index_expr (gfc_expr *e) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12625 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12626 | if (!gfc_resolve_expr (e)) |
| 12627 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12628 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12629 | if (!gfc_simplify_expr (e, 0)) |
| 12630 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12631 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12632 | if (!gfc_specification_expr (e)) |
| 12633 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12634 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12635 | return true; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12636 | } |
| 12637 | |
Steven G. Kargl | e69afb2 | 2010-11-02 17:09:58 +0000 | [diff] [blame] | 12638 | |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 12639 | /* Resolve a charlen structure. */ |
| 12640 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12641 | static bool |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 12642 | resolve_charlen (gfc_charlen *cl) |
| 12643 | { |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 12644 | int k; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12645 | bool saved_specification_expr; |
Tobias Schlüter | 5cd09fa | 2007-04-12 20:48:06 +0200 | [diff] [blame] | 12646 | |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 12647 | if (cl->resolved) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12648 | return true; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 12649 | |
| 12650 | cl->resolved = 1; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12651 | saved_specification_expr = specification_expr; |
| 12652 | specification_expr = true; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12653 | |
Harald Anlauf | c1a2cf8 | 2021-01-14 19:17:05 +0100 | [diff] [blame] | 12654 | if (cl->length_from_typespec) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12655 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12656 | if (!gfc_resolve_expr (cl->length)) |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12657 | { |
| 12658 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12659 | return false; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12660 | } |
Tobias Burnus | 239b48d | 2012-05-23 22:35:30 +0200 | [diff] [blame] | 12661 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12662 | if (!gfc_simplify_expr (cl->length, 0)) |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12663 | { |
| 12664 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12665 | return false; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12666 | } |
Steven G. Kargl | 266404a | 2018-01-10 21:31:43 +0000 | [diff] [blame] | 12667 | |
| 12668 | /* cl->length has been resolved. It should have an integer type. */ |
Paul Thomas | c6b0e33 | 2021-01-25 10:27:51 +0000 | [diff] [blame] | 12669 | if (cl->length |
| 12670 | && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0)) |
Steven G. Kargl | 266404a | 2018-01-10 21:31:43 +0000 | [diff] [blame] | 12671 | { |
| 12672 | gfc_error ("Scalar INTEGER expression expected at %L", |
| 12673 | &cl->length->where); |
| 12674 | return false; |
| 12675 | } |
Tobias Burnus | 239b48d | 2012-05-23 22:35:30 +0200 | [diff] [blame] | 12676 | } |
| 12677 | else |
| 12678 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12679 | if (!resolve_index_expr (cl->length)) |
Tobias Burnus | 239b48d | 2012-05-23 22:35:30 +0200 | [diff] [blame] | 12680 | { |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12681 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12682 | return false; |
Tobias Burnus | 239b48d | 2012-05-23 22:35:30 +0200 | [diff] [blame] | 12683 | } |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12684 | } |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 12685 | |
Steven G. Kargl | 98a819e | 2015-10-17 16:50:47 +0000 | [diff] [blame] | 12686 | /* 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 Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 12688 | if (cl->length && cl->length->expr_type == EXPR_CONSTANT |
| 12689 | && mpz_sgn (cl->length->value.integer) < 0) |
Steven G. Kargl | 98a819e | 2015-10-17 16:50:47 +0000 | [diff] [blame] | 12690 | gfc_replace_expr (cl->length, |
Janne Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 12691 | gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); |
Tobias Schlüter | 5cd09fa | 2007-04-12 20:48:06 +0200 | [diff] [blame] | 12692 | |
Francois-Xavier Coudert | b0c0681 | 2009-05-16 16:53:02 +0000 | [diff] [blame] | 12693 | /* 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 Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12700 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12701 | return false; |
Francois-Xavier Coudert | b0c0681 | 2009-05-16 16:53:02 +0000 | [diff] [blame] | 12702 | } |
| 12703 | |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 12704 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12705 | return true; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12706 | } |
| 12707 | |
| 12708 | |
Steven G. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 12709 | /* Test for non-constant shape arrays. */ |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12710 | |
| 12711 | static bool |
| 12712 | is_non_constant_shape_array (gfc_symbol *sym) |
| 12713 | { |
| 12714 | gfc_expr *e; |
| 12715 | int i; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12716 | bool not_constant; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12717 | |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12718 | not_constant = false; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12719 | 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 Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 12724 | for (i = 0; i < sym->as->rank + sym->as->corank; i++) |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12725 | { |
Martin Liska | d136595 | 2019-10-24 10:49:02 +0200 | [diff] [blame] | 12726 | if (i == GFC_MAX_DIMENSIONS) |
| 12727 | break; |
| 12728 | |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12729 | e = sym->as->lower[i]; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12730 | if (e && (!resolve_index_expr(e) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12731 | || !gfc_is_constant_expr (e))) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12732 | not_constant = true; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12733 | e = sym->as->upper[i]; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12734 | if (e && (!resolve_index_expr(e) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12735 | || !gfc_is_constant_expr (e))) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12736 | not_constant = true; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12737 | } |
| 12738 | } |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 12739 | return not_constant; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 12740 | } |
| 12741 | |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12742 | /* Given a symbol and an initialization expression, add code to initialize |
| 12743 | the symbol to the function entry. */ |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12744 | static void |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12745 | build_init_assign (gfc_symbol *sym, gfc_expr *init) |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12746 | { |
| 12747 | gfc_expr *lval; |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12748 | gfc_code *init_st; |
| 12749 | gfc_namespace *ns = sym->ns; |
| 12750 | |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12751 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12754 | && sym->name != sym->ns->proc_name->name) |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12755 | { |
| 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 Thomas | 08113c7 | 2007-07-24 19:15:27 +0000 | [diff] [blame] | 12769 | lval = gfc_lval_expr_from_sym (sym); |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12770 | |
| 12771 | /* Add the code at scope entry. */ |
Janus Weil | 11e5274 | 2013-08-09 21:26:07 +0200 | [diff] [blame] | 12772 | init_st = gfc_get_code (EXEC_INIT_ASSIGN); |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12773 | 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. Kargl | a513927 | 2009-05-13 20:49:13 +0000 | [diff] [blame] | 12778 | init_st->expr1 = lval; |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12779 | init_st->expr2 = init; |
| 12780 | } |
| 12781 | |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 12782 | |
| 12783 | /* Whether or not we can generate a default initializer for a symbol. */ |
| 12784 | |
| 12785 | static bool |
| 12786 | can_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 Burnus | 51d9ef7 | 2021-10-04 09:38:43 +0200 | [diff] [blame] | 12809 | || (a->dummy && (a->intent != INTENT_OUT |
| 12810 | || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)) |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 12811 | || (a->function && sym != sym->result) |
| 12812 | ); |
| 12813 | } |
| 12814 | |
| 12815 | |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12816 | /* Assign the default initializer to a derived type variable or result. */ |
| 12817 | |
| 12818 | static void |
| 12819 | apply_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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 12826 | if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 12827 | init = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12828 | |
Janus Weil | 50f3080 | 2010-09-01 22:50:46 +0200 | [diff] [blame] | 12829 | if (init == NULL && sym->ts.type != BT_CLASS) |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12830 | return; |
| 12831 | |
| 12832 | build_init_assign (sym, init); |
Tobias Burnus | 86e6a23 | 2010-09-02 12:11:39 +0200 | [diff] [blame] | 12833 | sym->attr.referenced = 1; |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12834 | } |
| 12835 | |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 12836 | |
| 12837 | /* Build an initializer for a local. Returns null if the symbol should not have |
| 12838 | a default initialization. */ |
| 12839 | |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12840 | static gfc_expr * |
| 12841 | build_default_init_expr (gfc_symbol *sym) |
| 12842 | { |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12843 | /* These symbols should never have a default initialization. */ |
Toon Moene | a3fd80ea | 2011-12-15 18:26:02 +0000 | [diff] [blame] | 12844 | if (sym->attr.allocatable |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12845 | || 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 Burnus | a67cfde | 2012-06-04 23:01:02 +0200 | [diff] [blame] | 12853 | || sym->attr.cray_pointer |
| 12854 | || sym->assoc) |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12855 | return NULL; |
| 12856 | |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 12857 | /* Get the appropriate init expression. */ |
| 12858 | return gfc_build_default_init_expr (&sym->ts, &sym->declared_at); |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12859 | } |
| 12860 | |
| 12861 | /* Add an initialization expression to a local variable. */ |
| 12862 | static void |
| 12863 | apply_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 Burnus | 068ed5e | 2012-01-14 13:05:59 +0100 | [diff] [blame] | 12878 | /* 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 Burnus | fab99ea | 2013-02-15 09:50:37 +0100 | [diff] [blame] | 12880 | are stack allocated even with -fno-automatic; we have also to exclude |
| 12881 | result variable, which are also nonstatic. */ |
Fritz Reese | 34d567d | 2016-09-23 21:06:18 +0000 | [diff] [blame] | 12882 | 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 Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 12887 | { |
| 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 Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 12896 | |
Steven G. Kargl | e69afb2 | 2010-11-02 17:09:58 +0000 | [diff] [blame] | 12897 | |
Steven G. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 12898 | /* Resolution of common features of flavors variable and procedure. */ |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12899 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12900 | static bool |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12901 | resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) |
| 12902 | { |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12903 | gfc_array_spec *as; |
| 12904 | |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 12905 | if (sym->ts.type == BT_CLASS && sym->attr.class_ok |
| 12906 | && sym->ts.u.derived && CLASS_DATA (sym)) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12907 | as = CLASS_DATA (sym)->as; |
| 12908 | else |
| 12909 | as = sym->as; |
| 12910 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12911 | /* Constraints on deferred shape variable. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12912 | if (as == NULL || as->type != AS_DEFERRED) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12913 | { |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12914 | bool pointer, allocatable, dimension; |
| 12915 | |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 12916 | if (sym->ts.type == BT_CLASS && sym->attr.class_ok |
| 12917 | && sym->ts.u.derived && CLASS_DATA (sym)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12918 | { |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12919 | 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 Thomas | 4cc7046 | 2012-12-21 14:29:34 +0000 | [diff] [blame] | 12925 | pointer = sym->attr.pointer && !sym->attr.select_type_temporary; |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 12926 | allocatable = sym->attr.allocatable; |
| 12927 | dimension = sym->attr.dimension; |
| 12928 | } |
| 12929 | |
| 12930 | if (allocatable) |
| 12931 | { |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 12932 | if (dimension && as->type != AS_ASSUMED_RANK) |
Janus Weil | 2fbd411 | 2009-08-31 12:22:32 +0200 | [diff] [blame] | 12933 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12934 | gfc_error ("Allocatable array %qs at %L must have a deferred " |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 12935 | "shape or assumed rank", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12936 | return false; |
Janus Weil | 2fbd411 | 2009-08-31 12:22:32 +0200 | [diff] [blame] | 12937 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12938 | else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12939 | "%qs at %L may not be ALLOCATABLE", |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12940 | sym->name, &sym->declared_at)) |
| 12941 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12942 | } |
| 12943 | |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 12944 | if (pointer && dimension && as->type != AS_ASSUMED_RANK) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12945 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12946 | gfc_error ("Array pointer %qs at %L must have a deferred shape or " |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 12947 | "assumed rank", sym->name, &sym->declared_at); |
Linus Koenig | efbf739 | 2020-04-13 16:30:44 +0200 | [diff] [blame] | 12948 | sym->error = 1; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12949 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12950 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12951 | } |
| 12952 | else |
| 12953 | { |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 12954 | if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer |
Tobias Burnus | 12578be | 2011-04-29 18:49:53 +0200 | [diff] [blame] | 12955 | && sym->ts.type != BT_CLASS && !sym->assoc) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12956 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12957 | gfc_error ("Array %qs at %L cannot have a deferred shape", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12958 | sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12959 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12960 | } |
| 12961 | } |
Janus Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12962 | |
| 12963 | /* Constraints on polymorphic variables. */ |
| 12964 | if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) |
| 12965 | { |
| 12966 | /* F03:C502. */ |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 12967 | if (sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 12968 | && sym->ts.u.derived |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 12969 | && !sym->attr.select_type_temporary |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12970 | && !UNLIMITED_POLY (sym) |
Harald Anlauf | 96e4244 | 2022-11-16 21:41:19 +0100 | [diff] [blame] | 12971 | && CLASS_DATA (sym)->ts.u.derived |
Janus Weil | d40477b | 2010-07-11 09:55:11 +0200 | [diff] [blame] | 12972 | && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) |
Janus Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12973 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12974 | gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible", |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 12975 | CLASS_DATA (sym)->ts.u.derived->name, sym->name, |
| 12976 | &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12977 | return false; |
Janus Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12978 | } |
| 12979 | |
| 12980 | /* F03:C509. */ |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 12981 | /* 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 Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12985 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 12986 | gfc_error ("CLASS variable %qs at %L must be dummy, allocatable " |
Janus Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12987 | "or pointer", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12988 | return false; |
Janus Weil | 233961d | 2010-05-17 10:25:06 +0200 | [diff] [blame] | 12989 | } |
| 12990 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 12991 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12992 | return true; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 12993 | } |
| 12994 | |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 12995 | |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 12996 | /* Additional checks for symbols with flavor variable and derived |
| 12997 | type. To be called from resolve_fl_variable. */ |
| 12998 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 12999 | static bool |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13000 | resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13001 | { |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 13002 | gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13003 | |
| 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 Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 13008 | if (sym->ts.u.derived |
| 13009 | && sym->ns != sym->ts.u.derived->ns |
Paul Thomas | 8532a01 | 2018-08-12 10:55:13 +0000 | [diff] [blame] | 13010 | && !sym->ts.u.derived->attr.use_assoc |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13011 | && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) |
| 13012 | { |
| 13013 | gfc_symbol *s; |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13014 | gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 13015 | if (s && s->attr.generic) |
| 13016 | s = gfc_find_dt_in_generic (s); |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 13017 | if (s && !gfc_fl_struct (s->attr.flavor)) |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13018 | { |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 13019 | gfc_error ("The type %qs cannot be host associated at %L " |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13020 | "because it is blocked by an incompatible object " |
| 13021 | "of the same name declared at %L", |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13022 | sym->ts.u.derived->name, &sym->declared_at, |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13023 | &s->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13024 | return false; |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13025 | } |
| 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 Franke | 16e520b | 2010-05-19 09:07:25 -0400 | [diff] [blame] | 13034 | gfc_has_default_initializer because gfc_default_initializer generates |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13035 | a hidden default for allocatable components. */ |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13036 | if (!(sym->value || no_init_flag) && sym->ns->proc_name |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13037 | && sym->ns->proc_name->attr.flavor == FL_MODULE |
Fritz Reese | 34d567d | 2016-09-23 21:06:18 +0000 | [diff] [blame] | 13038 | && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13039 | && !sym->attr.pointer && !sym->attr.allocatable |
Daniel Franke | 16e520b | 2010-05-19 09:07:25 -0400 | [diff] [blame] | 13040 | && gfc_has_default_initializer (sym->ts.u.derived) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13041 | && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13042 | "%qs at %L, needed due to the default " |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13043 | "initialization", sym->name, &sym->declared_at)) |
| 13044 | return false; |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13045 | |
| 13046 | /* Assign default initializer. */ |
| 13047 | if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) |
Tobias Burnus | 51d9ef7 | 2021-10-04 09:38:43 +0200 | [diff] [blame] | 13048 | && (!no_init_flag |
| 13049 | || (sym->attr.intent == INTENT_OUT |
| 13050 | && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))) |
Fritz Reese | 7fc6162 | 2016-08-15 21:19:09 +0000 | [diff] [blame] | 13051 | sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13052 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13053 | return true; |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13054 | } |
| 13055 | |
| 13056 | |
Steven G. Kargl | f2bc4e4 | 2016-09-04 20:00:48 +0000 | [diff] [blame] | 13057 | /* 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 | |
| 13061 | static bool |
| 13062 | deferred_requirements (gfc_symbol *sym) |
| 13063 | { |
| 13064 | if (sym->ts.deferred |
| 13065 | && !(sym->attr.pointer |
| 13066 | || sym->attr.allocatable |
Paul Thomas | b89a63b | 2017-09-21 18:40:21 +0000 | [diff] [blame] | 13067 | || sym->attr.associate_var |
Steven G. Kargl | f2bc4e4 | 2016-09-04 20:00:48 +0000 | [diff] [blame] | 13068 | || sym->attr.omp_udr_artificial_var)) |
| 13069 | { |
Steven G. Kargl | 9b15893 | 2019-06-21 20:24:01 +0000 | [diff] [blame] | 13070 | /* 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. Kargl | f2bc4e4 | 2016-09-04 20:00:48 +0000 | [diff] [blame] | 13074 | 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 Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13083 | /* Resolve symbols with flavor variable. */ |
| 13084 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13085 | static bool |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13086 | resolve_fl_variable (gfc_symbol *sym, int mp_flag) |
| 13087 | { |
Janus Weil | f8add00 | 2019-01-05 15:32:12 +0100 | [diff] [blame] | 13088 | const char *auto_save_msg = "Automatic object %qs at %L cannot have the " |
| 13089 | "SAVE attribute"; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13090 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13091 | if (!resolve_fl_var_and_proc (sym, mp_flag)) |
| 13092 | return false; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 13093 | |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13094 | /* 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 Weil | f8add00 | 2019-01-05 15:32:12 +0100 | [diff] [blame] | 13097 | bool saved_specification_expr = specification_expr; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13098 | specification_expr = true; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13099 | |
Tobias Schlüter | c4d4556 | 2007-10-07 13:45:15 +0200 | [diff] [blame] | 13100 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13104 | && !sym->attr.allocatable |
| 13105 | && !sym->attr.pointer |
| 13106 | && is_non_constant_shape_array (sym)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13107 | { |
Janus Weil | 068b961 | 2016-12-12 19:54:54 +0100 | [diff] [blame] | 13108 | /* F08:C541. The shape of an array defined in a main program or module |
| 13109 | * needs to be constant. */ |
Manuel López-Ibáñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 13110 | gfc_error ("The module or main program array %qs at %L must " |
Tobias Schlüter | c4d4556 | 2007-10-07 13:45:15 +0200 | [diff] [blame] | 13111 | "have constant shape", sym->name, &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13112 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13113 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13114 | } |
| 13115 | |
Steven G. Kargl | e69afb2 | 2010-11-02 17:09:58 +0000 | [diff] [blame] | 13116 | /* Constraints on deferred type parameter. */ |
Steven G. Kargl | f2bc4e4 | 2016-09-04 20:00:48 +0000 | [diff] [blame] | 13117 | if (!deferred_requirements (sym)) |
| 13118 | return false; |
Steven G. Kargl | e69afb2 | 2010-11-02 17:09:58 +0000 | [diff] [blame] | 13119 | |
Steven G. Kargl | 50b01e1 | 2016-10-05 21:14:14 +0000 | [diff] [blame] | 13120 | if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13121 | { |
| 13122 | /* Make sure that character string variables with assumed length are |
| 13123 | dummy arguments. */ |
Janus Weil | f8add00 | 2019-01-05 15:32:12 +0100 | [diff] [blame] | 13124 | gfc_expr *e = NULL; |
| 13125 | |
Steven G. Kargl | 7d564142 | 2018-12-19 22:31:25 +0000 | [diff] [blame] | 13126 | if (sym->ts.u.cl) |
| 13127 | e = sym->ts.u.cl->length; |
| 13128 | else |
| 13129 | return false; |
| 13130 | |
Steven G. Kargl | e69afb2 | 2010-11-02 17:09:58 +0000 | [diff] [blame] | 13131 | if (e == NULL && !sym->attr.dummy && !sym->attr.result |
Jakub Jelinek | 5f23671 | 2014-06-06 09:24:38 +0200 | [diff] [blame] | 13132 | && !sym->ts.deferred && !sym->attr.select_type_temporary |
| 13133 | && !sym->attr.omp_udr_artificial_var) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13134 | { |
| 13135 | gfc_error ("Entity with assumed character length at %L must be a " |
| 13136 | "dummy argument or a PARAMETER", &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13137 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13138 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13139 | } |
| 13140 | |
Janus Weil | 80f9522 | 2010-08-19 00:32:22 +0200 | [diff] [blame] | 13141 | if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13142 | { |
| 13143 | gfc_error (auto_save_msg, sym->name, &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13144 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13145 | return false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13146 | } |
| 13147 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13148 | if (!gfc_is_constant_expr (e) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13149 | && !(e->expr_type == EXPR_VARIABLE |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13150 | && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13151 | { |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13152 | 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áñez | fea70c9 | 2015-05-23 23:02:52 +0000 | [diff] [blame] | 13156 | gfc_error ("%qs at %L must have constant character length " |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13157 | "in this context", sym->name, &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13158 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13159 | return false; |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13160 | } |
| 13161 | if (sym->attr.in_common) |
| 13162 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13163 | gfc_error ("COMMON variable %qs at %L must have constant " |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13164 | "character length", sym->name, &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13165 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13166 | return false; |
Janus Weil | 30228b6 | 2011-08-17 11:14:18 +0200 | [diff] [blame] | 13167 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13168 | } |
| 13169 | } |
| 13170 | |
Asher Langton | 51b09ce | 2007-09-21 02:34:14 +0000 | [diff] [blame] | 13171 | if (sym->value == NULL && sym->attr.referenced) |
| 13172 | apply_default_init_local (sym); /* Try to apply a default initialization. */ |
| 13173 | |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13174 | /* Determine if the symbol may not have an initializer. */ |
Janus Weil | f8add00 | 2019-01-05 15:32:12 +0100 | [diff] [blame] | 13175 | int no_init_flag = 0, automatic_flag = 0; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13176 | if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13177 | || sym->attr.intrinsic || sym->attr.result) |
| 13178 | no_init_flag = 1; |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 13179 | else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13180 | && is_non_constant_shape_array (sym)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13181 | { |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13182 | no_init_flag = automatic_flag = 1; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13183 | |
Tobias Burnus | 5349080 | 2007-07-05 14:51:51 +0200 | [diff] [blame] | 13184 | /* Also, they must not have the SAVE attribute. |
| 13185 | SAVE_IMPLICIT is checked below. */ |
Tobias Burnus | 9f3761c | 2011-05-31 20:25:51 +0200 | [diff] [blame] | 13186 | 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 Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13194 | { |
| 13195 | gfc_error (auto_save_msg, sym->name, &sym->declared_at); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13196 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13197 | return false; |
Paul Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 13198 | } |
Tobias Schlüter | 448d2cd | 2007-10-03 13:37:44 +0200 | [diff] [blame] | 13199 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13200 | |
Steven G. Kargl | 7a99def | 2008-10-12 09:38:18 +0000 | [diff] [blame] | 13201 | /* Ensure that any initializer is simplified. */ |
| 13202 | if (sym->value) |
| 13203 | gfc_simplify_expr (sym->value, 1); |
| 13204 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13205 | /* Reject illegal initializers. */ |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13206 | if (!sym->mark && sym->value) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13207 | { |
Janus Weil | da285ce | 2011-02-02 14:11:50 +0100 | [diff] [blame] | 13208 | if (sym->attr.allocatable || (sym->ts.type == BT_CLASS |
| 13209 | && CLASS_DATA (sym)->attr.allocatable)) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13210 | gfc_error ("Allocatable %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13211 | sym->name, &sym->declared_at); |
| 13212 | else if (sym->attr.external) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13213 | gfc_error ("External %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13214 | sym->name, &sym->declared_at); |
Mark Eggleston | bae66e0 | 2020-06-10 07:22:50 +0100 | [diff] [blame] | 13215 | else if (sym->attr.dummy) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13216 | gfc_error ("Dummy %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13217 | sym->name, &sym->declared_at); |
| 13218 | else if (sym->attr.intrinsic) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13219 | gfc_error ("Intrinsic %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13220 | sym->name, &sym->declared_at); |
| 13221 | else if (sym->attr.result) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13222 | gfc_error ("Function result %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13223 | sym->name, &sym->declared_at); |
Tobias Schlüter | 9de8809 | 2007-10-08 22:54:47 +0200 | [diff] [blame] | 13224 | else if (automatic_flag) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13225 | gfc_error ("Automatic array %qs at %L cannot have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13226 | sym->name, &sym->declared_at); |
Paul Thomas | 145bdc2 | 2007-04-07 20:25:43 +0000 | [diff] [blame] | 13227 | else |
| 13228 | goto no_init_error; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13229 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13230 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13231 | } |
| 13232 | |
Paul Thomas | 145bdc2 | 2007-04-07 20:25:43 +0000 | [diff] [blame] | 13233 | no_init_error: |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 13234 | if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13235 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13236 | bool res = resolve_fl_variable_derived (sym, no_init_flag); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13237 | specification_expr = saved_specification_expr; |
| 13238 | return res; |
| 13239 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13240 | |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 13241 | specification_expr = saved_specification_expr; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13242 | return true; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13243 | } |
| 13244 | |
| 13245 | |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13246 | /* Compare the dummy characteristics of a module procedure interface |
| 13247 | declaration with the corresponding declaration in a submodule. */ |
| 13248 | static gfc_formal_arglist *new_formal; |
| 13249 | static char errmsg[200]; |
| 13250 | |
| 13251 | static void |
| 13252 | compare_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 Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13272 | /* Resolve a procedure. */ |
| 13273 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13274 | static bool |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13275 | resolve_fl_procedure (gfc_symbol *sym, int mp_flag) |
| 13276 | { |
| 13277 | gfc_formal_arglist *arg; |
Bernhard Reutner-Fischer | a16010a | 2021-10-31 17:17:56 +0100 | [diff] [blame] | 13278 | bool allocatable_or_pointer = false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13279 | |
| 13280 | if (sym->attr.function |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13281 | && !resolve_fl_var_and_proc (sym, mp_flag)) |
| 13282 | return false; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 13283 | |
Steven G. Kargl | 9b15893 | 2019-06-21 20:24:01 +0000 | [diff] [blame] | 13284 | /* Constraints on deferred type parameter. */ |
| 13285 | if (!deferred_requirements (sym)) |
| 13286 | return false; |
| 13287 | |
Paul Thomas | 92c5919 | 2006-11-22 00:05:10 +0000 | [diff] [blame] | 13288 | if (sym->ts.type == BT_CHARACTER) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13289 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13290 | gfc_charlen *cl = sym->ts.u.cl; |
Paul Thomas | 8111a92 | 2007-05-06 15:12:01 +0000 | [diff] [blame] | 13291 | |
| 13292 | if (cl && cl->length && gfc_is_constant_expr (cl->length) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13293 | && !resolve_charlen (cl)) |
| 13294 | return false; |
Paul Thomas | 8111a92 | 2007-05-06 15:12:01 +0000 | [diff] [blame] | 13295 | |
Tobias Burnus | d94be5e | 2009-12-15 09:37:41 +0100 | [diff] [blame] | 13296 | if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) |
| 13297 | && sym->attr.proc == PROC_ST_FUNCTION) |
Paul Thomas | 92c5919 | 2006-11-22 00:05:10 +0000 | [diff] [blame] | 13298 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13299 | gfc_error ("Character-valued statement function %qs at %L must " |
Tobias Burnus | d94be5e | 2009-12-15 09:37:41 +0100 | [diff] [blame] | 13300 | "have constant length", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13301 | return false; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13302 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13303 | } |
| 13304 | |
Paul Thomas | 37e47ee | 2006-03-28 10:13:50 +0000 | [diff] [blame] | 13305 | /* Ensure that derived type for are not of a private type. Internal |
Ralf Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 13306 | module procedures are excluded by 2.2.3.3 - i.e., they are not |
Kazu Hirata | b82feea | 2006-04-08 14:31:12 +0000 | [diff] [blame] | 13307 | externally accessible and can access all the objects accessible in |
Steven G. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 13308 | the host. */ |
Janus Weil | f8add00 | 2019-01-05 15:32:12 +0100 | [diff] [blame] | 13309 | if (!(sym->ns->parent && sym->ns->parent->proc_name |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13310 | && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 13311 | && gfc_check_symbol_access (sym)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13312 | { |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13313 | gfc_interface *iface; |
| 13314 | |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13315 | for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13316 | { |
| 13317 | if (arg->sym |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13318 | && arg->sym->ts.type == BT_DERIVED |
Mark Eggleston | 647340c | 2020-06-22 13:35:01 +0100 | [diff] [blame] | 13319 | && arg->sym->ts.u.derived |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13320 | && !arg->sym->ts.u.derived->attr.use_assoc |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 13321 | && !gfc_check_symbol_access (arg->sym->ts.u.derived) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13322 | && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13323 | "and cannot be a dummy argument" |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13324 | " of %qs, which is PUBLIC at %L", |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 13325 | arg->sym->name, sym->name, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13326 | &sym->declared_at)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13327 | { |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13328 | /* Stop this message from recurring. */ |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13329 | arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13330 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13331 | } |
| 13332 | } |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13333 | |
| 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 Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13338 | for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next) |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13339 | { |
| 13340 | if (arg->sym |
| 13341 | && arg->sym->ts.type == BT_DERIVED |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13342 | && !arg->sym->ts.u.derived->attr.use_assoc |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 13343 | && !gfc_check_symbol_access (arg->sym->ts.u.derived) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13344 | && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in " |
| 13345 | "PUBLIC interface %qs at %L " |
| 13346 | "takes dummy arguments of %qs which " |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 13347 | "is PRIVATE", iface->sym->name, |
| 13348 | sym->name, &iface->sym->declared_at, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13349 | gfc_typename(&arg->sym->ts))) |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13350 | { |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13351 | /* Stop this message from recurring. */ |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13352 | arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13353 | return false; |
Daniel Franke | 83b2e4e | 2007-07-08 16:38:58 -0400 | [diff] [blame] | 13354 | } |
| 13355 | } |
| 13356 | } |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13357 | } |
| 13358 | |
Janus Weil | 8fb74da | 2008-07-02 21:53:37 +0200 | [diff] [blame] | 13359 | if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION |
| 13360 | && !sym->attr.proc_pointer) |
Daniel Franke | f8faa85 | 2007-07-12 18:15:11 -0400 | [diff] [blame] | 13361 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13362 | gfc_error ("Function %qs at %L cannot have an initializer", |
Daniel Franke | f8faa85 | 2007-07-12 18:15:11 -0400 | [diff] [blame] | 13363 | sym->name, &sym->declared_at); |
Thomas Koenig | 83fad92 | 2018-11-18 09:16:19 +0000 | [diff] [blame] | 13364 | |
| 13365 | /* Make sure no second error is issued for this. */ |
| 13366 | sym->value->error = 1; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13367 | return false; |
Daniel Franke | f8faa85 | 2007-07-12 18:15:11 -0400 | [diff] [blame] | 13368 | } |
| 13369 | |
Kazu Hirata | e2ae140 | 2006-05-28 17:56:58 +0000 | [diff] [blame] | 13370 | /* An external symbol may not have an initializer because it is taken to be |
Janus Weil | 8fb74da | 2008-07-02 21:53:37 +0200 | [diff] [blame] | 13371 | a procedure. Exception: Procedure Pointers. */ |
| 13372 | if (sym->attr.external && sym->value && !sym->attr.proc_pointer) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13373 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13374 | gfc_error ("External object %qs at %L may not have an initializer", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13375 | sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13376 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13377 | } |
| 13378 | |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 13379 | /* An elemental function is required to return a scalar 12.7.1 */ |
Paul Thomas | 2b03b80 | 2018-10-06 15:14:29 +0000 | [diff] [blame] | 13380 | if (sym->attr.elemental && sym->attr.function |
Harald Anlauf | 7e913ca | 2021-12-10 22:41:24 +0100 | [diff] [blame] | 13381 | && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
| 13382 | && CLASS_DATA (sym)->as))) |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 13383 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13384 | gfc_error ("ELEMENTAL function %qs at %L must have a scalar " |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 13385 | "result", sym->name, &sym->declared_at); |
| 13386 | /* Reset so that the error only occurs once. */ |
| 13387 | sym->attr.elemental = 0; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13388 | return false; |
Paul Thomas | d68bd5a | 2006-06-25 15:11:02 +0000 | [diff] [blame] | 13389 | } |
| 13390 | |
Tobias Burnus | 1ca99f7 | 2011-01-30 19:17:29 +0100 | [diff] [blame] | 13391 | if (sym->attr.proc == PROC_ST_FUNCTION |
| 13392 | && (sym->attr.allocatable || sym->attr.pointer)) |
| 13393 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13394 | gfc_error ("Statement function %qs at %L may not have pointer or " |
Tobias Burnus | 1ca99f7 | 2011-01-30 19:17:29 +0100 | [diff] [blame] | 13395 | "allocatable attribute", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13396 | return false; |
Tobias Burnus | 1ca99f7 | 2011-01-30 19:17:29 +0100 | [diff] [blame] | 13397 | } |
| 13398 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13399 | /* 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 Burnus | dd91233 | 2012-05-12 11:53:53 +0200 | [diff] [blame] | 13406 | && sym->ts.type == BT_CHARACTER && !sym->ts.deferred |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13407 | && sym->ts.u.cl && sym->ts.u.cl->length == NULL) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13408 | { |
| 13409 | if ((sym->as && sym->as->rank) || (sym->attr.pointer) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 13410 | || (sym->attr.recursive) || (sym->attr.pure)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13411 | { |
| 13412 | if (sym->as && sym->as->rank) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13413 | gfc_error ("CHARACTER(*) function %qs at %L cannot be " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13414 | "array-valued", sym->name, &sym->declared_at); |
| 13415 | |
| 13416 | if (sym->attr.pointer) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13417 | gfc_error ("CHARACTER(*) function %qs at %L cannot be " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13418 | "pointer-valued", sym->name, &sym->declared_at); |
| 13419 | |
| 13420 | if (sym->attr.pure) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13421 | gfc_error ("CHARACTER(*) function %qs at %L cannot be " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13422 | "pure", sym->name, &sym->declared_at); |
| 13423 | |
| 13424 | if (sym->attr.recursive) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13425 | gfc_error ("CHARACTER(*) function %qs at %L cannot be " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13426 | "recursive", sym->name, &sym->declared_at); |
| 13427 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13428 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13429 | } |
| 13430 | |
| 13431 | /* Appendix B.2 of the standard. Contained functions give an |
Francois-Xavier Coudert | 63a496d | 2014-10-04 10:18:07 +0000 | [diff] [blame] | 13432 | 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 Weil | 9717f7a | 2012-07-17 23:51:20 +0200 | [diff] [blame] | 13437 | gfc_notify_std (GFC_STD_F95_OBS, |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13438 | "CHARACTER(*) function %qs at %L", |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 13439 | sym->name, &sym->declared_at); |
| 13440 | } |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13441 | |
Tobias Burnus | 019c0e5 | 2013-12-08 22:34:18 +0100 | [diff] [blame] | 13442 | /* F2008, C1218. */ |
| 13443 | if (sym->attr.elemental) |
| 13444 | { |
| 13445 | if (sym->attr.proc_pointer) |
| 13446 | { |
Mark Eggleston | eb069ae | 2020-05-07 08:02:02 +0100 | [diff] [blame] | 13447 | const char* name = (sym->attr.result ? sym->ns->proc_name->name |
| 13448 | : sym->name); |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13449 | gfc_error ("Procedure pointer %qs at %L shall not be elemental", |
Mark Eggleston | eb069ae | 2020-05-07 08:02:02 +0100 | [diff] [blame] | 13450 | name, &sym->declared_at); |
Tobias Burnus | 019c0e5 | 2013-12-08 22:34:18 +0100 | [diff] [blame] | 13451 | return false; |
| 13452 | } |
| 13453 | if (sym->attr.dummy) |
| 13454 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13455 | gfc_error ("Dummy procedure %qs at %L shall not be elemental", |
Tobias Burnus | 019c0e5 | 2013-12-08 22:34:18 +0100 | [diff] [blame] | 13456 | sym->name, &sym->declared_at); |
| 13457 | return false; |
| 13458 | } |
| 13459 | } |
| 13460 | |
Steven G. Kargl | 1813c97 | 2018-03-11 21:39:15 +0000 | [diff] [blame] | 13461 | /* 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 Thomas | 29a5298 | 2021-02-23 19:29:04 +0000 | [diff] [blame] | 13464 | 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. Kargl | 1813c97 | 2018-03-11 21:39:15 +0000 | [diff] [blame] | 13472 | if (sym->attr.elemental && sym->result |
Paul Thomas | 29a5298 | 2021-02-23 19:29:04 +0000 | [diff] [blame] | 13473 | && allocatable_or_pointer) |
Steven G. Kargl | 1813c97 | 2018-03-11 21:39:15 +0000 | [diff] [blame] | 13474 | { |
| 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13482 | if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) |
| 13483 | { |
| 13484 | gfc_formal_arglist *curr_arg; |
Christopher D. Rickett | aa5e22f | 2007-07-12 19:52:03 +0000 | [diff] [blame] | 13485 | int has_non_interop_arg = 0; |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13486 | |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 13487 | if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13488 | sym->common_block)) |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13489 | { |
| 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 13502 | |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13503 | curr_arg = gfc_sym_get_dummy_args (sym); |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13504 | while (curr_arg != NULL) |
| 13505 | { |
| 13506 | /* Skip implicitly typed dummy args here. */ |
Steven G. Kargl | 67b8d50 | 2018-05-24 23:28:35 +0000 | [diff] [blame] | 13507 | if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13508 | if (!gfc_verify_c_interop_param (curr_arg->sym)) |
Christopher D. Rickett | aa5e22f | 2007-07-12 19:52:03 +0000 | [diff] [blame] | 13509 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 13514 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13515 | curr_arg = curr_arg->next; |
| 13516 | } |
Christopher D. Rickett | aa5e22f | 2007-07-12 19:52:03 +0000 | [diff] [blame] | 13517 | |
| 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 13526 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 13527 | |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13528 | if (!sym->attr.proc_pointer) |
Janus Weil | beb4bd6 | 2008-08-14 23:15:59 +0200 | [diff] [blame] | 13529 | { |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13530 | if (sym->attr.save == SAVE_EXPLICIT) |
| 13531 | { |
| 13532 | gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13533 | "in %qs at %L", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13534 | return false; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13535 | } |
| 13536 | if (sym->attr.intent) |
| 13537 | { |
| 13538 | gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13539 | "in %qs at %L", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13540 | return false; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13541 | } |
| 13542 | if (sym->attr.subroutine && sym->attr.result) |
| 13543 | { |
| 13544 | gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " |
Mark Eggleston | eb069ae | 2020-05-07 08:02:02 +0100 | [diff] [blame] | 13545 | "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13546 | return false; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13547 | } |
Paul Thomas | 70112e2 | 2016-03-12 13:59:10 +0000 | [diff] [blame] | 13548 | if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13549 | && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) |
| 13550 | || sym->attr.contained)) |
| 13551 | { |
| 13552 | gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13553 | "in %qs at %L", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13554 | return false; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13555 | } |
| 13556 | if (strcmp ("ppr@", sym->name) == 0) |
| 13557 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13558 | gfc_error ("Procedure pointer result %qs at %L " |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13559 | "is missing the pointer attribute", |
| 13560 | sym->ns->proc_name->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13561 | return false; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 13562 | } |
Janus Weil | beb4bd6 | 2008-08-14 23:15:59 +0200 | [diff] [blame] | 13563 | } |
| 13564 | |
Paul Thomas | 30c931d | 2015-03-23 07:53:31 +0000 | [diff] [blame] | 13565 | /* 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 Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13570 | /* 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 Thomas | 4f283c4 | 2015-09-26 17:52:24 +0000 | [diff] [blame] | 13578 | 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 Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13584 | |
Paul Thomas | c064374 | 2016-12-09 22:25:26 +0000 | [diff] [blame] | 13585 | iface = sym->tlink; |
| 13586 | sym->tlink = NULL; |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13587 | |
Paul Thomas | 88b8971 | 2016-08-24 19:33:14 +0000 | [diff] [blame] | 13588 | /* 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 Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13595 | if (iface == NULL) |
| 13596 | goto check_formal; |
| 13597 | |
| 13598 | /* Check the procedure characteristics. */ |
Paul Thomas | 6442a6f43 | 2016-06-01 14:30:00 +0000 | [diff] [blame] | 13599 | if (sym->attr.elemental != iface->attr.elemental) |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13600 | { |
Paul Thomas | 6442a6f43 | 2016-06-01 14:30:00 +0000 | [diff] [blame] | 13601 | gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13602 | "PROCEDURE at %L and its interface in %s", |
Paul Thomas | 4f283c4 | 2015-09-26 17:52:24 +0000 | [diff] [blame] | 13603 | &sym->declared_at, module_name); |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13604 | return false; |
| 13605 | } |
| 13606 | |
Paul Thomas | 6442a6f43 | 2016-06-01 14:30:00 +0000 | [diff] [blame] | 13607 | if (sym->attr.pure != iface->attr.pure) |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13608 | { |
Paul Thomas | 6442a6f43 | 2016-06-01 14:30:00 +0000 | [diff] [blame] | 13609 | gfc_error ("Mismatch in PURE attribute between MODULE " |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13610 | "PROCEDURE at %L and its interface in %s", |
Paul Thomas | 4f283c4 | 2015-09-26 17:52:24 +0000 | [diff] [blame] | 13611 | &sym->declared_at, module_name); |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13612 | 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 Thomas | 4f283c4 | 2015-09-26 17:52:24 +0000 | [diff] [blame] | 13619 | &sym->declared_at, module_name); |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13620 | 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'Humieres | 2f029c0 | 2017-03-22 17:29:30 +0100 | [diff] [blame] | 13627 | "in MODULE %qs and the declaration at %L in " |
| 13628 | "(SUB)MODULE %qs", |
Paul Thomas | 753721a | 2017-02-28 19:32:02 +0000 | [diff] [blame] | 13629 | errmsg, module_name, &sym->declared_at, |
| 13630 | submodule_name ? submodule_name : module_name); |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13631 | return false; |
| 13632 | } |
| 13633 | |
| 13634 | check_formal: |
Paul Thomas | c064374 | 2016-12-09 22:25:26 +0000 | [diff] [blame] | 13635 | /* Check the characteristics of the formal arguments. */ |
Paul Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13636 | 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 Thomas | 4668d6f | 2015-07-02 20:39:56 +0000 | [diff] [blame] | 13644 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13645 | return true; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 13646 | } |
| 13647 | |
| 13648 | |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13649 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13653 | static bool |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13654 | gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13655 | { |
| 13656 | gfc_finalizer* list; |
| 13657 | gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13658 | bool result = true; |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13659 | bool seen_scalar = false; |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13660 | gfc_symbol *vtab; |
| 13661 | gfc_component *c; |
Tobias Burnus | 19fe965 | 2014-08-17 18:42:19 +0200 | [diff] [blame] | 13662 | gfc_symbol *parent = gfc_get_derived_super_type (derived); |
| 13663 | |
| 13664 | if (parent) |
| 13665 | gfc_resolve_finalizers (parent, finalizable); |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13666 | |
Janus Weil | 5285d5d | 2017-05-09 22:55:38 +0200 | [diff] [blame] | 13667 | /* 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 Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13680 | { |
Janus Weil | 5285d5d | 2017-05-09 22:55:38 +0200 | [diff] [blame] | 13681 | if (finalizable) |
| 13682 | *finalizable = false; |
| 13683 | return true; |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13684 | } |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13685 | |
| 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 Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13692 | gfc_formal_arglist *dummy_args; |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13693 | gfc_symbol* arg; |
| 13694 | gfc_finalizer* i; |
| 13695 | int my_rank; |
| 13696 | |
Daniel Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13697 | /* Skip this finalizer if we already resolved it. */ |
| 13698 | if (list->proc_tree) |
| 13699 | { |
Janus Weil | c0fe5a2 | 2016-11-29 15:15:29 +0100 | [diff] [blame] | 13700 | 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 Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13703 | prev_link = &(list->next); |
| 13704 | continue; |
| 13705 | } |
| 13706 | |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13707 | /* Check this exists and is a SUBROUTINE. */ |
Daniel Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13708 | if (!list->proc_sym->attr.subroutine) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13709 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13710 | gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE", |
Daniel Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13711 | list->proc_sym->name, &list->where); |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13712 | goto error; |
| 13713 | } |
| 13714 | |
| 13715 | /* We should have exactly one argument. */ |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13716 | dummy_args = gfc_sym_get_dummy_args (list->proc_sym); |
| 13717 | if (!dummy_args || dummy_args->next) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13718 | { |
| 13719 | gfc_error ("FINAL procedure at %L must have exactly one argument", |
| 13720 | &list->where); |
| 13721 | goto error; |
| 13722 | } |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13723 | arg = dummy_args->sym; |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13724 | |
| 13725 | /* This argument must be of our type. */ |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 13726 | if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13727 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13728 | gfc_error ("Argument of FINAL procedure at %L must be of type %qs", |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13729 | &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 Burnus | 73e42ee | 2014-11-30 09:33:25 +0100 | [diff] [blame] | 13762 | if (warn_surprising && arg->as && arg->as->rank != 0 |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13763 | && arg->as->type != AS_ASSUMED_SHAPE) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 13764 | gfc_warning (OPT_Wsurprising, |
| 13765 | "Non-scalar FINAL procedure at %L should have assumed" |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13766 | " 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 Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13776 | gfc_formal_arglist *dummy_args; |
| 13777 | |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13778 | /* Argument list might be empty; that is an error signalled earlier, |
| 13779 | but we nevertheless continued resolving. */ |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13780 | dummy_args = gfc_sym_get_dummy_args (i->proc_sym); |
| 13781 | if (dummy_args) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13782 | { |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 13783 | gfc_symbol* i_arg = dummy_args->sym; |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13784 | const int i_rank = (i_arg->as ? i_arg->as->rank : 0); |
| 13785 | if (i_rank == my_rank) |
| 13786 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13787 | gfc_error ("FINAL procedure %qs declared at %L has the same" |
| 13788 | " rank (%d) as %qs", |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 13789 | list->proc_sym->name, &list->where, my_rank, |
Daniel Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13790 | i->proc_sym->name); |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13791 | goto error; |
| 13792 | } |
| 13793 | } |
| 13794 | } |
| 13795 | |
| 13796 | /* Is this the/a scalar finalizer procedure? */ |
Janus Weil | c0fe5a2 | 2016-11-29 15:15:29 +0100 | [diff] [blame] | 13797 | if (my_rank == 0) |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13798 | seen_scalar = true; |
| 13799 | |
Daniel Kraft | f6fad28 | 2008-08-08 20:19:46 +0200 | [diff] [blame] | 13800 | /* 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 Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13804 | prev_link = &list->next; |
| 13805 | continue; |
| 13806 | |
Ralf Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 13807 | /* Remove wrong nodes immediately from the list so we don't risk any |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13808 | troubles in the future when they might fail later expectations. */ |
| 13809 | error: |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13810 | i = list; |
| 13811 | *prev_link = list->next; |
| 13812 | gfc_free_finalizer (i); |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13813 | result = false; |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13814 | } |
| 13815 | |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13816 | if (result == false) |
| 13817 | return false; |
| 13818 | |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13819 | /* 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 Weil | 802583a | 2016-12-03 10:32:27 +0100 | [diff] [blame] | 13822 | if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar) |
Manuel López-Ibáñez | 48749db | 2014-12-03 17:50:06 +0000 | [diff] [blame] | 13823 | gfc_warning (OPT_Wsurprising, |
| 13824 | "Only array FINAL procedures declared for derived type %qs" |
Daniel Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13825 | " defined at %L, suggest also scalar one", |
| 13826 | derived->name, &derived->declared_at); |
| 13827 | |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 13828 | 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 Kraft | 3452352 | 2008-06-02 22:03:03 +0200 | [diff] [blame] | 13836 | } |
| 13837 | |
| 13838 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13839 | /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ |
| 13840 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13841 | static bool |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13842 | check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, |
| 13843 | const char* generic_name, locus where) |
| 13844 | { |
Janus Weil | 6f3ab30 | 2012-06-22 23:05:51 +0200 | [diff] [blame] | 13845 | gfc_symbol *sym1, *sym2; |
| 13846 | const char *pass1, *pass2; |
Janus Weil | 2a144f6 | 2014-02-18 08:45:39 +0100 | [diff] [blame] | 13847 | gfc_formal_arglist *dummy_args; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13848 | |
| 13849 | gcc_assert (t1->specific && t2->specific); |
| 13850 | gcc_assert (!t1->specific->is_generic); |
| 13851 | gcc_assert (!t2->specific->is_generic); |
Tobias Burnus | 218e122 | 2012-01-31 19:41:47 +0100 | [diff] [blame] | 13852 | gcc_assert (t1->is_operator == t2->is_operator); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13853 | |
| 13854 | sym1 = t1->specific->u.specific->n.sym; |
| 13855 | sym2 = t2->specific->u.specific->n.sym; |
| 13856 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 13857 | if (sym1 == sym2) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13858 | return true; |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 13859 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13860 | /* 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 Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 13864 | gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for" |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13865 | " GENERIC %qs at %L", |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13866 | sym1->name, sym2->name, generic_name, &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13867 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13868 | } |
| 13869 | |
Janus Weil | 2a144f6 | 2014-02-18 08:45:39 +0100 | [diff] [blame] | 13870 | /* Determine PASS arguments. */ |
Janus Weil | 6f3ab30 | 2012-06-22 23:05:51 +0200 | [diff] [blame] | 13871 | if (t1->specific->nopass) |
| 13872 | pass1 = NULL; |
| 13873 | else if (t1->specific->pass_arg) |
| 13874 | pass1 = t1->specific->pass_arg; |
| 13875 | else |
Janus Weil | 2a144f6 | 2014-02-18 08:45:39 +0100 | [diff] [blame] | 13876 | { |
| 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 Weil | 6f3ab30 | 2012-06-22 23:05:51 +0200 | [diff] [blame] | 13883 | if (t2->specific->nopass) |
| 13884 | pass2 = NULL; |
| 13885 | else if (t2->specific->pass_arg) |
| 13886 | pass2 = t2->specific->pass_arg; |
| 13887 | else |
Janus Weil | 2a144f6 | 2014-02-18 08:45:39 +0100 | [diff] [blame] | 13888 | { |
| 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 Burnus | 218e122 | 2012-01-31 19:41:47 +0100 | [diff] [blame] | 13897 | if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, |
Janus Weil | 6f3ab30 | 2012-06-22 23:05:51 +0200 | [diff] [blame] | 13898 | NULL, 0, pass1, pass2)) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13899 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13900 | gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous", |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13901 | sym1->name, sym2->name, generic_name, &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13902 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13903 | } |
| 13904 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13905 | return true; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13906 | } |
| 13907 | |
| 13908 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13909 | /* 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13916 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13917 | static bool |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13918 | resolve_tb_generic_targets (gfc_symbol* super_type, |
| 13919 | gfc_typebound_proc* p, const char* name) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13920 | { |
| 13921 | gfc_tbp_generic* target; |
| 13922 | gfc_symtree* first_target; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13923 | gfc_symtree* inherited; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13924 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13925 | gcc_assert (p && p->is_generic); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13926 | |
| 13927 | /* Try to find the specific bindings for the symtrees in our target-list. */ |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13928 | gcc_assert (p->u.generic); |
| 13929 | for (target = p->u.generic; target; target = target->next) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13930 | 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 Weil | aea18e9 | 2010-08-03 13:08:50 +0200 | [diff] [blame] | 13939 | if (target->specific_st->n.tb && !target->specific_st->n.tb->error) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13940 | { |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 13941 | target->specific = target->specific_st->n.tb; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13942 | goto specific_found; |
| 13943 | } |
| 13944 | |
| 13945 | /* Look for an inherited specific binding. */ |
| 13946 | if (super_type) |
| 13947 | { |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 13948 | inherited = gfc_find_typebound_proc (super_type, NULL, target_name, |
| 13949 | true, NULL); |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13950 | |
| 13951 | if (inherited) |
| 13952 | { |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 13953 | gcc_assert (inherited->n.tb); |
| 13954 | target->specific = inherited->n.tb; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13955 | goto specific_found; |
| 13956 | } |
| 13957 | } |
| 13958 | |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13959 | gfc_error ("Undefined specific binding %qs as target of GENERIC %qs" |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13960 | " at %L", target_name, name, &p->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13961 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13962 | |
| 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. */ |
| 13965 | specific_found: |
| 13966 | gcc_assert (target->specific); |
| 13967 | |
| 13968 | /* This must really be a specific binding! */ |
| 13969 | if (target->specific->is_generic) |
| 13970 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 13971 | gfc_error ("GENERIC %qs at %L must target a specific binding," |
| 13972 | " %qs is GENERIC, too", name, &p->where, target_name); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13973 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13974 | } |
| 13975 | |
| 13976 | /* Check those already resolved on this type directly. */ |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13977 | for (g = p->u.generic; g; g = g->next) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13978 | if (g != target && g->specific |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13979 | && !check_generic_tbp_ambiguity (target, g, name, p->where)) |
| 13980 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13981 | |
| 13982 | /* Check for ambiguity with inherited specific targets. */ |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13983 | for (overridden_tbp = p->overridden; overridden_tbp; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13984 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 13990 | if (!check_generic_tbp_ambiguity (target, g, name, p->where)) |
| 13991 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13992 | } |
| 13993 | } |
| 13994 | } |
| 13995 | |
| 13996 | /* If we attempt to "overwrite" a specific binding, this is an error. */ |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 13997 | if (p->overridden && !p->overridden->is_generic) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 13998 | { |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 13999 | gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with" |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14000 | " the same name", name, &p->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14001 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14002 | } |
| 14003 | |
| 14004 | /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as |
| 14005 | all must have the same attributes here. */ |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14006 | first_target = p->u.generic->specific->u.specific; |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14007 | gcc_assert (first_target); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14008 | p->subroutine = first_target->n.sym->attr.subroutine; |
| 14009 | p->function = first_target->n.sym->attr.function; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14010 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14011 | return true; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14012 | } |
| 14013 | |
| 14014 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14015 | /* Resolve a GENERIC procedure binding for a derived type. */ |
| 14016 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14017 | static bool |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14018 | resolve_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 Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14028 | overridden = gfc_find_typebound_proc (super_type, NULL, st->name, |
| 14029 | true, NULL); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14030 | |
| 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 Kraft | b325faf | 2009-08-17 20:55:30 +0200 | [diff] [blame] | 14040 | /* Retrieve the target-procedure of an operator binding and do some checks in |
| 14041 | common for intrinsic and user-defined type-bound operators. */ |
| 14042 | |
| 14043 | static gfc_symbol* |
| 14044 | get_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 Weil | 2e33ad2 | 2012-09-17 00:04:26 +0200 | [diff] [blame] | 14052 | /* F08:C468. All operator bindings must have a passed-object dummy argument. */ |
Daniel Kraft | b325faf | 2009-08-17 20:55:30 +0200 | [diff] [blame] | 14053 | if (target->specific->nopass) |
| 14054 | { |
Martin Liska | 1fe61ad | 2019-03-12 16:11:42 +0100 | [diff] [blame] | 14055 | gfc_error ("Type-bound operator at %L cannot be NOPASS", &where); |
Daniel Kraft | b325faf | 2009-08-17 20:55:30 +0200 | [diff] [blame] | 14056 | return NULL; |
| 14057 | } |
| 14058 | |
| 14059 | return target_proc; |
| 14060 | } |
| 14061 | |
| 14062 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14063 | /* Resolve a type-bound intrinsic operator. */ |
| 14064 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14065 | static bool |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14066 | resolve_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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14071 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14072 | /* If there's already an error here, do nothing (but don't fail again). */ |
| 14073 | if (p->error) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14074 | return true; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14075 | |
| 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 Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14083 | op, true, NULL); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14084 | else |
| 14085 | p->overridden = NULL; |
| 14086 | |
| 14087 | /* Resolve general GENERIC properties using worker function. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14088 | if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op))) |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14089 | 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 Kraft | b325faf | 2009-08-17 20:55:30 +0200 | [diff] [blame] | 14096 | target_proc = get_checked_tb_operator_target (target, p->where); |
| 14097 | if (!target_proc) |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14098 | goto error; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14099 | |
| 14100 | if (!gfc_check_operator_interface (target_proc, op, p->where)) |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14101 | goto error; |
Janus Weil | 362aa47 | 2012-06-27 19:38:00 +0200 | [diff] [blame] | 14102 | |
| 14103 | /* Add target to non-typebound operator list. */ |
| 14104 | if (!target->specific->deferred && !derived->attr.use_assoc |
Paul Thomas | 474d486 | 2012-12-02 15:23:30 +0000 | [diff] [blame] | 14105 | && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) |
Janus Weil | 362aa47 | 2012-06-27 19:38:00 +0200 | [diff] [blame] | 14106 | { |
| 14107 | gfc_interface *head, *intr; |
Paul Thomas | cd612e8 | 2016-10-26 14:48:02 +0000 | [diff] [blame] | 14108 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14119 | return false; |
Janus Weil | 362aa47 | 2012-06-27 19:38:00 +0200 | [diff] [blame] | 14120 | 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 Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14127 | } |
| 14128 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14129 | return true; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14130 | |
| 14131 | error: |
| 14132 | p->error = 1; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14133 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14134 | } |
| 14135 | |
| 14136 | |
| 14137 | /* Resolve a type-bound user operator (tree-walker callback). */ |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14138 | |
| 14139 | static gfc_symbol* resolve_bindings_derived; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14140 | static bool resolve_bindings_result; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14141 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14142 | static bool check_uop_procedure (gfc_symbol* sym, locus where); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14143 | |
| 14144 | static void |
| 14145 | resolve_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 Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14164 | stree->name, true, NULL); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14165 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14173 | if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)) |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14174 | 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 Kraft | b325faf | 2009-08-17 20:55:30 +0200 | [diff] [blame] | 14181 | target_proc = get_checked_tb_operator_target (target, stree->n.tb->where); |
| 14182 | if (!target_proc) |
| 14183 | goto error; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14184 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14185 | if (!check_uop_procedure (target_proc, stree->n.tb->where)) |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14186 | goto error; |
| 14187 | } |
| 14188 | |
| 14189 | return; |
| 14190 | |
| 14191 | error: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14192 | resolve_bindings_result = false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14193 | stree->n.tb->error = 1; |
| 14194 | } |
| 14195 | |
| 14196 | |
| 14197 | /* Resolve the type-bound procedures for a derived type. */ |
| 14198 | |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14199 | static void |
| 14200 | resolve_typebound_procedure (gfc_symtree* stree) |
| 14201 | { |
| 14202 | gfc_symbol* proc; |
| 14203 | locus where; |
| 14204 | gfc_symbol* me_arg; |
| 14205 | gfc_symbol* super_type; |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 14206 | gfc_component* comp; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14207 | |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14208 | 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 Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14215 | return; |
| 14216 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14217 | /* If this is a GENERIC binding, use that routine. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14218 | if (stree->n.tb->is_generic) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14219 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14220 | if (!resolve_typebound_generic (resolve_bindings_derived, stree)) |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14221 | goto error; |
| 14222 | return; |
| 14223 | } |
| 14224 | |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14225 | /* Get the target-procedure to check it. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14226 | 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 Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14230 | |
| 14231 | /* Default access should already be resolved from the parser. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14232 | gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14233 | |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14234 | if (stree->n.tb->deferred) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14235 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14236 | if (!check_proc_interface (proc, &where)) |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14237 | goto error; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14238 | } |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14239 | else |
| 14240 | { |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 14241 | /* If proc has not been resolved at this point, proc->name may |
Steven G. Kargl | eabd9d9 | 2019-08-13 18:35:33 +0000 | [diff] [blame] | 14242 | actually be a USE associated entity. See PR fortran/89647. */ |
Mark Eggleston | dbeaa7a | 2020-04-23 10:33:14 +0100 | [diff] [blame] | 14243 | if (!proc->resolve_symbol_called |
Steven G. Kargl | eabd9d9 | 2019-08-13 18:35:33 +0000 | [diff] [blame] | 14244 | && 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 Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14260 | /* Check for F08:C465. */ |
| 14261 | if ((!proc->attr.subroutine && !proc->attr.function) |
| 14262 | || (proc->attr.proc != PROC_MODULE |
Paul Thomas | eaf8837 | 2021-01-21 10:00:00 +0000 | [diff] [blame] | 14263 | && proc->attr.if_source != IFSRC_IFBODY |
| 14264 | && !proc->attr.module_procedure) |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14265 | || proc->attr.abstract) |
| 14266 | { |
Steven G. Kargl | eabd9d9 | 2019-08-13 18:35:33 +0000 | [diff] [blame] | 14267 | gfc_error ("%qs must be a module procedure or an external " |
| 14268 | "procedure with an explicit interface at %L", |
| 14269 | proc->name, &where); |
Janus Weil | b6a4560 | 2012-08-02 10:57:58 +0200 | [diff] [blame] | 14270 | goto error; |
| 14271 | } |
| 14272 | } |
| 14273 | |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14274 | stree->n.tb->subroutine = proc->attr.subroutine; |
| 14275 | stree->n.tb->function = proc->attr.function; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14276 | |
| 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 Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14282 | /* If PASS, resolve and check arguments if not already resolved / loaded |
| 14283 | from a .mod file. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14284 | if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14285 | { |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 14286 | gfc_formal_arglist *dummy_args; |
| 14287 | |
| 14288 | dummy_args = gfc_sym_get_dummy_args (proc); |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14289 | if (stree->n.tb->pass_arg) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14290 | { |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 14291 | gfc_formal_arglist *i; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14292 | |
| 14293 | /* If an explicit passing argument name is given, walk the arg-list |
| 14294 | and look for it. */ |
| 14295 | |
| 14296 | me_arg = NULL; |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14297 | stree->n.tb->pass_arg_num = 1; |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 14298 | for (i = dummy_args; i; i = i->next) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14299 | { |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14300 | if (!strcmp (i->sym->name, stree->n.tb->pass_arg)) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14301 | { |
| 14302 | me_arg = i->sym; |
| 14303 | break; |
| 14304 | } |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14305 | ++stree->n.tb->pass_arg_num; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14306 | } |
| 14307 | |
| 14308 | if (!me_arg) |
| 14309 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14310 | gfc_error ("Procedure %qs with PASS(%s) at %L has no" |
| 14311 | " argument %qs", |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14312 | proc->name, stree->n.tb->pass_arg, &where, |
| 14313 | stree->n.tb->pass_arg); |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14314 | goto error; |
| 14315 | } |
| 14316 | } |
| 14317 | else |
| 14318 | { |
| 14319 | /* Otherwise, take the first one; there should in fact be at least |
| 14320 | one. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14321 | stree->n.tb->pass_arg_num = 1; |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 14322 | if (!dummy_args) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14323 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14324 | gfc_error ("Procedure %qs with PASS at %L must have at" |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14325 | " least one argument", proc->name, &where); |
| 14326 | goto error; |
| 14327 | } |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 14328 | me_arg = dummy_args->sym; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14329 | } |
| 14330 | |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14331 | /* Now check that the argument-type matches and the passed-object |
| 14332 | dummy argument is generally fine. */ |
| 14333 | |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14334 | gcc_assert (me_arg); |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14335 | |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 14336 | if (me_arg->ts.type != BT_CLASS) |
| 14337 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14338 | gfc_error ("Non-polymorphic passed-object dummy argument of %qs" |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 14339 | " at %L", proc->name, &where); |
| 14340 | goto error; |
| 14341 | } |
| 14342 | |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 14343 | if (CLASS_DATA (me_arg)->ts.u.derived |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 14344 | != resolve_bindings_derived) |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14345 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14346 | 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 Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14348 | me_arg->name, &where, resolve_bindings_derived->name); |
| 14349 | goto error; |
| 14350 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14351 | |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14352 | gcc_assert (me_arg->ts.type == BT_CLASS); |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 14353 | if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14354 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14355 | gfc_error ("Passed-object dummy argument of %qs at %L must be" |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14356 | " scalar", proc->name, &where); |
| 14357 | goto error; |
| 14358 | } |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 14359 | if (CLASS_DATA (me_arg)->attr.allocatable) |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14360 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14361 | gfc_error ("Passed-object dummy argument of %qs at %L must not" |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14362 | " be ALLOCATABLE", proc->name, &where); |
| 14363 | goto error; |
| 14364 | } |
Janus Weil | 7a08eda1 | 2010-05-30 23:56:11 +0200 | [diff] [blame] | 14365 | if (CLASS_DATA (me_arg)->attr.class_pointer) |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14366 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14367 | gfc_error ("Passed-object dummy argument of %qs at %L must not" |
Daniel Kraft | 41a394b | 2009-12-08 12:39:20 +0100 | [diff] [blame] | 14368 | " be POINTER", proc->name, &where); |
| 14369 | goto error; |
| 14370 | } |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14371 | } |
| 14372 | |
| 14373 | /* If we are extending some type, check that we don't override a procedure |
| 14374 | flagged NON_OVERRIDABLE. */ |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14375 | stree->n.tb->overridden = NULL; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14376 | if (super_type) |
| 14377 | { |
| 14378 | gfc_symtree* overridden; |
Daniel Kraft | 8e1f752 | 2008-08-28 20:03:02 +0200 | [diff] [blame] | 14379 | overridden = gfc_find_typebound_proc (super_type, NULL, |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14380 | stree->name, true, NULL); |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14381 | |
Janus Weil | 99fc1b9 | 2011-08-07 12:12:09 +0200 | [diff] [blame] | 14382 | if (overridden) |
| 14383 | { |
| 14384 | if (overridden->n.tb) |
| 14385 | stree->n.tb->overridden = overridden->n.tb; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 14386 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14387 | if (!gfc_check_typebound_override (stree, overridden)) |
Janus Weil | 99fc1b9 | 2011-08-07 12:12:09 +0200 | [diff] [blame] | 14388 | goto error; |
| 14389 | } |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14390 | } |
| 14391 | |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 14392 | /* 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14396 | gfc_error ("Procedure %qs at %L has the same name as a component of" |
| 14397 | " %qs", |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 14398 | stree->name, &where, resolve_bindings_derived->name); |
| 14399 | goto error; |
| 14400 | } |
| 14401 | |
| 14402 | /* Try to find a name collision with an inherited component. */ |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14403 | if (super_type && gfc_find_component (super_type, stree->name, true, true, |
| 14404 | NULL)) |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 14405 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14406 | gfc_error ("Procedure %qs at %L has the same name as an inherited" |
| 14407 | " component of %qs", |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 14408 | stree->name, &where, resolve_bindings_derived->name); |
| 14409 | goto error; |
| 14410 | } |
| 14411 | |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14412 | stree->n.tb->error = 0; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14413 | return; |
| 14414 | |
| 14415 | error: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14416 | resolve_bindings_result = false; |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14417 | stree->n.tb->error = 1; |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14418 | } |
| 14419 | |
Janus Weil | bd48f123 | 2010-08-29 23:29:38 +0200 | [diff] [blame] | 14420 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14421 | static bool |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14422 | resolve_typebound_procedures (gfc_symbol* derived) |
| 14423 | { |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14424 | int op; |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 14425 | gfc_symbol* super_type; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14426 | |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14427 | if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14428 | return true; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14429 | |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 14430 | super_type = gfc_get_derived_super_type (derived); |
| 14431 | if (super_type) |
Mikael Morin | 49c8d79 | 2013-02-04 19:06:06 +0000 | [diff] [blame] | 14432 | resolve_symbol (super_type); |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14433 | |
| 14434 | resolve_bindings_derived = derived; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14435 | resolve_bindings_result = true; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14436 | |
| 14437 | if (derived->f2k_derived->tb_sym_root) |
| 14438 | gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, |
| 14439 | &resolve_typebound_procedure); |
| 14440 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14441 | 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 Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 14448 | if (p && !resolve_typebound_intrinsic_op (derived, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14449 | (gfc_intrinsic_op)op, p)) |
| 14450 | resolve_bindings_result = false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 14451 | } |
Daniel Kraft | 30b608e | 2008-08-24 18:15:27 +0200 | [diff] [blame] | 14452 | |
| 14453 | return resolve_bindings_result; |
| 14454 | } |
| 14455 | |
| 14456 | |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 14457 | /* Add a derived type to the dt_list. The dt_list is used in trans-types.cc |
Paul Thomas | 9d5c21c | 2008-06-17 18:08:24 +0000 | [diff] [blame] | 14458 | to give all identical derived types the same backend_decl. */ |
| 14459 | static void |
| 14460 | add_dt_to_dt_list (gfc_symbol *derived) |
| 14461 | { |
Andrew Benson | 20e8cea | 2018-07-20 20:00:42 +0000 | [diff] [blame] | 14462 | 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 Thomas | 9d5c21c | 2008-06-17 18:08:24 +0000 | [diff] [blame] | 14475 | } |
| 14476 | |
| 14477 | |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14478 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14481 | static bool |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14482 | ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) |
| 14483 | { |
| 14484 | if (!st) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14485 | return true; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14486 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14487 | if (!ensure_not_abstract_walker (sub, st->left)) |
| 14488 | return false; |
| 14489 | if (!ensure_not_abstract_walker (sub, st->right)) |
| 14490 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14491 | |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14492 | if (st->n.tb && st->n.tb->deferred) |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14493 | { |
| 14494 | gfc_symtree* overriding; |
Daniel Kraft | 4a44a72 | 2009-08-27 13:42:56 +0200 | [diff] [blame] | 14495 | overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); |
Paul Thomas | 9c4174d | 2010-04-20 19:07:14 +0000 | [diff] [blame] | 14496 | if (!overriding) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14497 | return false; |
Paul Thomas | 9c4174d | 2010-04-20 19:07:14 +0000 | [diff] [blame] | 14498 | gcc_assert (overriding->n.tb); |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14499 | if (overriding->n.tb->deferred) |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14500 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 14501 | gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because" |
| 14502 | " %qs is DEFERRED and not overridden", |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14503 | sub->name, &sub->declared_at, st->name); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14504 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14505 | } |
| 14506 | } |
| 14507 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14508 | return true; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14509 | } |
| 14510 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14511 | static bool |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14512 | ensure_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 Weil | 7c9b8fb | 2010-05-22 12:21:32 +0200 | [diff] [blame] | 14521 | gcc_assert (ancestor && !sub->attr.abstract); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14522 | |
Janus Weil | 7c9b8fb | 2010-05-22 12:21:32 +0200 | [diff] [blame] | 14523 | if (!ancestor->attr.abstract) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14524 | return true; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14525 | |
| 14526 | /* Walk bindings of this ancestor. */ |
| 14527 | if (ancestor->f2k_derived) |
| 14528 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14529 | bool t; |
Daniel Kraft | e34ccb4 | 2009-04-24 17:20:23 +0200 | [diff] [blame] | 14530 | t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14531 | if (!t) |
| 14532 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14533 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 14540 | return true; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 14541 | } |
| 14542 | |
| 14543 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14544 | /* 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 | |
| 14548 | static void |
| 14549 | check_defined_assignments (gfc_symbol *derived) |
| 14550 | { |
| 14551 | gfc_component *c; |
| 14552 | |
| 14553 | for (c = derived->components; c; c = c->next) |
| 14554 | { |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14555 | if (!gfc_bt_struct (c->ts.type) |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 14556 | || 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14581 | /* Resolve a single component of a derived type or structure. */ |
| 14582 | |
| 14583 | static bool |
| 14584 | resolve_component (gfc_component *c, gfc_symbol *sym) |
| 14585 | { |
| 14586 | gfc_symbol *super_type; |
Thomas Koenig | 1bd83e0 | 2019-01-31 22:21:28 +0000 | [diff] [blame] | 14587 | symbol_attribute *attr; |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14588 | |
| 14589 | if (c->attr.artificial) |
| 14590 | return true; |
| 14591 | |
Paul Thomas | a964d4b | 2017-11-28 15:13:42 +0000 | [diff] [blame] | 14592 | /* 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 Thomas | aea5e93 | 2017-11-05 12:38:42 +0000 | [diff] [blame] | 14597 | return true; |
| 14598 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14599 | /* 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 Koenig | 1bd83e0 | 2019-01-31 22:21:28 +0000 | [diff] [blame] | 14630 | if (c->ts.type == BT_CLASS) |
| 14631 | { |
Harald Anlauf | 8b6f1e8 | 2021-01-06 19:37:11 +0100 | [diff] [blame] | 14632 | if (c->attr.class_ok && CLASS_DATA (c)) |
Thomas Koenig | 1bd83e0 | 2019-01-31 22:21:28 +0000 | [diff] [blame] | 14633 | { |
| 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14647 | { |
| 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 Koenig | 3be34c0 | 2018-01-29 07:11:16 +0000 | [diff] [blame] | 14653 | /* 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14664 | 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 Weil | 24abcc4 | 2018-02-12 18:11:58 +0100 | [diff] [blame] | 14794 | /* Check for F03:C453. */ |
| 14795 | if (CLASS_DATA (me_arg)->attr.dimension) |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14796 | { |
| 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 Weil | 24abcc4 | 2018-02-12 18:11:58 +0100 | [diff] [blame] | 14804 | if (CLASS_DATA (me_arg)->attr.class_pointer) |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14805 | { |
| 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 Weil | 24abcc4 | 2018-02-12 18:11:58 +0100 | [diff] [blame] | 14813 | if (CLASS_DATA (me_arg)->attr.allocatable) |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14814 | { |
| 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 Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 14888 | if (c->ts.type == BT_CHARACTER |
| 14889 | && (c->ts.deferred || c->attr.pdt_string) |
| 14890 | && !c->attr.function |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14891 | && !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 Thomas | bf9f15e | 2016-10-25 20:37:05 +0000 | [diff] [blame] | 14945 | /* 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 Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14952 | /* 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 Anlauf | 9e1e6e6 | 2021-01-14 19:21:05 +0100 | [diff] [blame] | 14962 | if (c->as && c->as->type != AS_DEFERRED |
| 14963 | && (c->attr.pointer || c->attr.allocatable)) |
| 14964 | return false; |
| 14965 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14966 | 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 Thomas | 5bab4c9 | 2017-09-09 11:10:42 +0000 | [diff] [blame] | 14972 | && !c->attr.pdt_kind && !c->attr.pdt_len |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 14973 | && !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 | |
| 14983 | static locus * |
| 14984 | cons_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 | |
| 15003 | static bool |
| 15004 | resolve_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 Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15042 | /* 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üter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15045 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15046 | static bool |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15047 | resolve_fl_derived0 (gfc_symbol *sym) |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15048 | { |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 15049 | gfc_symbol* super_type; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15050 | gfc_component *c; |
Paul Thomas | de624be | 2017-10-21 09:02:17 +0000 | [diff] [blame] | 15051 | gfc_formal_arglist *f; |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15052 | bool success; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15053 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15054 | if (sym->attr.unlimited_polymorphic) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15055 | return true; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15056 | |
Daniel Kraft | 9d1210f | 2008-08-25 19:58:53 +0200 | [diff] [blame] | 15057 | super_type = gfc_get_derived_super_type (sym); |
| 15058 | |
Joost VandeVondele | 1cc0e19 | 2014-09-20 11:48:00 +0000 | [diff] [blame] | 15059 | /* F2008, C432. */ |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 15060 | if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) |
| 15061 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15062 | gfc_error ("As extending type %qs at %L has a coarray component, " |
| 15063 | "parent type %qs shall also have one", sym->name, |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 15064 | &sym->declared_at, super_type->name); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15065 | return false; |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 15066 | } |
| 15067 | |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 15068 | /* Ensure the extended type gets resolved before we do. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15069 | if (super_type && !resolve_fl_derived0 (super_type)) |
| 15070 | return false; |
Daniel Kraft | e157f736 | 2008-08-31 12:00:30 +0200 | [diff] [blame] | 15071 | |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 15072 | /* An ABSTRACT type must be extensible. */ |
Tobias Burnus | cf2b3c2 | 2009-09-30 21:55:45 +0200 | [diff] [blame] | 15073 | if (sym->attr.abstract && !gfc_type_is_extensible (sym)) |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 15074 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15075 | gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 15076 | sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15077 | return false; |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 15078 | } |
| 15079 | |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15080 | c = (sym->attr.is_class) ? sym->components->ts.u.derived->components |
| 15081 | : sym->components; |
| 15082 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15083 | success = true; |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15084 | for ( ; c != NULL; c = c->next) |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15085 | if (!resolve_component (c, sym)) |
| 15086 | success = false; |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 15087 | |
Janus Weil | cab283f | 2015-01-15 19:28:02 +0100 | [diff] [blame] | 15088 | if (!success) |
| 15089 | return false; |
| 15090 | |
Paul Thomas | f549bfb | 2018-01-01 17:36:41 +0000 | [diff] [blame] | 15091 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15116 | 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 Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 15122 | /* 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 Weil | 5cd2f81 | 2010-06-22 19:07:06 +0200 | [diff] [blame] | 15125 | && !sym->attr.is_class |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15126 | && !ensure_not_abstract (sym, super_type)) |
| 15127 | return false; |
Daniel Kraft | b0e5fa9 | 2009-03-29 19:47:00 +0200 | [diff] [blame] | 15128 | |
Paul Thomas | de624be | 2017-10-21 09:02:17 +0000 | [diff] [blame] | 15129 | /* 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 Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15134 | if (!f->sym) |
| 15135 | continue; |
Paul Thomas | de624be | 2017-10-21 09:02:17 +0000 | [diff] [blame] | 15136 | 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 Thomas | 6b88779 | 2006-09-05 04:26:10 +0000 | [diff] [blame] | 15147 | /* Add derived type to the derived type list. */ |
Paul Thomas | 9d5c21c | 2008-06-17 18:08:24 +0000 | [diff] [blame] | 15148 | add_dt_to_dt_list (sym); |
Paul Thomas | 6b88779 | 2006-09-05 04:26:10 +0000 | [diff] [blame] | 15149 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15150 | return true; |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15151 | } |
| 15152 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15153 | |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15154 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15159 | static bool |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15160 | resolve_fl_derived (gfc_symbol *sym) |
| 15161 | { |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15162 | gfc_symbol *gen_dt = NULL; |
| 15163 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15164 | if (sym->attr.unlimited_polymorphic) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15165 | return true; |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15166 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15167 | 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 Burnus | 6ba84c3 | 2012-05-04 20:53:17 +0200 | [diff] [blame] | 15170 | && (!gen_dt->generic->sym->attr.use_assoc |
| 15171 | || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) |
Manuel López-Ibáñez | 2a2703a | 2015-05-16 12:31:00 +0000 | [diff] [blame] | 15172 | && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function " |
| 15173 | "%qs at %L being the same name as derived " |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 15174 | "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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15181 | &sym->declared_at)) |
| 15182 | return false; |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15183 | |
Janus Weil | 0e4cb16 | 2018-09-11 19:44:04 +0200 | [diff] [blame] | 15184 | if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc) |
Janus Weil | 00cad17 | 2018-08-22 19:10:00 +0200 | [diff] [blame] | 15185 | { |
| 15186 | gfc_error ("Derived type %qs at %L has not been declared", |
| 15187 | sym->name, &sym->declared_at); |
| 15188 | return false; |
| 15189 | } |
| 15190 | |
Tobias Burnus | 8e54f13 | 2012-09-03 08:35:59 +0200 | [diff] [blame] | 15191 | /* Resolve the finalizer procedures. */ |
Tobias Burnus | cb41490 | 2014-04-12 00:35:47 +0200 | [diff] [blame] | 15192 | if (!gfc_resolve_finalizers (sym, NULL)) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15193 | return false; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15194 | |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15195 | if (sym->attr.is_class && sym->ts.u.derived == NULL) |
| 15196 | { |
| 15197 | /* Fix up incomplete CLASS symbols. */ |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15198 | gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL); |
| 15199 | gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL); |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15200 | |
| 15201 | /* Nothing more to do for unlimited polymorphic entities. */ |
| 15202 | if (data->ts.u.derived->attr.unlimited_polymorphic) |
Mikael Morin | fa5cd71 | 2022-04-24 15:05:41 +0200 | [diff] [blame] | 15203 | { |
| 15204 | add_dt_to_dt_list (sym); |
| 15205 | return true; |
| 15206 | } |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15207 | else if (vptr->ts.u.derived == NULL) |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15208 | { |
| 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 Weil | 477f145 | 2017-05-22 19:08:24 +0200 | [diff] [blame] | 15212 | if (!resolve_fl_derived0 (vptr->ts.u.derived)) |
| 15213 | return false; |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15214 | } |
| 15215 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15216 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15217 | if (!resolve_fl_derived0 (sym)) |
| 15218 | return false; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15219 | |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15220 | /* Resolve the type-bound procedures. */ |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15221 | if (!resolve_typebound_procedures (sym)) |
| 15222 | return false; |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15223 | |
Paul Thomas | aea5e93 | 2017-11-05 12:38:42 +0000 | [diff] [blame] | 15224 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15238 | return true; |
Janus Weil | 0291fa2 | 2011-07-31 12:25:07 +0200 | [diff] [blame] | 15239 | } |
| 15240 | |
| 15241 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15242 | static bool |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15243 | resolve_fl_namelist (gfc_symbol *sym) |
| 15244 | { |
| 15245 | gfc_namelist *nl; |
| 15246 | gfc_symbol *nlsym; |
| 15247 | |
Tobias Burnus | e060847 | 2010-09-04 19:47:02 +0200 | [diff] [blame] | 15248 | for (nl = sym->namelist; nl; nl = nl->next) |
| 15249 | { |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15250 | /* 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15254 | gfc_error ("Assumed size array %qs in namelist %qs at %L is not " |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15255 | "allowed", nl->sym->name, sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15256 | return false; |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15257 | } |
| 15258 | |
Tobias Burnus | e060847 | 2010-09-04 19:47:02 +0200 | [diff] [blame] | 15259 | if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15260 | && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " |
| 15261 | "with assumed shape in namelist %qs at %L", |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15262 | nl->sym->name, sym->name, &sym->declared_at)) |
| 15263 | return false; |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15264 | |
| 15265 | if (is_non_constant_shape_array (nl->sym) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15266 | && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " |
| 15267 | "with nonconstant shape in namelist %qs at %L", |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15268 | nl->sym->name, sym->name, &sym->declared_at)) |
| 15269 | return false; |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15270 | |
| 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15274 | && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with " |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15275 | "nonconstant character length in " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15276 | "namelist %qs at %L", nl->sym->name, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15277 | sym->name, &sym->declared_at)) |
| 15278 | return false; |
Tobias Burnus | 19d3610 | 2011-01-26 11:12:47 +0100 | [diff] [blame] | 15279 | |
Tobias Burnus | e060847 | 2010-09-04 19:47:02 +0200 | [diff] [blame] | 15280 | } |
| 15281 | |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15282 | /* Reject PRIVATE objects in a PUBLIC namelist. */ |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 15283 | if (gfc_check_symbol_access (sym)) |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15284 | { |
| 15285 | for (nl = sym->namelist; nl; nl = nl->next) |
| 15286 | { |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 15287 | if (!nl->sym->attr.use_assoc |
Paul Thomas | c867b7b | 2009-04-20 21:55:26 +0000 | [diff] [blame] | 15288 | && !is_sym_host_assoc (nl->sym, sym->ns) |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 15289 | && !gfc_check_symbol_access (nl->sym)) |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15290 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15291 | gfc_error ("NAMELIST object %qs was declared PRIVATE and " |
| 15292 | "cannot be member of PUBLIC namelist %qs at %L", |
Daniel Franke | 5cca320 | 2007-07-28 04:51:06 -0400 | [diff] [blame] | 15293 | nl->sym->name, sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15294 | return false; |
Daniel Franke | 5cca320 | 2007-07-28 04:51:06 -0400 | [diff] [blame] | 15295 | } |
| 15296 | |
Jerry DeLisle | 628c06d | 2017-05-11 20:40:49 +0000 | [diff] [blame] | 15297 | 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 Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 15308 | |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 15309 | /* Types with private components that came here by USE-association. */ |
Daniel Franke | 5cca320 | 2007-07-28 04:51:06 -0400 | [diff] [blame] | 15310 | if (nl->sym->ts.type == BT_DERIVED |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15311 | && derived_inaccessible (nl->sym->ts.u.derived)) |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 15312 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15313 | gfc_error ("NAMELIST object %qs has use-associated PRIVATE " |
| 15314 | "components and cannot be member of namelist %qs at %L", |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 15315 | nl->sym->name, sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15316 | return false; |
Daniel Franke | 3dbf653 | 2007-08-06 16:53:19 -0400 | [diff] [blame] | 15317 | } |
| 15318 | |
| 15319 | /* Types with private components that are defined in the same module. */ |
| 15320 | if (nl->sym->ts.type == BT_DERIVED |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15321 | && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 15322 | && nl->sym->ts.u.derived->attr.private_comp) |
Daniel Franke | 5cca320 | 2007-07-28 04:51:06 -0400 | [diff] [blame] | 15323 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15324 | gfc_error ("NAMELIST object %qs has PRIVATE components and " |
| 15325 | "cannot be a member of PUBLIC namelist %qs at %L", |
Daniel Franke | 5cca320 | 2007-07-28 04:51:06 -0400 | [diff] [blame] | 15326 | nl->sym->name, sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15327 | return false; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15328 | } |
| 15329 | } |
| 15330 | } |
| 15331 | |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15332 | |
| 15333 | /* 14.1.2 A module or internal procedure represent local entities |
Paul Thomas | 847b053 | 2007-05-11 11:42:56 +0000 | [diff] [blame] | 15334 | of the same type as a namelist member and so are not allowed. */ |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15335 | for (nl = sym->namelist; nl; nl = nl->next) |
| 15336 | { |
Paul Thomas | 982186b | 2006-10-13 12:51:07 +0000 | [diff] [blame] | 15337 | if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE) |
| 15338 | continue; |
Paul Thomas | 847b053 | 2007-05-11 11:42:56 +0000 | [diff] [blame] | 15339 | |
| 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 Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15346 | nlsym = NULL; |
Tobias Burnus | 99c25a8 | 2012-09-23 08:48:48 +0200 | [diff] [blame] | 15347 | if (nl->sym->name) |
Paul Thomas | 847b053 | 2007-05-11 11:42:56 +0000 | [diff] [blame] | 15348 | gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym); |
Paul Thomas | 982186b | 2006-10-13 12:51:07 +0000 | [diff] [blame] | 15349 | if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) |
| 15350 | { |
| 15351 | gfc_error ("PROCEDURE attribute conflicts with NAMELIST " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15352 | "attribute in %qs at %L", nlsym->name, |
Paul Thomas | 982186b | 2006-10-13 12:51:07 +0000 | [diff] [blame] | 15353 | &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15354 | return false; |
Paul Thomas | 982186b | 2006-10-13 12:51:07 +0000 | [diff] [blame] | 15355 | } |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15356 | } |
| 15357 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15358 | return true; |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 15359 | } |
| 15360 | |
| 15361 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15362 | static bool |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15363 | resolve_fl_parameter (gfc_symbol *sym) |
| 15364 | { |
| 15365 | /* A parameter array's shape needs to be constant. */ |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15366 | if (sym->as != NULL |
Daniel Franke | c317bc4 | 2007-07-29 10:17:59 -0400 | [diff] [blame] | 15367 | && (sym->as->type == AS_DEFERRED |
| 15368 | || is_non_constant_shape_array (sym))) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15369 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15370 | gfc_error ("Parameter array %qs at %L cannot be automatic " |
Daniel Franke | c317bc4 | 2007-07-29 10:17:59 -0400 | [diff] [blame] | 15371 | "or of deferred shape", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15372 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15373 | } |
| 15374 | |
Steven G. Kargl | f2bc4e4 | 2016-09-04 20:00:48 +0000 | [diff] [blame] | 15375 | /* Constraints on deferred type parameter. */ |
| 15376 | if (!deferred_requirements (sym)) |
| 15377 | return false; |
| 15378 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15379 | /* 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 Weil | 713485c | 2009-05-06 23:17:16 +0200 | [diff] [blame] | 15383 | && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name, |
| 15384 | sym->ns))) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15385 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15386 | gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a " |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15387 | "later IMPLICIT type", sym->name, &sym->declared_at); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15388 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15389 | } |
| 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 Burnus | 22c30bc | 2012-01-16 20:50:11 +0100 | [diff] [blame] | 15394 | if (sym->ts.type == BT_DERIVED |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 15395 | && !gfc_compare_types (&sym->ts, &sym->value->ts)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15396 | { |
| 15397 | gfc_error ("Incompatible derived type in PARAMETER at %L", |
| 15398 | &sym->value->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15399 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15400 | } |
Janus Weil | 103c4f7 | 2016-11-08 23:07:21 +0100 | [diff] [blame] | 15401 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15410 | return true; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15411 | } |
| 15412 | |
| 15413 | |
Paul Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15414 | /* Called by resolve_symbol to check PDTs. */ |
Paul Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 15415 | |
| 15416 | static void |
| 15417 | resolve_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 Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15424 | symbol_attribute *attr; |
Paul Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 15425 | |
| 15426 | if (sym->ts.type == BT_DERIVED) |
Paul Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15427 | { |
| 15428 | derived = sym->ts.u.derived; |
| 15429 | attr = &(sym->attr); |
| 15430 | } |
Paul Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 15431 | else if (sym->ts.type == BT_CLASS) |
Paul Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15432 | { |
| 15433 | derived = CLASS_DATA (sym)->ts.u.derived; |
| 15434 | attr = &(CLASS_DATA (sym)->attr); |
| 15435 | } |
Paul Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 15436 | 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 Thomas | 276515e | 2017-12-01 15:05:55 +0000 | [diff] [blame] | 15453 | |
| 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 Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 15461 | } |
| 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15480 | /* 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 | |
| 15484 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 15485 | resolve_symbol (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15486 | { |
Paul Thomas | a34437a | 2007-05-08 14:40:58 +0000 | [diff] [blame] | 15487 | int check_constant, mp_flag; |
Steven G. Kargl | 219fa8c | 2006-02-03 19:11:27 +0000 | [diff] [blame] | 15488 | gfc_symtree *symtree; |
| 15489 | gfc_symtree *this_symtree; |
| 15490 | gfc_namespace *ns; |
| 15491 | gfc_component *c; |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15492 | symbol_attribute class_attr; |
| 15493 | gfc_array_spec *as; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 15494 | bool saved_specification_expr; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15495 | |
Mark Eggleston | dbeaa7a | 2020-04-23 10:33:14 +0100 | [diff] [blame] | 15496 | if (sym->resolve_symbol_called >= 1) |
Mikael Morin | 4af8d04 | 2013-02-04 18:34:30 +0000 | [diff] [blame] | 15497 | return; |
Mark Eggleston | dbeaa7a | 2020-04-23 10:33:14 +0100 | [diff] [blame] | 15498 | sym->resolve_symbol_called = 1; |
Mikael Morin | 4af8d04 | 2013-02-04 18:34:30 +0000 | [diff] [blame] | 15499 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15500 | /* 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 Vehreschild | 6fd9c6f | 2016-10-14 10:52:10 +0200 | [diff] [blame] | 15505 | /* 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 Anlauf | 3cbc0fb | 2020-06-27 14:56:33 +0200 | [diff] [blame] | 15510 | && CLASS_DATA (sym)->ts.u.derived |
Andre Vehreschild | 6479f45 | 2016-12-13 17:47:48 +0100 | [diff] [blame] | 15511 | && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp |
| 15512 | || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) |
Andre Vehreschild | 6fd9c6f | 2016-10-14 10:52:10 +0200 | [diff] [blame] | 15513 | { |
| 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 Burnus | 8e54f13 | 2012-09-03 08:35:59 +0200 | [diff] [blame] | 15519 | if (sym->attr.artificial) |
| 15520 | return; |
| 15521 | |
Paul Thomas | 8b70431 | 2012-12-20 00:15:00 +0000 | [diff] [blame] | 15522 | if (sym->attr.unlimited_polymorphic) |
| 15523 | return; |
| 15524 | |
Tobias Burnus | 4f94c38 | 2022-05-17 11:01:04 +0200 | [diff] [blame] | 15525 | 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 Burnus | 60fa393 | 2012-04-11 15:08:32 +0200 | [diff] [blame] | 15532 | if (sym->attr.flavor == FL_UNKNOWN |
| 15533 | || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic |
| 15534 | && !sym->attr.generic && !sym->attr.external |
Janus Weil | 6bd5968 | 2013-12-30 18:33:21 +0100 | [diff] [blame] | 15535 | && sym->attr.if_source == IFSRC_UNKNOWN |
| 15536 | && sym->ts.type == BT_UNKNOWN)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15537 | { |
Paul Thomas | 24d36d2 | 2005-07-19 20:13:53 +0000 | [diff] [blame] | 15538 | |
| 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 Weil | 7ca1703 | 2010-12-17 13:31:54 +0100 | [diff] [blame] | 15545 | if (symtree && (symtree->n.sym->generic || |
| 15546 | (symtree->n.sym->attr.flavor == FL_PROCEDURE |
| 15547 | && sym->ns->construct_entities))) |
Paul Thomas | 24d36d2 | 2005-07-19 20:13:53 +0000 | [diff] [blame] | 15548 | { |
| 15549 | this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, |
| 15550 | sym->name); |
Mikael Morin | 511820a | 2015-03-08 11:52:51 +0000 | [diff] [blame] | 15551 | 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 Thomas | 24d36d2 | 2005-07-19 20:13:53 +0000 | [diff] [blame] | 15558 | } |
| 15559 | } |
| 15560 | |
| 15561 | /* Otherwise give it a flavor according to such attributes as |
| 15562 | it has. */ |
Tobias Burnus | 60fa393 | 2012-04-11 15:08:32 +0200 | [diff] [blame] | 15563 | if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0 |
| 15564 | && sym->attr.intrinsic == 0) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15565 | sym->attr.flavor = FL_VARIABLE; |
Tobias Burnus | 60fa393 | 2012-04-11 15:08:32 +0200 | [diff] [blame] | 15566 | else if (sym->attr.flavor == FL_UNKNOWN) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15567 | { |
| 15568 | sym->attr.flavor = FL_PROCEDURE; |
| 15569 | if (sym->attr.dimension) |
| 15570 | sym->attr.function = 1; |
| 15571 | } |
| 15572 | } |
| 15573 | |
Janus Weil | c73b647 | 2009-04-22 11:05:58 +0200 | [diff] [blame] | 15574 | 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 Weil | 0e8d854 | 2012-07-31 20:32:41 +0200 | [diff] [blame] | 15577 | if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15578 | && !resolve_procedure_interface (sym)) |
Janus Weil | 2fcac97 | 2010-08-23 14:26:42 +0200 | [diff] [blame] | 15579 | return; |
Janus Weil | 6977374 | 2007-09-04 13:50:35 +0000 | [diff] [blame] | 15580 | |
Tobias Burnus | c064bf1 | 2010-06-08 08:37:32 +0200 | [diff] [blame] | 15581 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15594 | if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) |
Tobias Schlüter | 110eec2 | 2005-12-22 12:37:03 +0100 | [diff] [blame] | 15595 | return; |
| 15596 | |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 15597 | else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION) |
| 15598 | && !resolve_fl_struct (sym)) |
| 15599 | return; |
| 15600 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15601 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15608 | /* Make sure that the intrinsic is consistent with its internal |
| 15609 | representation. This needs to be done before assigning a default |
Daniel Franke | eb2c598 | 2007-06-30 12:26:55 -0400 | [diff] [blame] | 15610 | type to avoid spurious warnings. */ |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 15611 | if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15612 | && !gfc_resolve_intrinsic (sym, &sym->declared_at)) |
Janus Weil | f603813 | 2009-08-13 13:16:16 +0200 | [diff] [blame] | 15613 | return; |
Daniel Franke | eb2c598 | 2007-06-30 12:26:55 -0400 | [diff] [blame] | 15614 | |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 15615 | /* Resolve associate names. */ |
Daniel Kraft | 03af1e4 | 2010-06-10 16:47:49 +0200 | [diff] [blame] | 15616 | if (sym->assoc) |
Daniel Kraft | 3e78238 | 2010-08-26 21:48:43 +0200 | [diff] [blame] | 15617 | resolve_assoc_var (sym, true); |
Daniel Kraft | 03af1e4 | 2010-06-10 16:47:49 +0200 | [diff] [blame] | 15618 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15619 | /* 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 Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15623 | { |
| 15624 | gfc_set_default_type (sym, 1, NULL); |
| 15625 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15626 | |
Janus Weil | fc9c6e5 | 2009-06-27 00:11:15 +0200 | [diff] [blame] | 15627 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15632 | if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) |
| 15633 | { |
Paul Thomas | 5309625 | 2005-11-01 05:53:29 +0000 | [diff] [blame] | 15634 | /* The specific case of an external procedure should emit an error |
| 15635 | in the case that there is no implicit type. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15636 | if (!mp_flag) |
Louis Krupp | 6e48e77 | 2016-10-05 18:00:30 +0000 | [diff] [blame] | 15637 | { |
| 15638 | if (!sym->attr.mixed_entry_master) |
| 15639 | gfc_set_default_type (sym, sym->attr.external, NULL); |
| 15640 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15641 | else |
| 15642 | { |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 15643 | /* Result may be in another namespace. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15644 | resolve_symbol (sym->result); |
| 15645 | |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 15646 | 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 Burnus | fe4e525 | 2010-06-21 16:15:56 +0200 | [diff] [blame] | 15653 | sym->attr.contiguous = sym->result->attr.contiguous; |
Janus Weil | 3070bab | 2009-04-09 11:39:09 +0200 | [diff] [blame] | 15654 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15655 | } |
| 15656 | } |
| 15657 | } |
Mikael Morin | e3d748d | 2011-07-07 22:58:16 +0200 | [diff] [blame] | 15658 | else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 15659 | { |
| 15660 | bool saved_specification_expr = specification_expr; |
Paul Thomas | 7ae210d | 2020-12-05 14:14:19 +0000 | [diff] [blame] | 15661 | bool saved_formal_arg_flag = formal_arg_flag; |
| 15662 | |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 15663 | specification_expr = true; |
Paul Thomas | 7ae210d | 2020-12-05 14:14:19 +0000 | [diff] [blame] | 15664 | formal_arg_flag = true; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 15665 | gfc_resolve_array_spec (sym->result->as, false); |
Paul Thomas | 7ae210d | 2020-12-05 14:14:19 +0000 | [diff] [blame] | 15666 | formal_arg_flag = saved_formal_arg_flag; |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 15667 | specification_expr = saved_specification_expr; |
| 15668 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15669 | |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 15670 | if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15671 | { |
| 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 VandeVondele | 1cc0e19 | 2014-09-20 11:48:00 +0000 | [diff] [blame] | 15682 | /* F2008, C530. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15683 | if (sym->attr.contiguous |
| 15684 | && (!class_attr.dimension |
Tobias Burnus | 8e54f13 | 2012-09-03 08:35:59 +0200 | [diff] [blame] | 15685 | || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK |
| 15686 | && !class_attr.pointer))) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15687 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15688 | gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an " |
Tobias Burnus | 8e54f13 | 2012-09-03 08:35:59 +0200 | [diff] [blame] | 15689 | "array pointer or an assumed-shape or assumed-rank array", |
| 15690 | sym->name, &sym->declared_at); |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15691 | return; |
| 15692 | } |
| 15693 | |
Tobias Schlüter | f5e440e | 2004-06-21 19:23:52 +0200 | [diff] [blame] | 15694 | /* Assumed size arrays and assumed shape arrays must be dummy |
Daniel Kraft | f5ca06e | 2010-08-13 09:26:05 +0200 | [diff] [blame] | 15695 | arguments. Array-spec's of implied-shape should have been resolved to |
| 15696 | AS_EXPLICIT already. */ |
Tobias Schlüter | f5e440e | 2004-06-21 19:23:52 +0200 | [diff] [blame] | 15697 | |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15698 | if (as) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15699 | { |
Thomas Koenig | b04bebd | 2017-10-18 20:32:34 +0000 | [diff] [blame] | 15700 | /* 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 Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15717 | if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) |
| 15718 | || as->type == AS_ASSUMED_SHAPE) |
Paul Thomas | 4cc7046 | 2012-12-21 14:29:34 +0000 | [diff] [blame] | 15719 | && !sym->attr.dummy && !sym->attr.select_type_temporary) |
Daniel Kraft | f5ca06e | 2010-08-13 09:26:05 +0200 | [diff] [blame] | 15720 | { |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 15721 | if (as->type == AS_ASSUMED_SIZE) |
Daniel Kraft | f5ca06e | 2010-08-13 09:26:05 +0200 | [diff] [blame] | 15722 | 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 15729 | /* TS 29113, C535a. */ |
Paul Thomas | 4cc7046 | 2012-12-21 14:29:34 +0000 | [diff] [blame] | 15730 | if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy |
Paul Thomas | 70570ec | 2019-09-01 12:53:02 +0000 | [diff] [blame] | 15731 | && !sym->attr.select_type_temporary |
| 15732 | && !(cs_base && cs_base->current |
| 15733 | && cs_base->current->op == EXEC_SELECT_RANK)) |
Tobias Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 15734 | { |
| 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üter | a4ac5dd | 2004-06-09 14:35:39 +0200 | [diff] [blame] | 15746 | } |
| 15747 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15748 | /* 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 Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 15752 | if (!sym->attr.dummy |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 15753 | && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 15754 | { |
| 15755 | gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); |
| 15756 | return; |
| 15757 | } |
| 15758 | |
Paul Thomas | 06469ef | 2006-12-03 07:18:22 +0000 | [diff] [blame] | 15759 | if (sym->attr.value && !sym->attr.dummy) |
| 15760 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15761 | gfc_error ("%qs at %L cannot have the VALUE attribute because " |
Tobias Burnus | 1084b6b | 2007-02-20 10:16:58 +0100 | [diff] [blame] | 15762 | "it is not a dummy argument", sym->name, &sym->declared_at); |
Paul Thomas | 06469ef | 2006-12-03 07:18:22 +0000 | [diff] [blame] | 15763 | return; |
| 15764 | } |
| 15765 | |
Tobias Burnus | 1084b6b | 2007-02-20 10:16:58 +0100 | [diff] [blame] | 15766 | if (sym->attr.value && sym->ts.type == BT_CHARACTER) |
| 15767 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15768 | gfc_charlen *cl = sym->ts.u.cl; |
Tobias Burnus | 1084b6b | 2007-02-20 10:16:58 +0100 | [diff] [blame] | 15769 | if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) |
| 15770 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15771 | gfc_error ("Character dummy variable %qs at %L with VALUE " |
Tobias Burnus | 1084b6b | 2007-02-20 10:16:58 +0100 | [diff] [blame] | 15772 | "attribute must have constant length", |
| 15773 | sym->name, &sym->declared_at); |
| 15774 | return; |
| 15775 | } |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15776 | |
| 15777 | if (sym->ts.is_c_interop |
| 15778 | && mpz_cmp_si (cl->length->value.integer, 1) != 0) |
| 15779 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15780 | gfc_error ("C interoperable character dummy variable %qs at %L " |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15781 | "with VALUE attribute must have length one", |
| 15782 | sym->name, &sym->declared_at); |
| 15783 | return; |
| 15784 | } |
| 15785 | } |
| 15786 | |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15787 | 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15793 | gfc_error ("The derived type %qs at %L is of type %qs, " |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15794 | "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 Burnus | e7ac6a7 | 2013-04-16 22:54:21 +0200 | [diff] [blame] | 15801 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15856 | { |
Tobias Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 15857 | /* 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 Burnus | c62c662 | 2012-07-20 07:56:37 +0200 | [diff] [blame] | 15872 | 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 Burnus | 45a6932 | 2012-03-03 09:40:24 +0100 | [diff] [blame] | 15879 | 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 Koenig | c4fa898 | 2017-08-11 17:45:36 +0000 | [diff] [blame] | 15887 | /* 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15899 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15900 | bool t = true; |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15901 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15902 | /* 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áñez | c4100ea | 2014-12-11 15:13:33 +0000 | [diff] [blame] | 15907 | gfc_error ("Variable %qs at %L cannot be BIND(C) because it " |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15908 | "is neither a COMMON block nor declared at the " |
| 15909 | "module level scope", sym->name, &(sym->declared_at)); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15910 | t = false; |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15911 | } |
Thomas Koenig | 3be34c0 | 2018-01-29 07:11:16 +0000 | [diff] [blame] | 15912 | 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 Koenig | c4fa898 | 2017-08-11 17:45:36 +0000 | [diff] [blame] | 15921 | else if (sym->common_head != NULL && sym->attr.implicit_type == 0) |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15922 | { |
| 15923 | t = verify_com_block_vars_c_interop (sym->common_head); |
| 15924 | } |
Thomas Koenig | c4fa898 | 2017-08-11 17:45:36 +0000 | [diff] [blame] | 15925 | else if (sym->attr.implicit_type == 0) |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15926 | { |
| 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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15930 | sym->ts.u.derived->attr.is_c_interop != 1) |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15931 | { |
| 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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15936 | if (sym->ts.u.derived->attr.is_bind_c != 1) |
| 15937 | verify_bind_c_derived_type (sym->ts.u.derived); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15938 | t = false; |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15939 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 15940 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15941 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15949 | if (!t) |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 15950 | { |
| 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 Burnus | 1084b6b | 2007-02-20 10:16:58 +0100 | [diff] [blame] | 15956 | } |
| 15957 | |
Paul Thomas | 976e21f | 2005-10-26 05:20:19 +0000 | [diff] [blame] | 15958 | /* 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 Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15966 | if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c |
| 15967 | && sym->ts.u.derived->components == NULL |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15968 | && !sym->ts.u.derived->attr.zero_comp) |
Paul Thomas | 976e21f | 2005-10-26 05:20:19 +0000 | [diff] [blame] | 15969 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15970 | gfc_error ("The derived type %qs at %L is of type %qs, " |
Brooks Moses | e25a0da | 2006-11-16 03:05:28 +0000 | [diff] [blame] | 15971 | "which has not been defined", sym->name, |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15972 | &sym->declared_at, sym->ts.u.derived->name); |
Paul Thomas | 976e21f | 2005-10-26 05:20:19 +0000 | [diff] [blame] | 15973 | sym->ts.type = BT_UNKNOWN; |
| 15974 | return; |
| 15975 | } |
| 15976 | |
Paul Thomas | c1203a7 | 2008-03-24 19:11:24 +0000 | [diff] [blame] | 15977 | /* 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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15981 | && sym->ts.u.derived->attr.use_assoc |
Thomas Koenig | 96ffc6c | 2009-01-05 10:43:39 +0000 | [diff] [blame] | 15982 | && sym->ns->proc_name |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15983 | && sym->ns->proc_name->attr.flavor == FL_MODULE |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 15984 | && !resolve_fl_derived (sym->ts.u.derived)) |
Tobias Burnus | c3f3495 | 2011-11-16 22:37:43 +0100 | [diff] [blame] | 15985 | return; |
Paul Thomas | c1203a7 | 2008-03-24 19:11:24 +0000 | [diff] [blame] | 15986 | |
Tobias Burnus | a08a575 | 2007-09-17 17:55:22 +0200 | [diff] [blame] | 15987 | /* 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 Burnus | 7205223 | 2007-12-14 16:14:29 +0100 | [diff] [blame] | 15992 | && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 15993 | && !sym->ts.u.derived->attr.use_assoc |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 15994 | && gfc_check_symbol_access (sym) |
| 15995 | && !gfc_check_symbol_access (sym->ts.u.derived) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 15996 | && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE " |
| 15997 | "derived type %qs", |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 15998 | (sym->attr.flavor == FL_PARAMETER) |
| 15999 | ? "parameter" : "variable", |
| 16000 | sym->name, &sym->declared_at, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16001 | sym->ts.u.derived->name)) |
Tobias Burnus | a08a575 | 2007-09-17 17:55:22 +0200 | [diff] [blame] | 16002 | return; |
| 16003 | |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 16004 | /* F2008, C1302. */ |
| 16005 | if (sym->ts.type == BT_DERIVED |
Tobias Burnus | 3b6fa7a | 2011-08-18 17:10:25 +0200 | [diff] [blame] | 16006 | && ((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 Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 16010 | { |
Tobias Burnus | 3b6fa7a | 2011-08-18 17:10:25 +0200 | [diff] [blame] | 16011 | 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 Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 16014 | return; |
| 16015 | } |
| 16016 | |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 16017 | /* 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'Humieres | 370d975 | 2017-07-03 20:03:51 +0200 | [diff] [blame] | 16025 | "type EVENT_TYPE must be a coarray", sym->name, |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 16026 | &sym->declared_at); |
| 16027 | return; |
| 16028 | } |
| 16029 | |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 16030 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16033 | && sym->attr.dummy |
| 16034 | && sym->attr.intent == INTENT_OUT |
| 16035 | && sym->as |
| 16036 | && sym->as->type == AS_ASSUMED_SIZE) |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 16037 | { |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 16038 | for (c = sym->ts.u.derived->components; c; c = c->next) |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 16039 | { |
| 16040 | if (c->initializer) |
| 16041 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16042 | gfc_error ("The INTENT(OUT) dummy argument %qs at %L is " |
Paul Thomas | 4213f93 | 2005-10-17 20:52:37 +0000 | [diff] [blame] | 16043 | "ASSUMED SIZE and so cannot have a default initializer", |
| 16044 | sym->name, &sym->declared_at); |
| 16045 | return; |
| 16046 | } |
| 16047 | } |
| 16048 | } |
| 16049 | |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 16050 | /* F2008, C542. */ |
| 16051 | if (sym->ts.type == BT_DERIVED && sym->attr.dummy |
| 16052 | && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16053 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16054 | gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16055 | "INTENT(OUT)", sym->name, &sym->declared_at); |
| 16056 | return; |
| 16057 | } |
Tobias Burnus | fea5493 | 2011-06-20 23:12:39 +0200 | [diff] [blame] | 16058 | |
Tobias Burnus | 5df445a | 2015-12-02 22:59:05 +0100 | [diff] [blame] | 16059 | /* 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 Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16068 | /* F2008, C525. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16069 | if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) |
| 16070 | || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 16071 | && sym->ts.u.derived && CLASS_DATA (sym) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16072 | && CLASS_DATA (sym)->attr.coarray_comp)) |
| 16073 | || class_attr.codimension) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16074 | && (sym->attr.result || sym->result == sym)) |
| 16075 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16076 | gfc_error ("Function result %qs at %L shall not be a coarray or have " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16077 | "a coarray component", sym->name, &sym->declared_at); |
| 16078 | return; |
| 16079 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16080 | |
| 16081 | /* F2008, C524. */ |
| 16082 | if (sym->attr.codimension && sym->ts.type == BT_DERIVED |
| 16083 | && sym->ts.u.derived->ts.is_iso_c) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16084 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16085 | gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16086 | "shall not be a coarray", sym->name, &sym->declared_at); |
| 16087 | return; |
| 16088 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16089 | |
| 16090 | /* F2008, C525. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16091 | if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) |
| 16092 | || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 16093 | && sym->ts.u.derived && CLASS_DATA (sym) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16094 | && CLASS_DATA (sym)->attr.coarray_comp)) |
| 16095 | && (class_attr.codimension || class_attr.pointer || class_attr.dimension |
| 16096 | || class_attr.allocatable)) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16097 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16098 | gfc_error ("Variable %qs at %L with coarray component shall be a " |
Tobias Burnus | abc2d80 | 2013-07-15 10:25:48 +0200 | [diff] [blame] | 16099 | "nonpointer, nonallocatable scalar, which is not a coarray", |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16100 | sym->name, &sym->declared_at); |
| 16101 | return; |
| 16102 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16103 | |
| 16104 | /* F2008, C526. The function-result case was handled above. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16105 | if (class_attr.codimension |
| 16106 | && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save |
| 16107 | || sym->attr.select_type_temporary |
Paul Thomas | b89a63b | 2017-09-21 18:40:21 +0000 | [diff] [blame] | 16108 | || sym->attr.associate_var |
Fritz Reese | 34d567d | 2016-09-23 21:06:18 +0000 | [diff] [blame] | 16109 | || (sym->ns->save_all && !sym->attr.automatic) |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16110 | || 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 Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16113 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16114 | gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16115 | "nor a dummy argument", sym->name, &sym->declared_at); |
| 16116 | return; |
| 16117 | } |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16118 | /* F2008, C528. */ |
| 16119 | else if (class_attr.codimension && !sym->attr.select_type_temporary |
| 16120 | && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16121 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16122 | gfc_error ("Coarray variable %qs at %L shall not have codimensions with " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16123 | "deferred shape", sym->name, &sym->declared_at); |
| 16124 | return; |
| 16125 | } |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16126 | else if (class_attr.codimension && class_attr.allocatable && as |
| 16127 | && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED)) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16128 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16129 | gfc_error ("Allocatable coarray variable %qs at %L must have " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16130 | "deferred shape", sym->name, &sym->declared_at); |
| 16131 | return; |
| 16132 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16133 | |
| 16134 | /* F2008, C541. */ |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16135 | if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) |
| 16136 | || (sym->ts.type == BT_CLASS && sym->attr.class_ok |
Harald Anlauf | 70c884a | 2020-07-10 21:35:35 +0200 | [diff] [blame] | 16137 | && sym->ts.u.derived && CLASS_DATA (sym) |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16138 | && CLASS_DATA (sym)->attr.coarray_comp)) |
| 16139 | || (class_attr.codimension && class_attr.allocatable)) |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16140 | && sym->attr.dummy && sym->attr.intent == INTENT_OUT) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16141 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16142 | gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an " |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16143 | "allocatable coarray or have coarray components", |
| 16144 | sym->name, &sym->declared_at); |
| 16145 | return; |
| 16146 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16147 | |
Tobias Burnus | fac665b | 2011-12-19 09:15:47 +0100 | [diff] [blame] | 16148 | if (class_attr.codimension && sym->attr.dummy |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16149 | && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16150 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16151 | gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) " |
| 16152 | "procedure %qs", sym->name, &sym->declared_at, |
Tobias Burnus | e535f1b | 2011-08-15 22:10:51 +0200 | [diff] [blame] | 16153 | sym->ns->proc_name->name); |
| 16154 | return; |
| 16155 | } |
Tobias Burnus | be59db2 | 2010-04-06 20:16:13 +0200 | [diff] [blame] | 16156 | |
Tobias Burnus | d0841b5 | 2013-01-09 17:20:33 +0100 | [diff] [blame] | 16157 | 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 Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16167 | && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at " |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16168 | "%L with non-C_Bool kind in BIND(C) procedure " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16169 | "%qs", sym->name, &sym->declared_at, |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16170 | sym->ns->proc_name->name)) |
Tobias Burnus | d0841b5 | 2013-01-09 17:20:33 +0100 | [diff] [blame] | 16171 | return; |
| 16172 | else if (!gfc_logical_kinds[i].c_bool |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16173 | && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable " |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16174 | "%qs at %L with non-C_Bool kind in " |
| 16175 | "BIND(C) procedure %qs", sym->name, |
Paul Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 16176 | &sym->declared_at, |
| 16177 | sym->attr.function ? sym->name |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16178 | : sym->ns->proc_name->name)) |
Tobias Burnus | d0841b5 | 2013-01-09 17:20:33 +0100 | [diff] [blame] | 16179 | return; |
| 16180 | } |
| 16181 | |
Paul Brook | af30f79 | 2005-01-22 18:23:43 +0000 | [diff] [blame] | 16182 | switch (sym->attr.flavor) |
Paul Brook | 54b4ba6 | 2004-05-18 00:48:05 +0000 | [diff] [blame] | 16183 | { |
Paul Brook | af30f79 | 2005-01-22 18:23:43 +0000 | [diff] [blame] | 16184 | case FL_VARIABLE: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16185 | if (!resolve_fl_variable (sym, mp_flag)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16186 | return; |
| 16187 | break; |
Paul Brook | 54b4ba6 | 2004-05-18 00:48:05 +0000 | [diff] [blame] | 16188 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16189 | case FL_PROCEDURE: |
Jerry DeLisle | c0f0e35 | 2016-02-07 20:15:55 +0000 | [diff] [blame] | 16190 | 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 Loosemore | 6791469 | 2019-01-09 16:37:45 -0500 | [diff] [blame] | 16198 | gfc_error ("Namelist %qs cannot be an argument to " |
Jerry DeLisle | c0f0e35 | 2016-02-07 20:15:55 +0000 | [diff] [blame] | 16199 | "subroutine or function at %L", |
| 16200 | formal->sym->name, &sym->declared_at); |
| 16201 | return; |
| 16202 | } |
| 16203 | } |
| 16204 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16205 | if (!resolve_fl_procedure (sym, mp_flag)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16206 | return; |
Paul Brook | af30f79 | 2005-01-22 18:23:43 +0000 | [diff] [blame] | 16207 | break; |
| 16208 | |
| 16209 | case FL_NAMELIST: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16210 | if (!resolve_fl_namelist (sym)) |
Paul Thomas | 3e1cf50 | 2006-02-19 15:24:26 +0000 | [diff] [blame] | 16211 | return; |
Paul Thomas | 68ea355 | 2006-01-21 09:08:54 +0000 | [diff] [blame] | 16212 | break; |
| 16213 | |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16214 | case FL_PARAMETER: |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16215 | if (!resolve_fl_parameter (sym)) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16216 | return; |
Paul Thomas | e0e85e0 | 2005-12-22 07:05:22 +0000 | [diff] [blame] | 16217 | break; |
| 16218 | |
Paul Brook | af30f79 | 2005-01-22 18:23:43 +0000 | [diff] [blame] | 16219 | default: |
| 16220 | break; |
Paul Brook | 54b4ba6 | 2004-05-18 00:48:05 +0000 | [diff] [blame] | 16221 | } |
| 16222 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16223 | /* Resolve array specifier. Check as well some constraints |
Kazu Hirata | f7b529f | 2004-11-08 14:56:41 +0000 | [diff] [blame] | 16224 | on COMMON blocks. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16225 | |
| 16226 | check_constant = sym->attr.in_common && !sym->attr.pointer; |
Paul Thomas | 98bbe5e | 2006-12-04 11:16:12 +0000 | [diff] [blame] | 16227 | |
| 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. Kargl | a81a6d5 | 2019-01-15 20:17:35 +0000 | [diff] [blame] | 16231 | if ((sym->attr.function || sym->attr.result) && sym->as) |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 16232 | formal_arg_flag = true; |
Paul Thomas | 98bbe5e | 2006-12-04 11:16:12 +0000 | [diff] [blame] | 16233 | |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 16234 | saved_specification_expr = specification_expr; |
| 16235 | specification_expr = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16236 | gfc_resolve_array_spec (sym->as, check_constant); |
Tobias Burnus | fd06118 | 2012-10-18 19:09:13 +0200 | [diff] [blame] | 16237 | specification_expr = saved_specification_expr; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16238 | |
Janus Weil | 7a28353 | 2016-12-13 19:55:20 +0100 | [diff] [blame] | 16239 | formal_arg_flag = false; |
Paul Thomas | 98bbe5e | 2006-12-04 11:16:12 +0000 | [diff] [blame] | 16240 | |
Paul Thomas | a34437a | 2007-05-08 14:40:58 +0000 | [diff] [blame] | 16241 | /* Resolve formal namespaces. */ |
Janus Weil | f6ddbf1 | 2009-07-15 10:41:29 +0200 | [diff] [blame] | 16242 | if (sym->formal_ns && sym->formal_ns != gfc_current_ns |
Janus Weil | e4c1aa1 | 2009-08-20 11:33:01 +0200 | [diff] [blame] | 16243 | && !sym->attr.contained && !sym->attr.intrinsic) |
Paul Thomas | a34437a | 2007-05-08 14:40:58 +0000 | [diff] [blame] | 16244 | gfc_resolve (sym->formal_ns); |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 16245 | |
Janus Weil | acbdc37 | 2009-07-13 15:41:37 +0200 | [diff] [blame] | 16246 | /* 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 Anlauf | b887449 | 2020-07-02 20:48:16 +0200 | [diff] [blame] | 16256 | if (sym->formal_ns && sym->ns != formal->sym->ns) |
Tobias Burnus | 6f79f4d | 2012-08-27 14:07:43 +0200 | [diff] [blame] | 16257 | sym->formal_ns->refs++; |
Janus Weil | acbdc37 | 2009-07-13 15:41:37 +0200 | [diff] [blame] | 16258 | } |
| 16259 | } |
| 16260 | |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 16261 | /* Check threadprivate restrictions. */ |
Tobias Burnus | d065576 | 2021-03-12 16:34:10 +0100 | [diff] [blame] | 16262 | if (sym->attr.threadprivate |
| 16263 | && !(sym->attr.save || sym->attr.data || sym->attr.in_common) |
Fritz Reese | 34d567d | 2016-09-23 21:06:18 +0000 | [diff] [blame] | 16264 | && !(sym->ns->save_all && !sym->attr.automatic) |
Tobias Burnus | d065576 | 2021-03-12 16:34:10 +0100 | [diff] [blame] | 16265 | && sym->module == NULL |
| 16266 | && (sym->ns->proc_name == NULL |
Tobias Burnus | 62e1bd6 | 2021-05-14 19:19:26 +0200 | [diff] [blame] | 16267 | || (sym->ns->proc_name->attr.flavor != FL_MODULE |
| 16268 | && !sym->ns->proc_name->attr.is_main_program))) |
Jakub Jelinek | 6c7a4df | 2006-02-14 17:38:03 +0100 | [diff] [blame] | 16269 | gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 16270 | |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 16271 | /* Check omp declare target restrictions. */ |
| 16272 | if (sym->attr.omp_declare_target |
| 16273 | && sym->attr.flavor == FL_VARIABLE |
| 16274 | && !sym->attr.save |
Fritz Reese | 34d567d | 2016-09-23 21:06:18 +0000 | [diff] [blame] | 16275 | && !(sym->ns->save_all && !sym->attr.automatic) |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 16276 | && (!sym->attr.in_common |
| 16277 | && sym->module == NULL |
| 16278 | && (sym->ns->proc_name == NULL |
Tobias Burnus | 62e1bd6 | 2021-05-14 19:19:26 +0200 | [diff] [blame] | 16279 | || (sym->ns->proc_name->attr.flavor != FL_MODULE |
| 16280 | && !sym->ns->proc_name->attr.is_main_program)))) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16281 | gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd", |
Jakub Jelinek | f014c65 | 2014-06-18 09:16:12 +0200 | [diff] [blame] | 16282 | sym->name, &sym->declared_at); |
| 16283 | |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 16284 | /* 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 Thomas | 7114edc | 2006-11-09 18:42:28 +0000 | [diff] [blame] | 16287 | if (sym->ts.type == BT_DERIVED |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16288 | && !sym->value |
| 16289 | && !sym->attr.allocatable |
| 16290 | && !sym->attr.alloc_comp) |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 16291 | { |
| 16292 | symbol_attribute *a = &sym->attr; |
| 16293 | |
| 16294 | if ((!a->save && !a->dummy && !a->pointer |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16295 | && !a->in_common && !a->use_assoc |
Paul Thomas | e6110fa | 2017-10-13 18:59:34 +0000 | [diff] [blame] | 16296 | && 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 Burnus | 51d9ef7 | 2021-10-04 09:38:43 +0200 | [diff] [blame] | 16302 | || (a->dummy && !a->pointer && a->intent == INTENT_OUT |
| 16303 | && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) |
Paul Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 16304 | apply_default_init (sym); |
Andre Vehreschild | c16126a | 2015-07-06 12:26:12 +0200 | [diff] [blame] | 16305 | 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 Thomas | 6b591ec | 2006-10-19 04:51:14 +0000 | [diff] [blame] | 16311 | } |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 16312 | |
Janus Weil | 50f3080 | 2010-09-01 22:50:46 +0200 | [diff] [blame] | 16313 | if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns |
| 16314 | && sym->attr.dummy && sym->attr.intent == INTENT_OUT |
Tobias Burnus | 51d9ef7 | 2021-10-04 09:38:43 +0200 | [diff] [blame] | 16315 | && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY |
Janus Weil | c330d18 | 2010-09-02 14:34:26 +0200 | [diff] [blame] | 16316 | && !CLASS_DATA (sym)->attr.class_pointer |
| 16317 | && !CLASS_DATA (sym)->attr.allocatable) |
Tobias Burnus | 86e6a23 | 2010-09-02 12:11:39 +0200 | [diff] [blame] | 16318 | apply_default_init (sym); |
Janus Weil | 50f3080 | 2010-09-01 22:50:46 +0200 | [diff] [blame] | 16319 | |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 16320 | /* 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16323 | if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 16324 | return; |
Paul Thomas | 62d3c07 | 2017-09-17 18:24:37 +0000 | [diff] [blame] | 16325 | |
| 16326 | if (sym->param_list) |
| 16327 | resolve_pdt (sym); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16328 | } |
| 16329 | |
| 16330 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16331 | /************* Resolve DATA statements *************/ |
| 16332 | |
| 16333 | static struct |
| 16334 | { |
| 16335 | gfc_data_value *vnode; |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16336 | mpz_t left; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16337 | } |
| 16338 | values; |
| 16339 | |
| 16340 | |
| 16341 | /* Advance the values structure to point to the next value in the data list. */ |
| 16342 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16343 | static bool |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16344 | next_data_value (void) |
| 16345 | { |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16346 | while (mpz_cmp_ui (values.left, 0) == 0) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16347 | { |
Paul Thomas | abeab93 | 2009-06-11 20:11:59 +0000 | [diff] [blame] | 16348 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16349 | if (values.vnode->next == NULL) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16350 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16351 | |
| 16352 | values.vnode = values.vnode->next; |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16353 | mpz_set (values.left, values.vnode->repeat); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16354 | } |
| 16355 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16356 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16357 | } |
| 16358 | |
| 16359 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16360 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16361 | check_data_variable (gfc_data_variable *var, locus *where) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16362 | { |
| 16363 | gfc_expr *e; |
| 16364 | mpz_t size; |
| 16365 | mpz_t offset; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16366 | bool t; |
Tobias Schlüter | f5e440e | 2004-06-21 19:23:52 +0200 | [diff] [blame] | 16367 | ar_type mark = AR_UNKNOWN; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16368 | int i; |
| 16369 | mpz_t section_index[GFC_MAX_DIMENSIONS]; |
| 16370 | gfc_ref *ref; |
| 16371 | gfc_array_ref *ar; |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16372 | gfc_symbol *sym; |
| 16373 | int has_pointer; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16374 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16375 | if (!gfc_resolve_expr (var->expr)) |
| 16376 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16377 | |
| 16378 | ar = NULL; |
| 16379 | mpz_init_set_si (offset, 0); |
| 16380 | e = var->expr; |
| 16381 | |
Tobias Burnus | 63617e3 | 2016-06-21 20:36:25 +0200 | [diff] [blame] | 16382 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16386 | if (e->expr_type != EXPR_VARIABLE) |
Steven G. Kargl | 019761d | 2018-12-09 06:09:47 +0000 | [diff] [blame] | 16387 | { |
| 16388 | gfc_error ("Expecting definable entity near %L", where); |
| 16389 | return false; |
| 16390 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16391 | |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16392 | sym = e->symtree->n.sym; |
| 16393 | |
| 16394 | if (sym->ns->is_block_data && !sym->attr.in_common) |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16395 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16396 | gfc_error ("BLOCK DATA element %qs at %L must be in COMMON", |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16397 | sym->name, &sym->declared_at); |
Steven G. Kargl | 019761d | 2018-12-09 06:09:47 +0000 | [diff] [blame] | 16398 | return false; |
Paul Thomas | 2ed8d22 | 2006-02-13 21:22:55 +0000 | [diff] [blame] | 16399 | } |
| 16400 | |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16401 | if (e->ref == NULL && sym->as) |
Jerry DeLisle | f1607c0 | 2007-11-25 22:12:19 +0000 | [diff] [blame] | 16402 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16403 | gfc_error ("DATA array %qs at %L must be specified in a previous" |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16404 | " declaration", sym->name, where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16405 | return false; |
Jerry DeLisle | f1607c0 | 2007-11-25 22:12:19 +0000 | [diff] [blame] | 16406 | } |
| 16407 | |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 16408 | if (gfc_is_coindexed (e)) |
| 16409 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 16410 | gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name, |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 16411 | where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16412 | return false; |
Tobias Burnus | a3935ff | 2011-04-04 20:35:13 +0200 | [diff] [blame] | 16413 | } |
| 16414 | |
Steven G. Kargl | ade8fdb | 2019-08-14 04:22:31 +0000 | [diff] [blame] | 16415 | has_pointer = sym->attr.pointer; |
| 16416 | |
Paul Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16417 | 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. Kargl | ade8fdb | 2019-08-14 04:22:31 +0000 | [diff] [blame] | 16422 | 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 Anlauf | 5098d35 | 2020-12-16 17:25:06 +0100 | [diff] [blame] | 16439 | |
| 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 Thomas | e49be8f | 2009-03-31 20:05:44 +0000 | [diff] [blame] | 16446 | } |
| 16447 | |
| 16448 | if (e->rank == 0 || has_pointer) |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16449 | { |
| 16450 | mpz_init_set_ui (size, 1); |
| 16451 | ref = NULL; |
| 16452 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16453 | 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 Brook | 6e45f57 | 2004-09-08 14:33:03 +0000 | [diff] [blame] | 16466 | gcc_assert (ref); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16467 | |
Kazu Hirata | 1f2959f | 2004-09-16 16:00:45 +0000 | [diff] [blame] | 16468 | /* Set marks according to the reference pattern. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16469 | switch (ref->u.ar.type) |
| 16470 | { |
| 16471 | case AR_FULL: |
Tobias Schlüter | f5e440e | 2004-06-21 19:23:52 +0200 | [diff] [blame] | 16472 | mark = AR_FULL; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16473 | break; |
| 16474 | |
| 16475 | case AR_SECTION: |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16476 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16480 | break; |
| 16481 | |
| 16482 | default: |
Paul Brook | 6e45f57 | 2004-09-08 14:33:03 +0000 | [diff] [blame] | 16483 | gcc_unreachable (); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16484 | } |
| 16485 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16486 | if (!gfc_array_size (e, &size)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16487 | { |
| 16488 | gfc_error ("Nonconstant array section at %L in DATA statement", |
Fritz Reese | 9b24c10 | 2017-11-14 01:25:26 +0000 | [diff] [blame] | 16489 | where); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16490 | mpz_clear (offset); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16491 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16492 | } |
| 16493 | } |
| 16494 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16495 | t = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16496 | |
| 16497 | while (mpz_cmp_ui (size, 0) > 0) |
| 16498 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16499 | if (!next_data_value ()) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16500 | { |
| 16501 | gfc_error ("DATA statement at %L has more variables than values", |
| 16502 | where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16503 | t = false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16504 | break; |
| 16505 | } |
| 16506 | |
| 16507 | t = gfc_check_assign (var->expr, values.vnode->expr, 0); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16508 | if (!t) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16509 | break; |
| 16510 | |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16511 | /* 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. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16514 | /* FIXME: Only done for full arrays for now, since array sections |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16515 | seem tricky. */ |
| 16516 | if (mark == AR_FULL && ref && ref->next == NULL |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16517 | && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0) |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16518 | { |
| 16519 | mpz_t range; |
| 16520 | |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16521 | if (mpz_cmp (size, values.left) >= 0) |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16522 | { |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16523 | mpz_init_set (range, values.left); |
| 16524 | mpz_sub (size, size, values.left); |
| 16525 | mpz_set_ui (values.left, 0); |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16526 | } |
| 16527 | else |
| 16528 | { |
| 16529 | mpz_init_set (range, size); |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16530 | mpz_sub (values.left, values.left, size); |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16531 | mpz_set_ui (size, 0); |
| 16532 | } |
| 16533 | |
Jakub Jelinek | 21ea492 | 2011-06-30 12:25:40 +0200 | [diff] [blame] | 16534 | t = gfc_assign_data_value (var->expr, values.vnode->expr, |
| 16535 | offset, &range); |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16536 | |
| 16537 | mpz_add (offset, offset, range); |
| 16538 | mpz_clear (range); |
Daniel Franke | e588024 | 2010-05-05 14:53:23 -0400 | [diff] [blame] | 16539 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16540 | if (!t) |
Daniel Franke | e588024 | 2010-05-05 14:53:23 -0400 | [diff] [blame] | 16541 | break; |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16542 | } |
| 16543 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16544 | /* Assign initial value to symbol. */ |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16545 | else |
| 16546 | { |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16547 | mpz_sub_ui (values.left, values.left, 1); |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16548 | mpz_sub_ui (size, size, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16549 | |
Jakub Jelinek | 21ea492 | 2011-06-30 12:25:40 +0200 | [diff] [blame] | 16550 | t = gfc_assign_data_value (var->expr, values.vnode->expr, |
| 16551 | offset, NULL); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16552 | if (!t) |
Jerry DeLisle | a24668a | 2007-07-03 22:14:55 +0000 | [diff] [blame] | 16553 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16554 | |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16555 | if (mark == AR_FULL) |
| 16556 | mpz_add_ui (offset, offset, 1); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16557 | |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16558 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16563 | } |
Richard Henderson | b850243 | 2004-08-23 14:53:14 -0700 | [diff] [blame] | 16564 | |
Tobias Schlüter | f5e440e | 2004-06-21 19:23:52 +0200 | [diff] [blame] | 16565 | if (mark == AR_SECTION) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16566 | { |
| 16567 | for (i = 0; i < ar->dimen; i++) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16568 | mpz_clear (section_index[i]); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16569 | } |
| 16570 | |
| 16571 | mpz_clear (size); |
| 16572 | mpz_clear (offset); |
| 16573 | |
| 16574 | return t; |
| 16575 | } |
| 16576 | |
| 16577 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16578 | static bool traverse_data_var (gfc_data_variable *, locus *); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16579 | |
| 16580 | /* Iterate over a list of elements in a DATA statement. */ |
| 16581 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16582 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16583 | traverse_data_list (gfc_data_variable *var, locus *where) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16584 | { |
| 16585 | mpz_t trip; |
| 16586 | iterator_stack frame; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16587 | gfc_expr *e, *start, *end, *step; |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16588 | bool retval = true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16589 | |
| 16590 | mpz_init (frame.value); |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16591 | mpz_init (trip); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16592 | |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16593 | start = gfc_copy_expr (var->iter.start); |
| 16594 | end = gfc_copy_expr (var->iter.end); |
| 16595 | step = gfc_copy_expr (var->iter.step); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16596 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16597 | if (!gfc_simplify_expr (start, 1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16598 | || start->expr_type != EXPR_CONSTANT) |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16599 | { |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16600 | gfc_error ("start of implied-do loop at %L could not be " |
| 16601 | "simplified to a constant value", &start->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16602 | retval = false; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16603 | goto cleanup; |
| 16604 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16605 | if (!gfc_simplify_expr (end, 1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16606 | || end->expr_type != EXPR_CONSTANT) |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16607 | { |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16608 | gfc_error ("end of implied-do loop at %L could not be " |
Harald Anlauf | 94172dc | 2020-11-25 20:20:44 +0100 | [diff] [blame] | 16609 | "simplified to a constant value", &end->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16610 | retval = false; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16611 | goto cleanup; |
| 16612 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16613 | if (!gfc_simplify_expr (step, 1) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16614 | || step->expr_type != EXPR_CONSTANT) |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16615 | { |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16616 | gfc_error ("step of implied-do loop at %L could not be " |
Harald Anlauf | 94172dc | 2020-11-25 20:20:44 +0100 | [diff] [blame] | 16617 | "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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16625 | retval = false; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16626 | goto cleanup; |
| 16627 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16628 | |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16629 | mpz_set (trip, end->value.integer); |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16630 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16636 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16643 | if (!traverse_data_var (var->list, where)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16644 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16645 | retval = false; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16646 | goto cleanup; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16647 | } |
| 16648 | |
| 16649 | e = gfc_copy_expr (var->expr); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16650 | if (!gfc_simplify_expr (e, 1)) |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16651 | { |
| 16652 | gfc_free_expr (e); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16653 | retval = false; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16654 | goto cleanup; |
| 16655 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16656 | |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16657 | mpz_add (frame.value, frame.value, step->value.integer); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16658 | |
| 16659 | mpz_sub_ui (trip, trip, 1); |
| 16660 | } |
| 16661 | |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16662 | cleanup: |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16663 | mpz_clear (frame.value); |
Daniel Franke | 147a19a | 2010-05-05 15:35:22 -0400 | [diff] [blame] | 16664 | mpz_clear (trip); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16665 | |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16666 | gfc_free_expr (start); |
| 16667 | gfc_free_expr (end); |
| 16668 | gfc_free_expr (step); |
| 16669 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16670 | iter_stack = frame.prev; |
Paul Thomas | 2220652 | 2007-01-05 14:45:20 +0000 | [diff] [blame] | 16671 | return retval; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16672 | } |
| 16673 | |
| 16674 | |
| 16675 | /* Type resolve variables in the variable list of a DATA statement. */ |
| 16676 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16677 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16678 | traverse_data_var (gfc_data_variable *var, locus *where) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16679 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16680 | bool t; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16681 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16689 | if (!t) |
| 16690 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16691 | } |
| 16692 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16693 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16694 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16701 | static bool |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16702 | resolve_data_variables (gfc_data_variable *d) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16703 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16704 | for (; d; d = d->next) |
| 16705 | { |
| 16706 | if (d->list == NULL) |
| 16707 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16708 | if (!gfc_resolve_expr (d->expr)) |
| 16709 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16710 | } |
| 16711 | else |
| 16712 | { |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16713 | if (!gfc_resolve_iterator (&d->iter, false, true)) |
| 16714 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16715 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16716 | if (!resolve_data_variables (d->list)) |
| 16717 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16718 | } |
| 16719 | } |
| 16720 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16721 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16722 | } |
| 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 | |
| 16729 | static void |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16730 | resolve_data (gfc_data *d) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16731 | { |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16732 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16733 | if (!resolve_data_variables (d->var)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16734 | return; |
| 16735 | |
| 16736 | values.vnode = d->value; |
Steven G. Kargl | f211286 | 2007-10-22 22:10:42 +0000 | [diff] [blame] | 16737 | if (d->value == NULL) |
| 16738 | mpz_set_ui (values.left, 0); |
| 16739 | else |
| 16740 | mpz_set (values.left, d->value->repeat); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16741 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16742 | if (!traverse_data_var (d->var, &d->where)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16743 | return; |
| 16744 | |
| 16745 | /* At this point, we better not have any values left. */ |
| 16746 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16747 | if (next_data_value ()) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16748 | gfc_error ("DATA statement at %L has more values than variables", |
| 16749 | &d->where); |
| 16750 | } |
| 16751 | |
| 16752 | |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16753 | /* 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 Wildenhues | df2fba9 | 2008-07-21 19:17:08 +0000 | [diff] [blame] | 16759 | /* Determines if a variable is not 'pure', i.e., not assignable within a pure |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16760 | procedure. Returns zero if assignment is OK, nonzero if there is a |
| 16761 | problem. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16762 | int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16763 | gfc_impure_variable (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16764 | { |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16765 | gfc_symbol *proc; |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16766 | gfc_namespace *ns; |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16767 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16768 | if (sym->attr.use_assoc || sym->attr.in_common) |
| 16769 | return 1; |
| 16770 | |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16771 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16779 | |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16780 | proc = sym->ns->proc_name; |
Tobias Burnus | c915f8b | 2012-09-13 16:57:38 +0200 | [diff] [blame] | 16781 | if (sym->attr.dummy |
Harald Anlauf | a764c40 | 2020-10-27 20:25:23 +0100 | [diff] [blame] | 16782 | && !sym->attr.value |
Tobias Burnus | c915f8b | 2012-09-13 16:57:38 +0200 | [diff] [blame] | 16783 | && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) |
| 16784 | || proc->attr.function)) |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16785 | return 1; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16786 | |
Paul Thomas | d2088bb | 2007-06-18 23:04:28 +0000 | [diff] [blame] | 16787 | /* 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16790 | return 0; |
| 16791 | } |
| 16792 | |
| 16793 | |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16794 | /* Test whether a symbol is pure or not. For a NULL pointer, checks if the |
| 16795 | current namespace is inside a pure procedure. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16796 | |
| 16797 | int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16798 | gfc_pure (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16799 | { |
| 16800 | symbol_attribute attr; |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16801 | gfc_namespace *ns; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16802 | |
| 16803 | if (sym == NULL) |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16804 | { |
| 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 Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 16813 | if (attr.flavor == FL_PROCEDURE && attr.pure) |
Janus Weil | d103912 | 2010-03-03 16:12:40 +0100 | [diff] [blame] | 16814 | return 1; |
| 16815 | } |
| 16816 | return 0; |
| 16817 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16818 | |
| 16819 | attr = sym->attr; |
| 16820 | |
Daniel Kraft | e6c1489 | 2010-08-15 17:28:10 +0200 | [diff] [blame] | 16821 | return attr.flavor == FL_PROCEDURE && attr.pure; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16822 | } |
| 16823 | |
| 16824 | |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 16825 | /* 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 | |
| 16829 | int |
| 16830 | gfc_implicit_pure (gfc_symbol *sym) |
| 16831 | { |
Thomas Koenig | f29041d | 2011-12-31 08:18:52 +0000 | [diff] [blame] | 16832 | gfc_namespace *ns; |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 16833 | |
| 16834 | if (sym == NULL) |
| 16835 | { |
Thomas Koenig | f29041d | 2011-12-31 08:18:52 +0000 | [diff] [blame] | 16836 | /* 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 Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 16843 | |
Thomas Koenig | f29041d | 2011-12-31 08:18:52 +0000 | [diff] [blame] | 16844 | if (sym->attr.flavor == FL_PROCEDURE) |
| 16845 | break; |
| 16846 | } |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 16847 | } |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 16848 | |
Thomas Koenig | f29041d | 2011-12-31 08:18:52 +0000 | [diff] [blame] | 16849 | return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure |
| 16850 | && !sym->attr.pure; |
Paul Thomas | f1f3903 | 2011-01-08 19:17:03 +0000 | [diff] [blame] | 16851 | } |
| 16852 | |
| 16853 | |
Tobias Burnus | ccd7751 | 2014-03-19 22:03:14 +0100 | [diff] [blame] | 16854 | void |
| 16855 | gfc_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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16881 | /* Test whether the current procedure is elemental or not. */ |
| 16882 | |
| 16883 | int |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16884 | gfc_elemental (gfc_symbol *sym) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16885 | { |
| 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 | |
| 16900 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16901 | warn_unused_fortran_label (gfc_st_label *label) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16902 | { |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16903 | if (label == NULL) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16904 | return; |
| 16905 | |
Steven G. Kargl | 994c1cc | 2006-08-06 01:38:46 +0000 | [diff] [blame] | 16906 | warn_unused_fortran_label (label->left); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16907 | |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16908 | if (label->defined == ST_LABEL_UNKNOWN) |
| 16909 | return; |
| 16910 | |
| 16911 | switch (label->referenced) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16912 | { |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16913 | case ST_LABEL_UNKNOWN: |
Janus Weil | 28ce22e | 2016-11-05 11:35:23 +0100 | [diff] [blame] | 16914 | gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used", |
| 16915 | label->value, &label->where); |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16916 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16917 | |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16918 | case ST_LABEL_BAD_TARGET: |
Janus Weil | 28ce22e | 2016-11-05 11:35:23 +0100 | [diff] [blame] | 16919 | gfc_warning (OPT_Wunused_label, |
| 16920 | "Label %d at %L defined but cannot be used", |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16921 | label->value, &label->where); |
| 16922 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16923 | |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16924 | default: |
| 16925 | break; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16926 | } |
Tobias Schlüter | 5cf5458 | 2006-01-18 21:54:49 +0100 | [diff] [blame] | 16927 | |
Steven G. Kargl | 994c1cc | 2006-08-06 01:38:46 +0000 | [diff] [blame] | 16928 | warn_unused_fortran_label (label->right); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16929 | } |
| 16930 | |
| 16931 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 16932 | /* Returns the sequence type of a symbol or sequence. */ |
| 16933 | |
| 16934 | static seq_type |
| 16935 | sequence_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 Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 16944 | if (ts.u.derived->components == NULL) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 16945 | return SEQ_NONDEFAULT; |
| 16946 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 16947 | result = sequence_type (ts.u.derived->components->ts); |
| 16948 | for (c = ts.u.derived->components->next; c; c = c->next) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 16949 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 16968 | || ts.kind == gfc_default_double_kind)) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 16969 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16991 | /* Resolve derived type EQUIVALENCE object. */ |
| 16992 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16993 | static bool |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16994 | resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) |
| 16995 | { |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 16996 | gfc_component *c = derived->components; |
| 16997 | |
| 16998 | if (!derived) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 16999 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17000 | |
| 17001 | /* Shall not be an object of nonsequence derived type. */ |
| 17002 | if (!derived->attr.sequence) |
| 17003 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17004 | gfc_error ("Derived type variable %qs at %L must have SEQUENCE " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17005 | "attribute to be an EQUIVALENCE object", sym->name, |
| 17006 | &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17007 | return false; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17008 | } |
| 17009 | |
Steven G. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 17010 | /* Shall not have allocatable components. */ |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 17011 | if (derived->attr.alloc_comp) |
| 17012 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17013 | gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17014 | "components to be an EQUIVALENCE object",sym->name, |
| 17015 | &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17016 | return false; |
Paul Thomas | 5046aff | 2006-10-08 16:21:55 +0000 | [diff] [blame] | 17017 | } |
| 17018 | |
Daniel Franke | 16e520b | 2010-05-19 09:07:25 -0400 | [diff] [blame] | 17019 | if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) |
Tobias Burnus | cddcf0d | 2008-01-06 19:07:52 +0100 | [diff] [blame] | 17020 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17021 | gfc_error ("Derived type variable %qs at %L with default " |
Tobias Burnus | cddcf0d | 2008-01-06 19:07:52 +0100 | [diff] [blame] | 17022 | "initialization cannot be in EQUIVALENCE with a variable " |
| 17023 | "in COMMON", sym->name, &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17024 | return false; |
Tobias Burnus | cddcf0d | 2008-01-06 19:07:52 +0100 | [diff] [blame] | 17025 | } |
| 17026 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17027 | for (; c ; c = c->next) |
| 17028 | { |
Fritz Reese | f6288c2 | 2016-05-07 23:16:23 +0000 | [diff] [blame] | 17029 | if (gfc_bt_struct (c->ts.type) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17030 | && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) |
| 17031 | return false; |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 17032 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17033 | /* Shall not be an object of sequence derived type containing a pointer |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17034 | in the structure. */ |
Janus Weil | d4b7d0f | 2008-08-23 23:04:01 +0200 | [diff] [blame] | 17035 | if (c->attr.pointer) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17036 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17037 | gfc_error ("Derived type variable %qs at %L with pointer " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17038 | "component(s) cannot be an EQUIVALENCE object", |
| 17039 | sym->name, &e->where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17040 | return false; |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17041 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17042 | } |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17043 | return true; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17044 | } |
| 17045 | |
| 17046 | |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 17047 | /* Resolve equivalence object. |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17048 | 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 Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17050 | 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 Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17053 | 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 Burnus | ee7e677 | 2006-12-10 20:53:07 +0100 | [diff] [blame] | 17056 | Either all or none of the objects shall have an protected attribute. |
Martin Liska | e53b6e5 | 2022-01-14 16:57:02 +0100 | [diff] [blame] | 17057 | The simple constraints are done in symbol.cc(check_conflict) and the rest |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17058 | are implemented here. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17059 | |
| 17060 | static void |
| 17061 | resolve_equivalence (gfc_equiv *eq) |
| 17062 | { |
| 17063 | gfc_symbol *sym; |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17064 | gfc_symbol *first_sym; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17065 | gfc_expr *e; |
| 17066 | gfc_ref *r; |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17067 | locus *last_where = NULL; |
| 17068 | seq_type eq_type, last_eq_type; |
| 17069 | gfc_typespec *last_ts; |
Tobias Burnus | ee7e677 | 2006-12-10 20:53:07 +0100 | [diff] [blame] | 17070 | int object, cnt_protected; |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17071 | const char *msg; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17072 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17073 | last_ts = &eq->expr->symtree->n.sym->ts; |
| 17074 | |
| 17075 | first_sym = eq->expr->symtree->n.sym; |
| 17076 | |
Tobias Burnus | ee7e677 | 2006-12-10 20:53:07 +0100 | [diff] [blame] | 17077 | cnt_protected = 0; |
| 17078 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17079 | for (object = 1; eq; eq = eq->eq, object++) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17080 | { |
| 17081 | e = eq->expr; |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17082 | |
| 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 Blomqvist | f622221 | 2018-01-05 21:01:12 +0200 | [diff] [blame] | 17123 | start = gfc_get_int_expr (gfc_charlen_int_kind, |
Jerry DeLisle | b7e7577 | 2010-04-13 01:59:35 +0000 | [diff] [blame] | 17124 | NULL, 1); |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17125 | ref->u.ss.start = start; |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 17126 | if (end == NULL && e->ts.u.cl) |
| 17127 | end = gfc_copy_expr (e->ts.u.cl->length); |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17128 | ref->u.ss.end = end; |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 17129 | ref->u.ss.length = e->ts.u.cl; |
| 17130 | e->ts.u.cl = NULL; |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17131 | } |
| 17132 | ref = ref->next; |
Jim Meyering | cede950 | 2011-04-18 19:20:53 +0000 | [diff] [blame] | 17133 | free (mem); |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17134 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17146 | if (!gfc_resolve_expr (e)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17147 | continue; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17148 | |
| 17149 | sym = e->symtree->n.sym; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17150 | |
Kaveh R. Ghazi | 9aa433c | 2008-07-19 16:19:27 +0000 | [diff] [blame] | 17151 | if (sym->attr.is_protected) |
Tobias Burnus | ee7e677 | 2006-12-10 20:53:07 +0100 | [diff] [blame] | 17152 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17160 | } |
Tobias Burnus | ee7e677 | 2006-12-10 20:53:07 +0100 | [diff] [blame] | 17161 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17162 | /* Shall not equivalence common block variables in a PURE procedure. */ |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 17163 | if (sym->ns->proc_name |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17164 | && sym->ns->proc_name->attr.pure |
| 17165 | && sym->attr.in_common) |
| 17166 | { |
Steven G. Kargl | 9cfdd48 | 2017-11-04 00:34:40 +0000 | [diff] [blame] | 17167 | /* 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 Thomas | aea5e93 | 2017-11-05 12:38:42 +0000 | [diff] [blame] | 17174 | if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; |
Steven G. Kargl | 9cfdd48 | 2017-11-04 00:34:40 +0000 | [diff] [blame] | 17175 | } |
| 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17183 | break; |
| 17184 | } |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 17185 | |
| 17186 | /* Shall not be a named constant. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17187 | if (e->expr_type == EXPR_CONSTANT) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17188 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17189 | gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17190 | "object", sym->name, &e->where); |
| 17191 | continue; |
| 17192 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17193 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 17194 | if (e->ts.type == BT_DERIVED |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17195 | && !resolve_equivalence_derived (e->ts.u.derived, sym, e)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17196 | continue; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17197 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17198 | /* 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17222 | && last_eq_type == SEQ_MIXED |
Harald Anlauf | e505f74 | 2022-11-09 21:05:28 +0100 | [diff] [blame] | 17223 | && last_where |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17224 | && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17225 | || (eq_type == SEQ_MIXED |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17226 | && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17227 | 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. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17232 | && last_eq_type == SEQ_NONDEFAULT |
Harald Anlauf | e505f74 | 2022-11-09 21:05:28 +0100 | [diff] [blame] | 17233 | && last_where |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17234 | && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17235 | || (eq_type == SEQ_NONDEFAULT |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17236 | && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17237 | continue; |
| 17238 | |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17239 | msg ="Non-CHARACTER object %qs in default CHARACTER " |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17240 | "EQUIVALENCE statement at %L"; |
| 17241 | if (last_eq_type == SEQ_CHARACTER |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17242 | && eq_type != SEQ_CHARACTER |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17243 | && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17244 | continue; |
| 17245 | |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17246 | msg ="Non-NUMERIC object %qs in default NUMERIC " |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17247 | "EQUIVALENCE statement at %L"; |
| 17248 | if (last_eq_type == SEQ_NUMERIC |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17249 | && eq_type != SEQ_NUMERIC |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17250 | && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17251 | continue; |
| 17252 | |
Mark Eggleston | bf1f6d8 | 2020-04-02 07:18:52 +0100 | [diff] [blame] | 17253 | identical_types: |
| 17254 | |
Paul Thomas | e8ec07e | 2005-10-01 07:39:08 +0000 | [diff] [blame] | 17255 | last_ts =&sym->ts; |
| 17256 | last_where = &e->where; |
| 17257 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17258 | if (!e->ref) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17259 | continue; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17260 | |
| 17261 | /* Shall not be an automatic array. */ |
Mark Eggleston | bf1f6d8 | 2020-04-02 07:18:52 +0100 | [diff] [blame] | 17262 | if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym)) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17263 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17264 | gfc_error ("Array %qs at %L with non-constant bounds cannot be " |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17265 | "an EQUIVALENCE object", sym->name, &e->where); |
| 17266 | continue; |
| 17267 | } |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17268 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17269 | r = e->ref; |
| 17270 | while (r) |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17271 | { |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17272 | /* Shall not be a structure component. */ |
| 17273 | if (r->type == REF_COMPONENT) |
| 17274 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17275 | gfc_error ("Structure component %qs at %L cannot be an " |
Jakub Jelinek | a8006d0 | 2005-08-06 12:00:53 +0200 | [diff] [blame] | 17276 | "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 Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 17293 | } |
| 17294 | } |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17295 | |
| 17296 | |
Paul Thomas | a9b64a6 | 2019-10-27 15:00:54 +0000 | [diff] [blame] | 17297 | /* Function called by resolve_fntype to flag other symbols used in the |
| 17298 | length type parameter specification of function results. */ |
Paul Thomas | 345bd7e | 2016-12-09 11:55:27 +0000 | [diff] [blame] | 17299 | |
| 17300 | static bool |
| 17301 | flag_fn_result_spec (gfc_expr *expr, |
Paul Thomas | 9ad8aaf | 2018-05-20 10:08:24 +0000 | [diff] [blame] | 17302 | gfc_symbol *sym, |
Paul Thomas | 345bd7e | 2016-12-09 11:55:27 +0000 | [diff] [blame] | 17303 | 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 Thomas | 9ad8aaf | 2018-05-20 10:08:24 +0000 | [diff] [blame] | 17315 | 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 Thomas | 345bd7e | 2016-12-09 11:55:27 +0000 | [diff] [blame] | 17322 | 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. Kargl | 66e4ab3 | 2007-06-07 18:10:31 +0000 | [diff] [blame] | 17352 | /* Resolve function and ENTRY types, issue diagnostics if needed. */ |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17353 | |
| 17354 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17355 | resolve_fntype (gfc_namespace *ns) |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17356 | { |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17371 | && !gfc_set_default_type (sym, 0, NULL) |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17372 | && !sym->attr.untyped) |
| 17373 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17374 | gfc_error ("Function %qs at %L has no IMPLICIT type", |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17375 | sym->name, &sym->declared_at); |
| 17376 | sym->attr.untyped = 1; |
| 17377 | } |
| 17378 | |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 17379 | if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc |
Tobias Burnus | 0d6872c | 2008-11-12 07:59:33 +0100 | [diff] [blame] | 17380 | && !sym->attr.contained |
Janus Weil | 6e2062b | 2011-02-18 11:04:30 +0100 | [diff] [blame] | 17381 | && !gfc_check_symbol_access (sym->ts.u.derived) |
| 17382 | && gfc_check_symbol_access (sym)) |
Erik Edelmann | 3bcc018 | 2006-01-08 17:52:57 +0000 | [diff] [blame] | 17383 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17384 | gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at " |
| 17385 | "%L of PRIVATE type %qs", sym->name, |
Janus Weil | bc21d31 | 2009-08-13 21:46:46 +0200 | [diff] [blame] | 17386 | &sym->declared_at, sym->ts.u.derived->name); |
Erik Edelmann | 3bcc018 | 2006-01-08 17:52:57 +0000 | [diff] [blame] | 17387 | } |
| 17388 | |
Paul Thomas | 7453378 | 2007-03-18 15:00:55 +0000 | [diff] [blame] | 17389 | if (ns->entries) |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17390 | 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17394 | && !gfc_set_default_type (el->sym, 0, NULL) |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17395 | && !el->sym->attr.untyped) |
| 17396 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17397 | gfc_error ("ENTRY %qs at %L has no IMPLICIT type", |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17398 | el->sym->name, &el->sym->declared_at); |
| 17399 | el->sym->attr.untyped = 1; |
| 17400 | } |
| 17401 | } |
Paul Thomas | 345bd7e | 2016-12-09 11:55:27 +0000 | [diff] [blame] | 17402 | |
| 17403 | if (sym->ts.type == BT_CHARACTER) |
Paul Thomas | 9ad8aaf | 2018-05-20 10:08:24 +0000 | [diff] [blame] | 17404 | gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0); |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17405 | } |
| 17406 | |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17407 | |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17408 | /* 12.3.2.1.1 Defined operators. */ |
| 17409 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17410 | static bool |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17411 | check_uop_procedure (gfc_symbol *sym, locus where) |
| 17412 | { |
| 17413 | gfc_formal_arglist *formal; |
| 17414 | |
| 17415 | if (!sym->attr.function) |
| 17416 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17417 | gfc_error ("User operator procedure %qs at %L must be a FUNCTION", |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17418 | sym->name, &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17419 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17420 | } |
| 17421 | |
| 17422 | if (sym->ts.type == BT_CHARACTER |
Paul Thomas | afbc5ae | 2016-01-15 20:33:58 +0000 | [diff] [blame] | 17423 | && !((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 Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17426 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17427 | gfc_error ("User operator procedure %qs at %L cannot be assumed " |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17428 | "character length", sym->name, &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17429 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17430 | } |
| 17431 | |
Janus Weil | 4cbc903 | 2013-01-29 22:40:51 +0100 | [diff] [blame] | 17432 | formal = gfc_sym_get_dummy_args (sym); |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17433 | if (!formal || !formal->sym) |
| 17434 | { |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17435 | gfc_error ("User operator procedure %qs at %L must have at least " |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17436 | "one argument", sym->name, &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17437 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17438 | } |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17444 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17445 | } |
| 17446 | |
| 17447 | if (formal->sym->attr.optional) |
| 17448 | { |
| 17449 | gfc_error ("First argument of operator interface at %L cannot be " |
| 17450 | "optional", &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17451 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17452 | } |
| 17453 | |
| 17454 | formal = formal->next; |
| 17455 | if (!formal || !formal->sym) |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17456 | return true; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17457 | |
| 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 Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17462 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17463 | } |
| 17464 | |
| 17465 | if (formal->sym->attr.optional) |
| 17466 | { |
| 17467 | gfc_error ("Second argument of operator interface at %L cannot be " |
| 17468 | "optional", &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17469 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17470 | } |
| 17471 | |
| 17472 | if (formal->next) |
| 17473 | { |
| 17474 | gfc_error ("Operator interface at %L must have, at most, two " |
| 17475 | "arguments", &where); |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17476 | return false; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17477 | } |
| 17478 | |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17479 | return true; |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17480 | } |
| 17481 | |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17482 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17483 | gfc_resolve_uops (gfc_symtree *symtree) |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17484 | { |
| 17485 | gfc_interface *itr; |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17486 | |
Bernhard Fischer | 05c1e3a | 2006-09-30 21:10:54 +0200 | [diff] [blame] | 17487 | if (symtree == NULL) |
| 17488 | return; |
| 17489 | |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17490 | gfc_resolve_uops (symtree->left); |
| 17491 | gfc_resolve_uops (symtree->right); |
| 17492 | |
Kaveh R. Ghazi | a1ee985 | 2008-07-19 16:22:12 +0000 | [diff] [blame] | 17493 | for (itr = symtree->n.uop->op; itr; itr = itr->next) |
Daniel Kraft | 9474728 | 2009-08-10 12:51:46 +0200 | [diff] [blame] | 17494 | check_uop_procedure (itr->sym, itr->sym->declared_at); |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17495 | } |
| 17496 | |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17497 | |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17498 | /* 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 Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 17502 | block, which is handled by gfc_resolve_code. */ |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17503 | |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17504 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17505 | resolve_types (gfc_namespace *ns) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17506 | { |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17507 | gfc_namespace *n; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17508 | gfc_charlen *cl; |
| 17509 | gfc_data *d; |
| 17510 | gfc_equiv *eq; |
Daniel Kraft | a82f1f2 | 2008-09-05 22:51:50 +0200 | [diff] [blame] | 17511 | gfc_namespace* old_ns = gfc_current_ns; |
Mark Eggleston | e4a5f73 | 2020-01-17 08:49:25 +0000 | [diff] [blame] | 17512 | bool recursive = ns->proc_name && ns->proc_name->attr.recursive; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17513 | |
Mikael Morin | 2b91aea | 2015-03-25 10:15:46 +0000 | [diff] [blame] | 17514 | if (ns->types_resolved) |
| 17515 | return; |
| 17516 | |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 17517 | /* 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 Thomas | 22c2388 | 2014-10-18 14:35:51 +0000 | [diff] [blame] | 17523 | && !resolve_typespec_used (&ns->default_type[letter], |
Janne Blomqvist | 524af0d | 2013-04-11 00:36:58 +0300 | [diff] [blame] | 17524 | &ns->implicit_loc[letter], NULL)) |
Daniel Kraft | 52f4993 | 2008-09-02 10:13:21 +0200 | [diff] [blame] | 17525 | return; |
| 17526 | } |
| 17527 | |
Daniel Kraft | a82f1f2 | 2008-09-05 22:51:50 +0200 | [diff] [blame] | 17528 | gfc_current_ns = ns; |
| 17529 | |
Paul Thomas | 0f3162e | 2006-02-24 13:54:06 +0000 | [diff] [blame] | 17530 | resolve_entries (ns); |
| 17531 | |
Mikael Morin | 6dcab50 | 2015-10-04 12:07:50 +0000 | [diff] [blame] | 17532 | resolve_common_vars (&ns->blank_common, false); |
Tobias Burnus | ad22b1f | 2007-07-03 23:41:34 +0200 | [diff] [blame] | 17533 | resolve_common_blocks (ns->common_root); |
| 17534 | |
Paul Thomas | 0f3162e | 2006-02-24 13:54:06 +0000 | [diff] [blame] | 17535 | resolve_contained_functions (ns); |
| 17536 | |
Tobias Burnus | 12578be | 2011-04-29 18:49:53 +0200 | [diff] [blame] | 17537 | if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE |
| 17538 | && ns->proc_name->attr.if_source == IFSRC_IFBODY) |
Tobias Burnus | 3ab216a | 2020-04-02 18:27:09 +0200 | [diff] [blame] | 17539 | gfc_resolve_formal_arglist (ns->proc_name); |
Tobias Burnus | 12578be | 2011-04-29 18:49:53 +0200 | [diff] [blame] | 17540 | |
Christopher D. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 17541 | gfc_traverse_ns (ns, resolve_bind_c_derived_types); |
| 17542 | |
Tobias Schlüter | 5cd09fa | 2007-04-12 20:48:06 +0200 | [diff] [blame] | 17543 | for (cl = ns->cl_list; cl; cl = cl->next) |
| 17544 | resolve_charlen (cl); |
| 17545 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17546 | gfc_traverse_ns (ns, resolve_symbol); |
| 17547 | |
Jakub Jelinek | cf4d246 | 2005-06-01 12:00:19 +0200 | [diff] [blame] | 17548 | resolve_fntype (ns); |
| 17549 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17550 | for (n = ns->contained; n; n = n->sibling) |
| 17551 | { |
| 17552 | if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)) |
Tobias Burnus | a4d9b22 | 2014-12-13 00:12:06 +0100 | [diff] [blame] | 17553 | gfc_error ("Contained procedure %qs at %L of a PURE procedure must " |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17554 | "also be PURE", n->proc_name->name, |
| 17555 | &n->proc_name->declared_at); |
| 17556 | |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17557 | resolve_types (n); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17558 | } |
| 17559 | |
| 17560 | forall_flag = 0; |
Thomas Koenig | ce96d37 | 2013-09-02 22:09:07 +0000 | [diff] [blame] | 17561 | gfc_do_concurrent_flag = 0; |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17562 | gfc_check_interfaces (ns); |
| 17563 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17564 | gfc_traverse_ns (ns, resolve_values); |
| 17565 | |
Mark Eggleston | e4a5f73 | 2020-01-17 08:49:25 +0000 | [diff] [blame] | 17566 | if (ns->save_all || (!flag_automatic && !recursive)) |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17567 | 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. Rickett | a8b3b0b | 2007-07-02 02:47:21 +0000 | [diff] [blame] | 17576 | gfc_traverse_ns (ns, gfc_verify_binding_labels); |
| 17577 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17578 | for (eq = ns->equiv; eq; eq = eq->next) |
| 17579 | resolve_equivalence (eq); |
| 17580 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17581 | /* Warn about unused labels. */ |
Bernhard Fischer | 2e5758e | 2006-10-15 14:12:59 +0200 | [diff] [blame] | 17582 | if (warn_unused_label) |
Steven G. Kargl | 994c1cc | 2006-08-06 01:38:46 +0000 | [diff] [blame] | 17583 | warn_unused_fortran_label (ns->st_labels); |
Paul Thomas | 0e3e65b | 2006-04-21 05:10:22 +0000 | [diff] [blame] | 17584 | |
| 17585 | gfc_resolve_uops (ns->uop_root); |
Daniel Kraft | a82f1f2 | 2008-09-05 22:51:50 +0200 | [diff] [blame] | 17586 | |
Paul Thomas | e73d3ca | 2016-08-31 05:36:22 +0000 | [diff] [blame] | 17587 | gfc_traverse_ns (ns, gfc_verify_DTIO_procedures); |
| 17588 | |
Jakub Jelinek | dd2fc52 | 2014-05-11 22:26:36 +0200 | [diff] [blame] | 17589 | gfc_resolve_omp_declare_simd (ns); |
| 17590 | |
Jakub Jelinek | 5f23671 | 2014-06-06 09:24:38 +0200 | [diff] [blame] | 17591 | gfc_resolve_omp_udrs (ns->omp_udr_root); |
| 17592 | |
Mikael Morin | 2b91aea | 2015-03-25 10:15:46 +0000 | [diff] [blame] | 17593 | ns->types_resolved = 1; |
| 17594 | |
Daniel Kraft | a82f1f2 | 2008-09-05 22:51:50 +0200 | [diff] [blame] | 17595 | gfc_current_ns = old_ns; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17596 | } |
| 17597 | |
| 17598 | |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 17599 | /* Call gfc_resolve_code recursively. */ |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17600 | |
| 17601 | static void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17602 | resolve_codes (gfc_namespace *ns) |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17603 | { |
| 17604 | gfc_namespace *n; |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17605 | bitmap_obstack old_obstack; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17606 | |
Janus Weil | 611c64f | 2010-11-05 19:14:52 +0100 | [diff] [blame] | 17607 | if (ns->resolved == 1) |
| 17608 | return; |
| 17609 | |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17610 | for (n = ns->contained; n; n = n->sibling) |
| 17611 | resolve_codes (n); |
| 17612 | |
| 17613 | gfc_current_ns = ns; |
Janus Weil | 76d02e9 | 2009-10-22 10:53:26 +0200 | [diff] [blame] | 17614 | |
| 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 Thomas | 0e9a445 | 2006-06-07 07:20:39 +0000 | [diff] [blame] | 17619 | /* Set to an out of range value. */ |
| 17620 | current_entry_id = -1; |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 17621 | |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17622 | old_obstack = labels_obstack; |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 17623 | bitmap_obstack_initialize (&labels_obstack); |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17624 | |
Thomas Schwinge | 41dbbb3 | 2015-01-15 21:11:12 +0100 | [diff] [blame] | 17625 | gfc_resolve_oacc_declare (ns); |
Thomas Schwinge | f6bf4bc | 2019-03-21 21:02:42 +0100 | [diff] [blame] | 17626 | gfc_resolve_oacc_routines (ns); |
Jakub Jelinek | cd30a0b | 2017-10-19 09:38:59 +0200 | [diff] [blame] | 17627 | gfc_resolve_omp_local_vars (ns); |
Jakub Jelinek | b46ebd6 | 2014-06-24 09:45:22 +0200 | [diff] [blame] | 17628 | gfc_resolve_code (ns->code, ns); |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17629 | |
Tobias Schlüter | 0615f92 | 2007-04-13 15:48:08 +0200 | [diff] [blame] | 17630 | bitmap_obstack_release (&labels_obstack); |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17631 | labels_obstack = old_obstack; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17632 | } |
| 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 | |
| 17641 | void |
Steven G. Kargl | edf1eac | 2007-01-20 22:01:41 +0000 | [diff] [blame] | 17642 | gfc_resolve (gfc_namespace *ns) |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17643 | { |
| 17644 | gfc_namespace *old_ns; |
Paul Thomas | 3af8d8c | 2009-08-01 13:45:12 +0000 | [diff] [blame] | 17645 | code_stack *old_cs_base; |
Mikael Morin | f0e9940 | 2015-06-19 12:50:00 +0000 | [diff] [blame] | 17646 | struct gfc_omp_saved_state old_omp_state; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17647 | |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17648 | if (ns->resolved) |
| 17649 | return; |
| 17650 | |
Paul Thomas | 3af8d8c | 2009-08-01 13:45:12 +0000 | [diff] [blame] | 17651 | ns->resolved = -1; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17652 | old_ns = gfc_current_ns; |
Paul Thomas | 3af8d8c | 2009-08-01 13:45:12 +0000 | [diff] [blame] | 17653 | old_cs_base = cs_base; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17654 | |
Mikael Morin | f0e9940 | 2015-06-19 12:50:00 +0000 | [diff] [blame] | 17655 | /* 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 Jelinek | 1cad928 | 2016-08-19 17:30:33 +0200 | [diff] [blame] | 17658 | if (!ns->construct_entities) |
| 17659 | gfc_omp_save_and_clear_state (&old_omp_state); |
Mikael Morin | f0e9940 | 2015-06-19 12:50:00 +0000 | [diff] [blame] | 17660 | |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17661 | resolve_types (ns); |
Alessandro Fanfarillo | 4d38232 | 2012-12-01 08:00:22 +0000 | [diff] [blame] | 17662 | component_assignment_level = 0; |
H.J. Lu | efb0828 | 2006-02-05 19:53:00 +0000 | [diff] [blame] | 17663 | resolve_codes (ns); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17664 | |
Tobias Burnus | e2a2284 | 2022-10-05 19:25:27 +0200 | [diff] [blame] | 17665 | if (ns->omp_assumes) |
| 17666 | gfc_resolve_omp_assumptions (ns->omp_assumes); |
| 17667 | |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17668 | gfc_current_ns = old_ns; |
Paul Thomas | 3af8d8c | 2009-08-01 13:45:12 +0000 | [diff] [blame] | 17669 | cs_base = old_cs_base; |
Paul Thomas | 71a7778 | 2009-03-30 19:35:14 +0000 | [diff] [blame] | 17670 | ns->resolved = 1; |
Thomas Koenig | 601d98b | 2010-07-25 19:31:37 +0000 | [diff] [blame] | 17671 | |
| 17672 | gfc_run_passes (ns); |
Mikael Morin | f0e9940 | 2015-06-19 12:50:00 +0000 | [diff] [blame] | 17673 | |
Jakub Jelinek | 1cad928 | 2016-08-19 17:30:33 +0200 | [diff] [blame] | 17674 | if (!ns->construct_entities) |
| 17675 | gfc_omp_restore_state (&old_omp_state); |
Diego Novillo | 6de9cd9 | 2004-05-13 02:41:07 -0400 | [diff] [blame] | 17676 | } |