contrib/gcc-3.4/gcc/f/stw.c

   1 /* stw.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 2003 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None (despite the name, it doesn't really depend on ffest*)
  24
  25    Description:
  26       Provides abstraction and stack mechanism to track the block structure
  27       of a Fortran program.
  28
  29    Modifications:
  30 */
  31
  32 /* Include files. */
  33
  34 #include "proj.h"
  35 #include "stw.h"
  36 #include "bld.h"
  37 #include "com.h"
  38 #include "info.h"
  39 #include "lab.h"
  40 #include "lex.h"
  41 #include "malloc.h"
  42 #include "sta.h"
  43 #include "stv.h"
  44 #include "symbol.h"
  45 #include "where.h"
  46
  47 /* Externals defined here. */
  48
  49 ffestw ffestw_stack_top_ = NULL;
  50
  51 /* Simple definitions and enumerations. */
  52
  53
  54 /* Internal typedefs. */
  55
  56
  57 /* Private include files. */
  58
  59
  60 /* Internal structure definitions. */
  61
  62
  63 /* Static objects accessed by functions in this module. */
  64
  65
  66 /* Static functions (internal). */
  67
  68
  69 /* Internal macros. */
  70 \f
  71
  72 /* ffestw_display_state -- DEBUGGING; display current block state
  73
  74    ffestw_display_state();  */
  75
  76 void
  77 ffestw_display_state (void)
  78 {
  79   assert (ffestw_stack_top_ != NULL);
  80
  81   if (!ffe_is_ffedebug ())
  82     return;
  83
  84   fprintf (dmpout, "; block %lu, state ", ffestw_stack_top_->blocknum_);
  85   switch (ffestw_stack_top_->state_)
  86     {
  87     case FFESTV_stateNIL:
  88       fputs ("NIL", dmpout);
  89       break;
  90
  91     case FFESTV_statePROGRAM0:
  92       fputs ("PROGRAM0", dmpout);
  93       break;
  94
  95     case FFESTV_statePROGRAM1:
  96       fputs ("PROGRAM1", dmpout);
  97       break;
  98
  99     case FFESTV_statePROGRAM2:
 100       fputs ("PROGRAM2", dmpout);
 101       break;
 102
 103     case FFESTV_statePROGRAM3:
 104       fputs ("PROGRAM3", dmpout);
 105       break;
 106
 107     case FFESTV_statePROGRAM4:
 108       fputs ("PROGRAM4", dmpout);
 109       break;
 110
 111     case FFESTV_statePROGRAM5:
 112       fputs ("PROGRAM5", dmpout);
 113       break;
 114
 115     case FFESTV_stateSUBROUTINE0:
 116       fputs ("SUBROUTINE0", dmpout);
 117       break;
 118
 119     case FFESTV_stateSUBROUTINE1:
 120       fputs ("SUBROUTINE1", dmpout);
 121       break;
 122
 123     case FFESTV_stateSUBROUTINE2:
 124       fputs ("SUBROUTINE2", dmpout);
 125       break;
 126
 127     case FFESTV_stateSUBROUTINE3:
 128       fputs ("SUBROUTINE3", dmpout);
 129       break;
 130
 131     case FFESTV_stateSUBROUTINE4:
 132       fputs ("SUBROUTINE4", dmpout);
 133       break;
 134
 135     case FFESTV_stateSUBROUTINE5:
 136       fputs ("SUBROUTINE5", dmpout);
 137       break;
 138
 139     case FFESTV_stateFUNCTION0:
 140       fputs ("FUNCTION0", dmpout);
 141       break;
 142
 143     case FFESTV_stateFUNCTION1:
 144       fputs ("FUNCTION1", dmpout);
 145       break;
 146
 147     case FFESTV_stateFUNCTION2:
 148       fputs ("FUNCTION2", dmpout);
 149       break;
 150
 151     case FFESTV_stateFUNCTION3:
 152       fputs ("FUNCTION3", dmpout);
 153       break;
 154
 155     case FFESTV_stateFUNCTION4:
 156       fputs ("FUNCTION4", dmpout);
 157       break;
 158
 159     case FFESTV_stateFUNCTION5:
 160       fputs ("FUNCTION5", dmpout);
 161       break;
 162
 163     case FFESTV_stateMODULE0:
 164       fputs ("MODULE0", dmpout);
 165       break;
 166
 167     case FFESTV_stateMODULE1:
 168       fputs ("MODULE1", dmpout);
 169       break;
 170
 171     case FFESTV_stateMODULE2:
 172       fputs ("MODULE2", dmpout);
 173       break;
 174
 175     case FFESTV_stateMODULE3:
 176       fputs ("MODULE3", dmpout);
 177       break;
 178
 179     case FFESTV_stateMODULE4:
 180       fputs ("MODULE4", dmpout);
 181       break;
 182
 183     case FFESTV_stateMODULE5:
 184       fputs ("MODULE5", dmpout);
 185       break;
 186
 187     case FFESTV_stateBLOCKDATA0:
 188       fputs ("BLOCKDATA0", dmpout);
 189       break;
 190
 191     case FFESTV_stateBLOCKDATA1:
 192       fputs ("BLOCKDATA1", dmpout);
 193       break;
 194
 195     case FFESTV_stateBLOCKDATA2:
 196       fputs ("BLOCKDATA2", dmpout);
 197       break;
 198
 199     case FFESTV_stateBLOCKDATA3:
 200       fputs ("BLOCKDATA3", dmpout);
 201       break;
 202
 203     case FFESTV_stateBLOCKDATA4:
 204       fputs ("BLOCKDATA4", dmpout);
 205       break;
 206
 207     case FFESTV_stateBLOCKDATA5:
 208       fputs ("BLOCKDATA5", dmpout);
 209       break;
 210
 211     case FFESTV_stateUSE:
 212       fputs ("USE", dmpout);
 213       break;
 214
 215     case FFESTV_stateTYPE:
 216       fputs ("TYPE", dmpout);
 217       break;
 218
 219     case FFESTV_stateINTERFACE0:
 220       fputs ("INTERFACE0", dmpout);
 221       break;
 222
 223     case FFESTV_stateINTERFACE1:
 224       fputs ("INTERFACE1", dmpout);
 225       break;
 226
 227     case FFESTV_stateSTRUCTURE:
 228       fputs ("STRUCTURE", dmpout);
 229       break;
 230
 231     case FFESTV_stateUNION:
 232       fputs ("UNION", dmpout);
 233       break;
 234
 235     case FFESTV_stateMAP:
 236       fputs ("MAP", dmpout);
 237       break;
 238
 239     case FFESTV_stateWHERETHEN:
 240       fputs ("WHERETHEN", dmpout);
 241       break;
 242
 243     case FFESTV_stateWHERE:
 244       fputs ("WHERE", dmpout);
 245       break;
 246
 247     case FFESTV_stateIFTHEN:
 248       fputs ("IFTHEN", dmpout);
 249       break;
 250
 251     case FFESTV_stateIF:
 252       fputs ("IF", dmpout);
 253       break;
 254
 255     case FFESTV_stateDO:
 256       fputs ("DO", dmpout);
 257       break;
 258
 259     case FFESTV_stateSELECT0:
 260       fputs ("SELECT0", dmpout);
 261       break;
 262
 263     case FFESTV_stateSELECT1:
 264       fputs ("SELECT1", dmpout);
 265       break;
 266
 267     default:
 268       assert ("bad state" == NULL);
 269       break;
 270     }
 271   if (ffestw_stack_top_->top_do_ != NULL)
 272     fputs (" (within DO)", dmpout);
 273   fputc ('\n', dmpout);
 274 }
 275
 276 /* ffestw_init_0 -- Initialize ffestw structures
 277
 278    ffestw_init_0();  */
 279
 280 void
 281 ffestw_init_0 (void)
 282 {
 283   ffestw b;
 284
 285   ffestw_stack_top_ = b = malloc_new_kp (malloc_pool_image (),
 286                                          "FFESTW stack base", sizeof (*b));
 287   b->uses_ = 0;                 /* catch if anyone uses, kills, &c this
 288                                    block. */
 289   b->next_ = NULL;
 290   b->previous_ = NULL;
 291   b->top_do_ = NULL;
 292   b->blocknum_ = 0;
 293   b->shriek_ = NULL;
 294   b->state_ = FFESTV_stateNIL;
 295   b->line_ = ffewhere_line_unknown ();
 296   b->col_ = ffewhere_column_unknown ();
 297 }
 298
 299 /* ffestw_kill -- Kill block
 300
 301    ffestw b;
 302    ffestw_kill(b);  */
 303
 304 void
 305 ffestw_kill (ffestw b)
 306 {
 307   assert (b != NULL);
 308   assert (b->uses_ > 0);
 309
 310   if (--b->uses_ != 0)
 311     return;
 312
 313   ffewhere_line_kill (b->line_);
 314   ffewhere_column_kill (b->col_);
 315 }
 316
 317 /* ffestw_new -- Create block
 318
 319    ffestw b;
 320    b = ffestw_new();  */
 321
 322 ffestw
 323 ffestw_new (void)
 324 {
 325   ffestw b;
 326
 327   b = malloc_new_kp (malloc_pool_image (), "FFESTW", sizeof (*b));
 328   b->uses_ = 1;
 329
 330   return b;
 331 }
 332
 333 /* ffestw_pop -- Pop block off stack
 334
 335    ffestw_pop();  */
 336
 337 ffestw
 338 ffestw_pop (void)
 339 {
 340   ffestw b;
 341   ffestw oldb = ffestw_stack_top_;
 342
 343   assert (oldb != NULL);
 344   ffestw_stack_top_ = b = ffestw_stack_top_->previous_;
 345   assert (b != NULL);
 346   if ((ffewhere_line_is_unknown (b->line_) || ffewhere_column_is_unknown (b->col_))
 347       && (ffesta_tokens[0] != NULL))
 348     {
 349       assert (b->state_ == FFESTV_stateNIL);
 350       if (ffewhere_line_is_unknown (b->line_))
 351         b->line_
 352           = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
 353       if (ffewhere_column_is_unknown (b->col_))
 354         b->col_
 355           = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
 356     }
 357
 358   return oldb;
 359 }
 360
 361 /* ffestw_push -- Push block onto stack, return its address
 362
 363    ffestw b;  // NULL if new block to be obtained first.
 364    ffestw_push(b);
 365
 366    Returns address of block if desired, also updates ffestw_stack_top_
 367    to point to it.
 368
 369    30-Oct-91  JCB  2.0
 370       Takes block as arg, or NULL if new block needed.  */
 371
 372 ffestw
 373 ffestw_push (ffestw b)
 374 {
 375   if (b == NULL)
 376     b = ffestw_new ();
 377
 378   b->next_ = NULL;
 379   b->previous_ = ffestw_stack_top_;
 380   b->line_ = ffewhere_line_unknown ();
 381   b->col_ = ffewhere_column_unknown ();
 382   ffestw_stack_top_ = b;
 383   return b;
 384 }
 385
 386 /* ffestw_update -- Update current block line/col info
 387
 388    ffestw_update();
 389
 390    Updates block to point to current statement.  */
 391
 392 ffestw
 393 ffestw_update (ffestw b)
 394 {
 395   if (b == NULL)
 396     {
 397       b = ffestw_stack_top_;
 398       assert (b != NULL);
 399     }
 400
 401   if (ffesta_tokens[0] == NULL)
 402     return b;
 403
 404   ffewhere_line_kill (b->line_);
 405   ffewhere_column_kill (b->col_);
 406   b->line_ = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
 407   b->col_ = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
 408
 409   return b;
 410 }
 411
 412 /* ffestw_use -- Mark extra use of block
 413
 414    ffestw b;
 415    b = ffestw_use(b);  // will always return original copy of b
 416
 417    Increments use counter for b.  */
 418
 419 ffestw
 420 ffestw_use (ffestw b)
 421 {
 422   assert (b != NULL);
 423   assert (b->uses_ != 0);
 424
 425   ++b->uses_;
 426
 427   return b;
 428 }