home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / global.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  13KB  |  491 lines
  1. /* global.c -- Implementation File (module.c template V1.0)
  2.    Copyright (C) 1995 Free Software Foundation, Inc.
  3.    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
  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, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.    Related Modules:
  22.  
  23.    Description:
  24.       Manages information kept across individual program units within a single
  25.       source file.  This includes reporting errors when a name is defined
  26.       multiple times (for example, two program units named FOO) and when a
  27.       COMMON block is given initial data in more than one program unit.
  28.  
  29.    Modifications:
  30. */
  31.  
  32. /* Include files. */
  33.  
  34. #include "proj.h"
  35. #include "global.h"
  36. #include "lex.h"
  37. #include "malloc.h"
  38. #include "name.h"
  39. #include "symbol.h"
  40. #include "top.h"
  41.  
  42. /* Externals defined here. */
  43.  
  44.  
  45. /* Simple definitions and enumerations. */
  46.  
  47.  
  48. /* Internal typedefs. */
  49.  
  50.  
  51. /* Private include files. */
  52.  
  53.  
  54. /* Internal structure definitions. */
  55.  
  56.  
  57. /* Static objects accessed by functions in this module. */
  58.  
  59. #if FFEGLOBAL_ENABLED
  60. static ffenameSpace ffeglobal_filewide_ = NULL;
  61. #endif
  62.  
  63. /* Static functions (internal). */
  64.  
  65.  
  66. /* Internal macros. */
  67.  
  68.  
  69. /* Call given fn with all globals
  70.  
  71.    ffeglobal (*fn)(ffeglobal g);
  72.    ffeglobal_drive(fn);     */
  73.  
  74. #if FFEGLOBAL_ENABLED
  75. void
  76. ffeglobal_drive (ffeglobal (*fn) ())
  77. {
  78.   if (ffeglobal_filewide_ != NULL)
  79.     ffename_space_drive_global (ffeglobal_filewide_, fn);
  80. }
  81.  
  82. #endif
  83. /* ffeglobal_new_ -- Make new global
  84.  
  85.    ffename n;
  86.    ffeglobal g;
  87.    g = ffeglobal_new_(n);  */
  88.  
  89. #if FFEGLOBAL_ENABLED
  90. static ffeglobal
  91. ffeglobal_new_ (ffename n)
  92. {
  93.   ffeglobal g;
  94.  
  95.   assert (n != NULL);
  96.  
  97.   g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL",
  98.                  sizeof (*g));
  99.   g->n = n;
  100. #ifdef FFECOM_globalHOOK
  101.   g->hook = FFECOM_globalNULL;
  102. #endif
  103.  
  104.   ffename_set_global (n, g);
  105.  
  106.   return g;
  107. }
  108.  
  109. #endif
  110. /* ffeglobal_init_1 -- Initialize per file
  111.  
  112.    ffeglobal_init_1();    */
  113.  
  114. void
  115. ffeglobal_init_1 ()
  116. {
  117. #if FFEGLOBAL_ENABLED
  118.   if (ffeglobal_filewide_ != NULL)
  119.     ffename_space_kill (ffeglobal_filewide_);
  120.   ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
  121. #endif
  122. }
  123.  
  124. /* ffeglobal_init_common -- Initial value specified for common block
  125.  
  126.    ffesymbol s;     // the ffesymbol for the common block
  127.    ffelexToken t;  // the token with the point of initialization
  128.    ffeglobal_init_common(s,t);
  129.  
  130.    For back ends where file-wide global symbols are not maintained, does
  131.    nothing.  Otherwise, makes sure this common block hasn't already been
  132.    initialized in a previous program unit, and flag that it's been
  133.    initialized in this one.  */
  134.  
  135. void
  136. ffeglobal_init_common (ffesymbol s, ffelexToken t)
  137. {
  138. #if FFEGLOBAL_ENABLED
  139.   ffeglobal g;
  140.  
  141.   g = ffesymbol_global (s);
  142.   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
  143.     return;
  144.  
  145.   if (g->init == ffe_count_2)
  146.     return;
  147.  
  148.   if (g->init != 0)
  149.     {
  150.       if (g->initt != NULL)
  151.     {
  152.       ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
  153.       ffebad_string (ffesymbol_text (s));
  154.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  155.       ffebad_here (1, ffelex_token_where_line (g->initt),
  156.                ffelex_token_where_column (g->initt));
  157.       ffebad_finish ();
  158.     }
  159.  
  160.       /* Complain about just one attempt to reinit per program unit, but
  161.          continue referring back to the first such successful attempt.  */
  162.     }
  163.   else
  164.     {
  165.       if (g->blank)
  166.     {
  167.       ffebad_start (FFEBAD_COMMON_BLANK_INIT);
  168.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  169.       ffebad_finish ();
  170.     }
  171.  
  172.       g->initt = ffelex_token_use (t);
  173.     }
  174.  
  175.   g->init = ffe_count_2;
  176. #endif
  177. }
  178.  
  179. /* ffeglobal_new_common -- New common block
  180.  
  181.    ffesymbol s;     // the ffesymbol for the new common block
  182.    ffelexToken t;  // the token with the name of the common block
  183.    bool blank;    // TRUE if blank common
  184.    ffeglobal_new_common(s,t,blank);
  185.  
  186.    For back ends where file-wide global symbols are not maintained, does
  187.    nothing.  Otherwise, makes sure this symbol hasn't been seen before or
  188.    is known as a common block.    */
  189.  
  190. void
  191. ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
  192. {
  193. #if FFEGLOBAL_ENABLED
  194.   ffename n;
  195.   ffeglobal g;
  196.  
  197.   if (ffesymbol_global (s) == NULL)
  198.     {
  199.       n = ffename_find (ffeglobal_filewide_, t);
  200.       g = ffename_global (n);
  201.     }
  202.   else
  203.     {
  204.       g = ffesymbol_global (s);
  205.       n = NULL;
  206.     }
  207.  
  208.   if (g != NULL)
  209.     {
  210.       if (g->type == FFEGLOBAL_typeCOMMON)
  211.     {
  212.       assert (g->blank == blank);
  213.     }
  214.       else
  215.     {
  216.       ffebad_start (FFEBAD_FILEWIDE_ALREADY_SEEN);
  217.       ffebad_string (ffelex_token_text (t));
  218.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  219.       ffebad_here (1, ffelex_token_where_line (g->t),
  220.                ffelex_token_where_column (g->t));
  221.       ffebad_finish ();
  222.       g->type = FFEGLOBAL_typeANY;
  223.     }
  224.     }
  225.   else
  226.     {
  227.       g = ffeglobal_new_ (n);
  228.       g->t = ffelex_token_use (t);
  229.       g->init = 0;
  230.       g->type = FFEGLOBAL_typeCOMMON;
  231.       g->have_pad = FALSE;
  232.       g->have_save = FALSE;
  233.       g->have_size = FALSE;
  234.       g->blank = blank;
  235.     }
  236.  
  237.   ffesymbol_set_global (s, g);
  238. #endif
  239. }
  240.  
  241. /* ffeglobal_new_progunit_ -- New program unit
  242.  
  243.    ffesymbol s;     // the ffesymbol for the new unit
  244.    ffelexToken t;  // the token with the name of the unit
  245.    ffeglobalType type;    // the type of the new unit
  246.    ffeglobal_new_progunit_(s,t,type);
  247.  
  248.    For back ends where file-wide global symbols are not maintained, does
  249.    nothing.  Otherwise, makes sure this symbol hasn't been seen before.     */
  250.  
  251. void
  252. ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
  253. {
  254. #if FFEGLOBAL_ENABLED
  255.   ffename n;
  256.   ffeglobal g;
  257.  
  258.   n = ffename_find (ffeglobal_filewide_, t);
  259.   g = ffename_global (n);
  260.   if (g != NULL)
  261.     {
  262.       ffebad_start (FFEBAD_FILEWIDE_ALREADY_SEEN);
  263.       ffebad_string (ffelex_token_text (t));
  264.       ffebad_here (0, ffelex_token_where_line (t),
  265.            ffelex_token_where_column (t));
  266.       ffebad_here (1, ffelex_token_where_line (g->t),
  267.            ffelex_token_where_column (g->t));
  268.       ffebad_finish ();
  269.       g->type = FFEGLOBAL_typeANY;
  270.     }
  271.   else
  272.     {
  273.       g = ffeglobal_new_ (n);
  274.       g->t = ffelex_token_use (t);
  275.       g->type = type;
  276.     }
  277.  
  278.   ffesymbol_set_global (s, g);
  279. #endif
  280. }
  281.  
  282. /* ffeglobal_pad_common -- Check initial padding of common area
  283.  
  284.    ffesymbol s;     // the common area
  285.    ffetargetAlign pad;    // the initial padding
  286.    ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
  287.      ffesymbol_where_column(s));
  288.  
  289.    In global-enabled mode, make sure the padding agrees with any existing
  290.    padding established for the common area, otherwise complain.
  291.    In global-disabled mode, warn about nonzero padding.     */
  292.  
  293. void
  294. ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
  295.               ffewhereColumn wc)
  296. {
  297. #if FFEGLOBAL_ENABLED
  298.   ffeglobal g;
  299.  
  300.   g = ffesymbol_global (s);
  301.   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
  302.     return;            /* Let someone else catch this! */
  303.  
  304.   if (!g->have_pad)
  305.     {
  306.       g->have_pad = TRUE;
  307.       g->pad = pad;
  308.       g->pad_where_line = ffewhere_line_use (wl);
  309.       g->pad_where_col = ffewhere_column_use (wc);
  310.     }
  311.   else
  312.     {
  313.       if (g->pad != pad)
  314.     {
  315.       char padding_1[20];
  316.       char padding_2[20];
  317.  
  318.       sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
  319.       sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->pad);
  320.       ffebad_start (FFEBAD_COMMON_DIFF_PAD);
  321.       ffebad_string (ffesymbol_text (s));
  322.       ffebad_string (padding_1);
  323.       ffebad_here (0, wl, wc);
  324.       ffebad_string (padding_2);
  325.       ffebad_string ((pad == 1)
  326.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  327.       ffebad_string ((g->pad == 1)
  328.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  329.       ffebad_here (1, g->pad_where_line, g->pad_where_col);
  330.       ffebad_finish ();
  331.     }
  332.     }
  333. #endif
  334.  
  335.   if (pad != 0)
  336.     {                /* Warn about initial padding in common area. */
  337.       char padding[20];
  338.  
  339.       sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
  340.       ffebad_start (FFEBAD_COMMON_INIT_PAD);
  341.       ffebad_string (ffesymbol_text (s));
  342.       ffebad_string (padding);
  343.       ffebad_string ((pad == 1)
  344.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  345.       ffebad_here (0, wl, wc);
  346.       ffebad_finish ();
  347.     }
  348. }
  349.  
  350. /* ffeglobal_save_common -- Check SAVE status of common area
  351.  
  352.    ffesymbol s;     // the common area
  353.    bool save;  // TRUE if SAVEd, FALSE otherwise
  354.    ffeglobal_save_common(s,save,ffesymbol_where_line(s),
  355.      ffesymbol_where_column(s));
  356.  
  357.    In global-enabled mode, make sure the save info agrees with any existing
  358.    info established for the common area, otherwise complain.
  359.    In global-disabled mode, do nothing.     */
  360.  
  361. void
  362. ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
  363.                ffewhereColumn wc)
  364. {
  365. #if FFEGLOBAL_ENABLED
  366.   ffeglobal g;
  367.  
  368.   g = ffesymbol_global (s);
  369.   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
  370.     return;            /* Let someone else catch this! */
  371.  
  372.   if (!g->have_save)
  373.     {
  374.       g->have_save = TRUE;
  375.       g->save = save;
  376.       g->save_where_line = ffewhere_line_use (wl);
  377.       g->save_where_col = ffewhere_column_use (wc);
  378.     }
  379.   else
  380.     {
  381.       if ((g->save != save) && ffe_is_pedantic ())
  382.     {
  383.       ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
  384.       ffebad_string (ffesymbol_text (s));
  385.       ffebad_here (save ? 0 : 1, wl, wc);
  386.       ffebad_here (save ? 1 : 0, g->pad_where_line, g->pad_where_col);
  387.       ffebad_finish ();
  388.     }
  389.     }
  390. #endif
  391. }
  392.  
  393. /* ffeglobal_size_common -- Establish size of COMMON area
  394.  
  395.    ffesymbol s;     // the common area
  396.    long size;  // size in units
  397.    if (ffeglobal_size_common(s,size))  // new size is largest seen
  398.  
  399.    In global-enabled mode, set the size if it current size isn't known or is
  400.    smaller than new size, and for non-blank common, complain if old size
  401.    is different from new.  Return TRUE if the new size is the largest seen
  402.    for this COMMON area (or if no size was known for it previously).
  403.    In global-disabled mode, do nothing.     */
  404.  
  405. #if FFEGLOBAL_ENABLED
  406. bool
  407. ffeglobal_size_common (ffesymbol s, long size)
  408. {
  409.   ffeglobal g;
  410.  
  411.   g = ffesymbol_global (s);
  412.   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
  413.     return FALSE;
  414.  
  415.   if (!g->have_size)
  416.     {
  417.       g->have_size = TRUE;
  418.       g->size = size;
  419.       return TRUE;
  420.     }
  421.  
  422.   if ((g->size < size) && (g->init > 0) && (g->init < ffe_count_2))
  423.     {
  424.       char oldsize[40];
  425.       char newsize[40];
  426.  
  427.       sprintf (&oldsize[0], "%ld", g->size);
  428.       sprintf (&newsize[0], "%ld", size);
  429.  
  430.       ffebad_start (FFEBAD_COMMON_ENLARGED);
  431.       ffebad_string (ffesymbol_text (s));
  432.       ffebad_string (oldsize);
  433.       ffebad_string (newsize);
  434.       ffebad_string ((g->size == 1)
  435.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  436.       ffebad_string ((size == 1)
  437.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  438.       ffebad_here (0, ffelex_token_where_line (g->initt),
  439.            ffelex_token_where_column (g->initt));
  440.       ffebad_here (1, ffesymbol_where_line (s),
  441.            ffesymbol_where_column (s));
  442.       ffebad_finish ();
  443.     }
  444.   else if ((g->size != size) && !g->blank)
  445.     {
  446.       char oldsize[40];
  447.       char newsize[40];
  448.  
  449.       /* Warn about this even if not -pedantic, because putting all
  450.      program units in a single source file is the only way to
  451.      detect this.  Apparently UNIX-model linkers neither handle
  452.      nor report when they make a common unit smaller than
  453.      requested, such as when the smaller-declared version is
  454.      initialized and the larger-declared version is not.  So
  455.      if people complain about strange overwriting, we can tell
  456.      them to put all their code in a single file and compile
  457.      that way.  Warnings about differing sizes must therefore
  458.      always be issued.  */
  459.  
  460.       sprintf (&oldsize[0], "%ld", g->size);
  461.       sprintf (&newsize[0], "%ld", size);
  462.  
  463.       ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
  464.       ffebad_string (ffesymbol_text (s));
  465.       ffebad_string (oldsize);
  466.       ffebad_string (newsize);
  467.       ffebad_string ((g->size == 1)
  468.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  469.       ffebad_string ((size == 1)
  470.              ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
  471.       ffebad_here (0, ffelex_token_where_line (g->t),
  472.            ffelex_token_where_column (g->t));
  473.       ffebad_here (1, ffesymbol_where_line (s),
  474.            ffesymbol_where_column (s));
  475.       ffebad_finish ();
  476.     }
  477.  
  478.   if (size > g->size)
  479.     {
  480.       g->size = size;
  481.       return TRUE;
  482.     }
  483.   return FALSE;
  484. }
  485.  
  486. #endif
  487. void
  488. ffeglobal_terminate_1 ()
  489. {
  490. }
  491.