gcc/fortran/st.cc

   1 /* Build executable statement trees.
   2    Copyright (C) 2000-2023 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  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.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 /* Executable statements are strung together into a singly linked list
  22    of code structures.  These structures are later translated into GCC
  23    GENERIC tree structures and from there to executable code for a
  24    target.  */
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "gfortran.h"
  30
  31 gfc_code new_st;
  32
  33
  34 /* Zeroes out the new_st structure.  */
  35
  36 void
  37 gfc_clear_new_st (void)
  38 {
  39   memset (&new_st, '\0', sizeof (new_st));
  40   new_st.op = EXEC_NOP;
  41 }
  42
  43
  44 /* Get a gfc_code structure, initialized with the current locus
  45    and a statement code 'op'.  */
  46
  47 gfc_code *
  48 gfc_get_code (gfc_exec_op op)
  49 {
  50   gfc_code *c;
  51
  52   c = XCNEW (gfc_code);
  53   c->op = op;
  54   c->loc = gfc_current_locus;
  55   return c;
  56 }
  57
  58
  59 /* Given some part of a gfc_code structure, append a set of code to
  60    its tail, returning a pointer to the new tail.  */
  61
  62 gfc_code *
  63 gfc_append_code (gfc_code *tail, gfc_code *new_code)
  64 {
  65   if (tail != NULL)
  66     {
  67       while (tail->next != NULL)
  68         tail = tail->next;
  69
  70       tail->next = new_code;
  71     }
  72
  73   while (new_code->next != NULL)
  74     new_code = new_code->next;
  75
  76   return new_code;
  77 }
  78
  79
  80 /* Free a single code structure, but not the actual structure itself.  */
  81
  82 void
  83 gfc_free_statement (gfc_code *p)
  84 {
  85   if (p->expr1)
  86     gfc_free_expr (p->expr1);
  87   if (p->expr2)
  88     gfc_free_expr (p->expr2);
  89
  90   switch (p->op)
  91     {
  92     case EXEC_NOP:
  93     case EXEC_END_BLOCK:
  94     case EXEC_END_NESTED_BLOCK:
  95     case EXEC_ASSIGN:
  96     case EXEC_INIT_ASSIGN:
  97     case EXEC_GOTO:
  98     case EXEC_CYCLE:
  99     case EXEC_RETURN:
 100     case EXEC_END_PROCEDURE:
 101     case EXEC_IF:
 102     case EXEC_PAUSE:
 103     case EXEC_STOP:
 104     case EXEC_ERROR_STOP:
 105     case EXEC_EXIT:
 106     case EXEC_WHERE:
 107     case EXEC_IOLENGTH:
 108     case EXEC_POINTER_ASSIGN:
 109     case EXEC_DO_WHILE:
 110     case EXEC_CONTINUE:
 111     case EXEC_TRANSFER:
 112     case EXEC_LABEL_ASSIGN:
 113     case EXEC_ENTRY:
 114     case EXEC_ARITHMETIC_IF:
 115     case EXEC_CRITICAL:
 116     case EXEC_SYNC_ALL:
 117     case EXEC_SYNC_IMAGES:
 118     case EXEC_SYNC_MEMORY:
 119     case EXEC_LOCK:
 120     case EXEC_UNLOCK:
 121     case EXEC_EVENT_POST:
 122     case EXEC_EVENT_WAIT:
 123     case EXEC_FAIL_IMAGE:
 124     case EXEC_CHANGE_TEAM:
 125     case EXEC_END_TEAM:
 126     case EXEC_FORM_TEAM:
 127     case EXEC_SYNC_TEAM:
 128       break;
 129
 130     case EXEC_BLOCK:
 131       gfc_free_namespace (p->ext.block.ns);
 132       gfc_free_association_list (p->ext.block.assoc);
 133       break;
 134
 135     case EXEC_COMPCALL:
 136     case EXEC_CALL_PPC:
 137     case EXEC_CALL:
 138     case EXEC_ASSIGN_CALL:
 139       gfc_free_actual_arglist (p->ext.actual);
 140       break;
 141
 142     case EXEC_SELECT:
 143     case EXEC_SELECT_TYPE:
 144     case EXEC_SELECT_RANK:
 145       if (p->ext.block.case_list)
 146         gfc_free_case_list (p->ext.block.case_list);
 147       break;
 148
 149     case EXEC_DO:
 150       gfc_free_iterator (p->ext.iterator, 1);
 151       break;
 152
 153     case EXEC_ALLOCATE:
 154     case EXEC_DEALLOCATE:
 155       gfc_free_alloc_list (p->ext.alloc.list);
 156       break;
 157
 158     case EXEC_OPEN:
 159       gfc_free_open (p->ext.open);
 160       break;
 161
 162     case EXEC_CLOSE:
 163       gfc_free_close (p->ext.close);
 164       break;
 165
 166     case EXEC_BACKSPACE:
 167     case EXEC_ENDFILE:
 168     case EXEC_REWIND:
 169     case EXEC_FLUSH:
 170       gfc_free_filepos (p->ext.filepos);
 171       break;
 172
 173     case EXEC_INQUIRE:
 174       gfc_free_inquire (p->ext.inquire);
 175       break;
 176
 177     case EXEC_WAIT:
 178       gfc_free_wait (p->ext.wait);
 179       break;
 180
 181     case EXEC_READ:
 182     case EXEC_WRITE:
 183       gfc_free_dt (p->ext.dt);
 184       break;
 185
 186     case EXEC_DT_END:
 187       /* The ext.dt member is a duplicate pointer and doesn't need to
 188          be freed.  */
 189       break;
 190
 191     case EXEC_DO_CONCURRENT:
 192     case EXEC_FORALL:
 193       gfc_free_forall_iterator (p->ext.forall_iterator);
 194       break;
 195
 196     case EXEC_OACC_DECLARE:
 197       if (p->ext.oacc_declare)
 198         gfc_free_oacc_declare_clauses (p->ext.oacc_declare);
 199       break;
 200
 201     case EXEC_OACC_ATOMIC:
 202     case EXEC_OACC_PARALLEL_LOOP:
 203     case EXEC_OACC_PARALLEL:
 204     case EXEC_OACC_KERNELS_LOOP:
 205     case EXEC_OACC_KERNELS:
 206     case EXEC_OACC_SERIAL_LOOP:
 207     case EXEC_OACC_SERIAL:
 208     case EXEC_OACC_DATA:
 209     case EXEC_OACC_HOST_DATA:
 210     case EXEC_OACC_LOOP:
 211     case EXEC_OACC_UPDATE:
 212     case EXEC_OACC_WAIT:
 213     case EXEC_OACC_CACHE:
 214     case EXEC_OACC_ENTER_DATA:
 215     case EXEC_OACC_EXIT_DATA:
 216     case EXEC_OACC_ROUTINE:
 217     case EXEC_OMP_ALLOCATE:
 218     case EXEC_OMP_ALLOCATORS:
 219     case EXEC_OMP_ASSUME:
 220     case EXEC_OMP_ATOMIC:
 221     case EXEC_OMP_CANCEL:
 222     case EXEC_OMP_CANCELLATION_POINT:
 223     case EXEC_OMP_CRITICAL:
 224     case EXEC_OMP_DEPOBJ:
 225     case EXEC_OMP_DISTRIBUTE:
 226     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
 227     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
 228     case EXEC_OMP_DISTRIBUTE_SIMD:
 229     case EXEC_OMP_DO:
 230     case EXEC_OMP_DO_SIMD:
 231     case EXEC_OMP_ERROR:
 232     case EXEC_OMP_LOOP:
 233     case EXEC_OMP_END_SINGLE:
 234     case EXEC_OMP_MASKED_TASKLOOP:
 235     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
 236     case EXEC_OMP_MASTER_TASKLOOP:
 237     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
 238     case EXEC_OMP_ORDERED:
 239     case EXEC_OMP_MASKED:
 240     case EXEC_OMP_PARALLEL:
 241     case EXEC_OMP_PARALLEL_DO:
 242     case EXEC_OMP_PARALLEL_DO_SIMD:
 243     case EXEC_OMP_PARALLEL_LOOP:
 244     case EXEC_OMP_PARALLEL_MASKED:
 245     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
 246     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
 247     case EXEC_OMP_PARALLEL_MASTER:
 248     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
 249     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
 250     case EXEC_OMP_PARALLEL_SECTIONS:
 251     case EXEC_OMP_PARALLEL_WORKSHARE:
 252     case EXEC_OMP_SCAN:
 253     case EXEC_OMP_SCOPE:
 254     case EXEC_OMP_SECTIONS:
 255     case EXEC_OMP_SIMD:
 256     case EXEC_OMP_SINGLE:
 257     case EXEC_OMP_TARGET:
 258     case EXEC_OMP_TARGET_DATA:
 259     case EXEC_OMP_TARGET_ENTER_DATA:
 260     case EXEC_OMP_TARGET_EXIT_DATA:
 261     case EXEC_OMP_TARGET_PARALLEL:
 262     case EXEC_OMP_TARGET_PARALLEL_DO:
 263     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
 264     case EXEC_OMP_TARGET_PARALLEL_LOOP:
 265     case EXEC_OMP_TARGET_SIMD:
 266     case EXEC_OMP_TARGET_TEAMS:
 267     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
 268     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
 269     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
 270     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
 271     case EXEC_OMP_TARGET_TEAMS_LOOP:
 272     case EXEC_OMP_TARGET_UPDATE:
 273     case EXEC_OMP_TASK:
 274     case EXEC_OMP_TASKLOOP:
 275     case EXEC_OMP_TASKLOOP_SIMD:
 276     case EXEC_OMP_TEAMS:
 277     case EXEC_OMP_TEAMS_DISTRIBUTE:
 278     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
 279     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
 280     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
 281     case EXEC_OMP_TEAMS_LOOP:
 282     case EXEC_OMP_WORKSHARE:
 283       gfc_free_omp_clauses (p->ext.omp_clauses);
 284       break;
 285
 286     case EXEC_OMP_END_CRITICAL:
 287       free (CONST_CAST (char *, p->ext.omp_name));
 288       break;
 289
 290     case EXEC_OMP_FLUSH:
 291       gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false);
 292       break;
 293
 294     case EXEC_OMP_BARRIER:
 295     case EXEC_OMP_MASTER:
 296     case EXEC_OMP_END_NOWAIT:
 297     case EXEC_OMP_TASKGROUP:
 298     case EXEC_OMP_TASKWAIT:
 299     case EXEC_OMP_TASKYIELD:
 300       break;
 301
 302     default:
 303       gfc_internal_error ("gfc_free_statement(): Bad statement");
 304     }
 305 }
 306
 307
 308 /* Free a code statement and all other code structures linked to it.  */
 309
 310 void
 311 gfc_free_statements (gfc_code *p)
 312 {
 313   gfc_code *q;
 314
 315   for (; p; p = q)
 316     {
 317       q = p->next;
 318
 319       if (p->block)
 320         gfc_free_statements (p->block);
 321       gfc_free_statement (p);
 322       free (p);
 323     }
 324 }
 325
 326
 327 /* Free an association list (of an ASSOCIATE statement).  */
 328
 329 void
 330 gfc_free_association_list (gfc_association_list* assoc)
 331 {
 332   if (!assoc)
 333     return;
 334
 335   gfc_free_association_list (assoc->next);
 336   free (assoc);
 337 }