Algol 68 Genie

common.c

     
   1  //! @file common.c
   2  //! @author J. Marcel van der Veer
   3  //
   4  //! @section Copyright
   5  //
   6  // This file is part of VIF - vintage FORTRAN compiler.
   7  // Copyright 2020-2024 J. Marcel van der Veer <algol68g@xs4all.nl>.
   8  //
   9  //! @section License
  10  //
  11  // This program is free software; you can redistribute it and/or modify it 
  12  // under the terms of the GNU General Public License as published by the 
  13  // Free Software Foundation; either version 3 of the License, or 
  14  // (at your option) any later version.
  15  //
  16  // This program is distributed in the hope that it will be useful, but 
  17  // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  // more details. You should have received a copy of the GNU General Public 
  20  // License along with this program. If not, see <http://www.gnu.org/licenses/>.
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Compiler COMMON statements.
  25  
  26  #include <vif.h>
  27  
  28  void merge_commons (void)
  29  {
  30    int_4 k, g;
  31    for (k = 0; k < nlocals; k++) {
  32      IDENT *idf = &locals[k];
  33      int_4 found = FALSE;
  34      if (idf->common > 0 && idf->common != EXTERN) {
  35        for (g = 0; g < nglobals && !found; g++) {
  36          IDENT *idg = &globals[g];
  37          if (idf->common == idg->common && EQUAL (CID (idf), CID (idg))) {
  38            int_4 same = TRUE;
  39            found = TRUE;
  40            same &= (idf->mode.type == idg->mode.type);
  41            same &= (idf->mode.len == idg->mode.len);
  42            same &= (idf->mode.dim == idg->mode.dim);
  43            if (same) {
  44              int_4 n;
  45              for (n = 0; n < idf->mode.dim; n++) {
  46                same &= (EQUAL (idf->lwb[n], idg->lwb[n]));
  47                same &= (EQUAL (idf->upb[n], idg->upb[n]));
  48              }
  49            }
  50            if (!same) {
  51              ERROR (601, "common block consistency", CID (idg));
  52            }
  53          }
  54        }
  55        if (!found) {
  56          if (nglobals >= MAX_IDENTS) {
  57            ERROR (602, "too many common identifiers", NULL);
  58            return;
  59          }
  60  // Copy-paste into global name space.
  61          IDENT *idn = &globals[nglobals++];
  62          memcpy (idn, idf, sizeof (IDENT));
  63        }
  64      }
  65    }
  66  }
  67  
  68  void common (void)
  69  {
  70    int_4 cblck = LOCAL, rc;
  71    rc = scan (NULL);
  72    if (!TOKEN ("/")) {
  73      cblck = add_block ("_common");
  74    }
  75    while (WITHIN) {
  76      if (TOKEN (",")) {
  77        rc = scan (NULL);
  78        if (!WITHIN) {
  79          SYNTAX (603, "common block");
  80        }
  81      } else if (TOKEN ("/")) {
  82        rc = scan (NULL);
  83        if (rc != WORD) {
  84          SYNTAX (604, "common block name");
  85        } else {
  86          cblck = add_block (curlex);
  87        }
  88        rc = scan ("/");
  89        rc = scan (NULL);
  90      } else if (rc == WORD) {
  91        MODE mode;
  92        IDENT *idf = void_decl (curlex, &mode);
  93        if (idf != NULL) {
  94          idf->common = cblck;
  95        }
  96        rc = scan (NULL);
  97        if (TOKEN ("(") && idf != NULL) {
  98          if (idf->mode.dim != 0) {
  99            ERROR (605, "already dimensioned", CID (idf));
 100          }
 101          get_dims (idf, 1);
 102          rc = scan (NULL);
 103        }
 104      } else {
 105        SYNTAX (606, "common block");
 106        rc = scan (NULL);
 107      }
 108    }
 109  }
 110  
 111  void get_common (void)
 112  {
 113    int_4 go_on = TRUE;
 114    while (go_on) {
 115      SAVE_POS;
 116      int_4 rc = scan (NULL);
 117      if (rc == DECLAR) {
 118        skip_card ();
 119      } else if (TOKEN ("implicit")) {
 120        skip_card ();
 121      } else if (TOKEN ("save")) {
 122        skip_card ();
 123      } else if (TOKEN ("automatic")) {
 124        skip_card ();
 125      } else if (TOKEN ("parameter")) {
 126        skip_card ();
 127      } else if (TOKEN ("common")) {
 128        common ();
 129        skip_card ();
 130      } else if (TOKEN ("dimension")) {
 131        skip_card ();
 132      } else if (TOKEN ("equivalence")) {
 133        skip_card ();
 134      } else if (TOKEN ("external")) {
 135        skip_card ();
 136      } else if (TOKEN ("intrinsic")) {
 137        skip_card ();
 138      } else if (TOKEN ("data")) {
 139        skip_card ();
 140      } else if (strlen (curlex) > 0) {
 141  // Backspace and done.
 142        RESTORE_POS;
 143        go_on = FALSE;
 144      }
 145    }
 146  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

This website is archived by the National Library of the Netherlands.