Open64: osprey/kgccfe/gnu/f/stw.c Source File

00001 /* stw.c -- Implementation File (module.c template V1.0)
00002    Copyright (C) 1995 Free Software Foundation, Inc.
00003    Contributed by James Craig Burley.
00004 
00005 This file is part of GNU Fortran.
00006 
00007 GNU Fortran is free software; you can redistribute it and/or modify
00008 it under the terms of the GNU General Public License as published by
00009 the Free Software Foundation; either version 2, or (at your option)
00010 any later version.
00011 
00012 GNU Fortran is distributed in the hope that it will be useful,
00013 but WITHOUT ANY WARRANTY; without even the implied warranty of
00014 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00015 GNU General Public License for more details.
00016 
00017 You should have received a copy of the GNU General Public License
00018 along with GNU Fortran; see the file COPYING.  If not, write to
00019 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
00020 02111-1307, USA.
00021 
00022    Related Modules:
00023       None (despite the name, it doesn't really depend on ffest*)
00024 
00025    Description:
00026       Provides abstraction and stack mechanism to track the block structure
00027       of a Fortran program.
00028 
00029    Modifications:
00030 */
00031 
00032 /* Include files. */
00033 
00034 #include "proj.h"
00035 #include "stw.h"
00036 #include "bld.h"
00037 #include "com.h"
00038 #include "info.h"
00039 #include "lab.h"
00040 #include "lex.h"
00041 #include "malloc.h"
00042 #include "sta.h"
00043 #include "stv.h"
00044 #include "symbol.h"
00045 #include "where.h"
00046 
00047 /* Externals defined here. */
00048 
00049 ffestw ffestw_stack_top_ = NULL;
00050 
00051 /* Simple definitions and enumerations. */
00052 
00053 
00054 /* Internal typedefs. */
00055 
00056 
00057 /* Private include files. */
00058 
00059 
00060 /* Internal structure definitions. */
00061 
00062 
00063 /* Static objects accessed by functions in this module. */
00064 
00065 
00066 /* Static functions (internal). */
00067 
00068 
00069 /* Internal macros. */
00070 
00071 
00072 /* ffestw_display_state -- DEBUGGING; display current block state
00073 
00074    ffestw_display_state();  */
00075 
00076 void
00077 ffestw_display_state (void)
00078 {
00079   assert (ffestw_stack_top_ != NULL);
00080 
00081   if (!ffe_is_ffedebug ())
00082     return;
00083 
00084   fprintf (dmpout, "; block %lu, state ", ffestw_stack_top_->blocknum_);
00085   switch (ffestw_stack_top_->state_)
00086     {
00087     case FFESTV_stateNIL:
00088       fputs ("NIL", dmpout);
00089       break;
00090 
00091     case FFESTV_statePROGRAM0:
00092       fputs ("PROGRAM0", dmpout);
00093       break;
00094 
00095     case FFESTV_statePROGRAM1:
00096       fputs ("PROGRAM1", dmpout);
00097       break;
00098 
00099     case FFESTV_statePROGRAM2:
00100       fputs ("PROGRAM2", dmpout);
00101       break;
00102 
00103     case FFESTV_statePROGRAM3:
00104       fputs ("PROGRAM3", dmpout);
00105       break;
00106 
00107     case FFESTV_statePROGRAM4:
00108       fputs ("PROGRAM4", dmpout);
00109       break;
00110 
00111     case FFESTV_statePROGRAM5:
00112       fputs ("PROGRAM5", dmpout);
00113       break;
00114 
00115     case FFESTV_stateSUBROUTINE0:
00116       fputs ("SUBROUTINE0", dmpout);
00117       break;
00118 
00119     case FFESTV_stateSUBROUTINE1:
00120       fputs ("SUBROUTINE1", dmpout);
00121       break;
00122 
00123     case FFESTV_stateSUBROUTINE2:
00124       fputs ("SUBROUTINE2", dmpout);
00125       break;
00126 
00127     case FFESTV_stateSUBROUTINE3:
00128       fputs ("SUBROUTINE3", dmpout);
00129       break;
00130 
00131     case FFESTV_stateSUBROUTINE4:
00132       fputs ("SUBROUTINE4", dmpout);
00133       break;
00134 
00135     case FFESTV_stateSUBROUTINE5:
00136       fputs ("SUBROUTINE5", dmpout);
00137       break;
00138 
00139     case FFESTV_stateFUNCTION0:
00140       fputs ("FUNCTION0", dmpout);
00141       break;
00142 
00143     case FFESTV_stateFUNCTION1:
00144       fputs ("FUNCTION1", dmpout);
00145       break;
00146 
00147     case FFESTV_stateFUNCTION2:
00148       fputs ("FUNCTION2", dmpout);
00149       break;
00150 
00151     case FFESTV_stateFUNCTION3:
00152       fputs ("FUNCTION3", dmpout);
00153       break;
00154 
00155     case FFESTV_stateFUNCTION4:
00156       fputs ("FUNCTION4", dmpout);
00157       break;
00158 
00159     case FFESTV_stateFUNCTION5:
00160       fputs ("FUNCTION5", dmpout);
00161       break;
00162 
00163     case FFESTV_stateMODULE0:
00164       fputs ("MODULE0", dmpout);
00165       break;
00166 
00167     case FFESTV_stateMODULE1:
00168       fputs ("MODULE1", dmpout);
00169       break;
00170 
00171     case FFESTV_stateMODULE2:
00172       fputs ("MODULE2", dmpout);
00173       break;
00174 
00175     case FFESTV_stateMODULE3:
00176       fputs ("MODULE3", dmpout);
00177       break;
00178 
00179     case FFESTV_stateMODULE4:
00180       fputs ("MODULE4", dmpout);
00181       break;
00182 
00183     case FFESTV_stateMODULE5:
00184       fputs ("MODULE5", dmpout);
00185       break;
00186 
00187     case FFESTV_stateBLOCKDATA0:
00188       fputs ("BLOCKDATA0", dmpout);
00189       break;
00190 
00191     case FFESTV_stateBLOCKDATA1:
00192       fputs ("BLOCKDATA1", dmpout);
00193       break;
00194 
00195     case FFESTV_stateBLOCKDATA2:
00196       fputs ("BLOCKDATA2", dmpout);
00197       break;
00198 
00199     case FFESTV_stateBLOCKDATA3:
00200       fputs ("BLOCKDATA3", dmpout);
00201       break;
00202 
00203     case FFESTV_stateBLOCKDATA4:
00204       fputs ("BLOCKDATA4", dmpout);
00205       break;
00206 
00207     case FFESTV_stateBLOCKDATA5:
00208       fputs ("BLOCKDATA5", dmpout);
00209       break;
00210 
00211     case FFESTV_stateUSE:
00212       fputs ("USE", dmpout);
00213       break;
00214 
00215     case FFESTV_stateTYPE:
00216       fputs ("TYPE", dmpout);
00217       break;
00218 
00219     case FFESTV_stateINTERFACE0:
00220       fputs ("INTERFACE0", dmpout);
00221       break;
00222 
00223     case FFESTV_stateINTERFACE1:
00224       fputs ("INTERFACE1", dmpout);
00225       break;
00226 
00227     case FFESTV_stateSTRUCTURE:
00228       fputs ("STRUCTURE", dmpout);
00229       break;
00230 
00231     case FFESTV_stateUNION:
00232       fputs ("UNION", dmpout);
00233       break;
00234 
00235     case FFESTV_stateMAP:
00236       fputs ("MAP", dmpout);
00237       break;
00238 
00239     case FFESTV_stateWHERETHEN:
00240       fputs ("WHERETHEN", dmpout);
00241       break;
00242 
00243     case FFESTV_stateWHERE:
00244       fputs ("WHERE", dmpout);
00245       break;
00246 
00247     case FFESTV_stateIFTHEN:
00248       fputs ("IFTHEN", dmpout);
00249       break;
00250 
00251     case FFESTV_stateIF:
00252       fputs ("IF", dmpout);
00253       break;
00254 
00255     case FFESTV_stateDO:
00256       fputs ("DO", dmpout);
00257       break;
00258 
00259     case FFESTV_stateSELECT0:
00260       fputs ("SELECT0", dmpout);
00261       break;
00262 
00263     case FFESTV_stateSELECT1:
00264       fputs ("SELECT1", dmpout);
00265       break;
00266 
00267     default:
00268       assert ("bad state" == NULL);
00269       break;
00270     }
00271   if (ffestw_stack_top_->top_do_ != NULL)
00272     fputs (" (within DO)", dmpout);
00273   fputc ('\n', dmpout);
00274 }
00275 
00276 /* ffestw_init_0 -- Initialize ffestw structures
00277 
00278    ffestw_init_0();  */
00279 
00280 void
00281 ffestw_init_0 ()
00282 {
00283   ffestw b;
00284 
00285   ffestw_stack_top_ = b = (ffestw) malloc_new_kp (malloc_pool_image (),
00286             "FFESTW stack base", sizeof (*b));
00287   b->uses_ = 0;     /* catch if anyone uses, kills, &c this
00288            block. */
00289   b->next_ = NULL;
00290   b->previous_ = NULL;
00291   b->top_do_ = NULL;
00292   b->blocknum_ = 0;
00293   b->shriek_ = NULL;
00294   b->state_ = FFESTV_stateNIL;
00295   b->line_ = ffewhere_line_unknown ();
00296   b->col_ = ffewhere_column_unknown ();
00297 }
00298 
00299 /* ffestw_kill -- Kill block
00300 
00301    ffestw b;
00302    ffestw_kill(b);  */
00303 
00304 void
00305 ffestw_kill (ffestw b)
00306 {
00307   assert (b != NULL);
00308   assert (b->uses_ > 0);
00309 
00310   if (--b->uses_ != 0)
00311     return;
00312 
00313   ffewhere_line_kill (b->line_);
00314   ffewhere_column_kill (b->col_);
00315 }
00316 
00317 /* ffestw_new -- Create block
00318 
00319    ffestw b;
00320    b = ffestw_new();  */
00321 
00322 ffestw
00323 ffestw_new (void)
00324 {
00325   ffestw b;
00326 
00327   b = (ffestw) malloc_new_kp (malloc_pool_image (), "FFESTW", sizeof (*b));
00328   b->uses_ = 1;
00329 
00330   return b;
00331 }
00332 
00333 /* ffestw_pop -- Pop block off stack
00334 
00335    ffestw_pop();  */
00336 
00337 ffestw
00338 ffestw_pop (void)
00339 {
00340   ffestw b;
00341   ffestw oldb = ffestw_stack_top_;
00342 
00343   assert (oldb != NULL);
00344   ffestw_stack_top_ = b = ffestw_stack_top_->previous_;
00345   assert (b != NULL);
00346   if ((ffewhere_line_is_unknown (b->line_) || ffewhere_column_is_unknown (b->col_))
00347       && (ffesta_tokens[0] != NULL))
00348     {
00349       assert (b->state_ == FFESTV_stateNIL);
00350       if (ffewhere_line_is_unknown (b->line_))
00351   b->line_
00352     = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
00353       if (ffewhere_column_is_unknown (b->col_))
00354   b->col_
00355     = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
00356     }
00357 
00358   return oldb;
00359 }
00360 
00361 /* ffestw_push -- Push block onto stack, return its address
00362 
00363    ffestw b;  // NULL if new block to be obtained first.
00364    ffestw_push(b);
00365 
00366    Returns address of block if desired, also updates ffestw_stack_top_
00367    to point to it.
00368 
00369    30-Oct-91  JCB  2.0
00370       Takes block as arg, or NULL if new block needed.  */
00371 
00372 ffestw
00373 ffestw_push (ffestw b)
00374 {
00375   if (b == NULL)
00376     b = ffestw_new ();
00377 
00378   b->next_ = NULL;
00379   b->previous_ = ffestw_stack_top_;
00380   b->line_ = ffewhere_line_unknown ();
00381   b->col_ = ffewhere_column_unknown ();
00382   ffestw_stack_top_ = b;
00383   return b;
00384 }
00385 
00386 /* ffestw_update -- Update current block line/col info
00387 
00388    ffestw_update();
00389 
00390    Updates block to point to current statement.  */
00391 
00392 ffestw
00393 ffestw_update (ffestw b)
00394 {
00395   if (b == NULL)
00396     {
00397       b = ffestw_stack_top_;
00398       assert (b != NULL);
00399     }
00400 
00401   if (ffesta_tokens[0] == NULL)
00402     return b;
00403 
00404   ffewhere_line_kill (b->line_);
00405   ffewhere_column_kill (b->col_);
00406   b->line_ = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
00407   b->col_ = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
00408 
00409   return b;
00410 }
00411 
00412 /* ffestw_use -- Mark extra use of block
00413 
00414    ffestw b;
00415    b = ffestw_use(b);  // will always return original copy of b
00416 
00417    Increments use counter for b.  */
00418 
00419 ffestw
00420 ffestw_use (ffestw b)
00421 {
00422   assert (b != NULL);
00423   assert (b->uses_ != 0);
00424 
00425   ++b->uses_;
00426 
00427   return b;
00428 }