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-2025 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  //! Compile COMMON.
    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 (NOT_LOCAL (idf) && idf->common != EXTERN) {
    35        for (g = 0; g < nglobals && !found; g++) {
    36          IDENT *idg = &globals[g];
    37          if (idf->common == idg->common && EQUAL (C_NAME (idf), C_NAME (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              NEW_RECORD (where);
    52              _srecordf (where, "%s in block %s", FTN_NAME (idg), commons[idg->common]);
    53              ERROR (701, "common block consistency", where);
    54            }
    55          }
    56        }
    57        if (!found) {
    58          if (nglobals >= MAX_IDENTS) {
    59            ERROR (702, "too many common identifiers", NO_TEXT);
    60            return;
    61          }
    62  // Copy-paste into global name space.
    63          IDENT *idn = &globals[nglobals++];
    64          memcpy (idn, idf, sizeof (IDENT));
    65        }
    66      }
    67    }
    68  }
    69  
    70  void common (void)
    71  {
    72    int_4 cblck = LOCAL, rc;
    73    rc = scan (EXPECT_NONE);
    74    if (!TOKEN ("/")) {
    75      cblck = add_block ("_common");
    76    }
    77    while (WITHIN) {
    78      if (TOKEN (",")) {
    79        rc = scan (EXPECT_NONE);
    80        if (!WITHIN) {
    81          SYNTAX (703, "common block");
    82        }
    83      } else if (TOKEN ("/")) {
    84        rc = scan (EXPECT_NONE);
    85        if (rc != WORD) {
    86          SYNTAX (704, "common block name");
    87        } else {
    88          cblck = add_block (curlex);
    89        }
    90        rc = scan ("/");
    91        rc = scan (EXPECT_NONE);
    92      } else if (rc == WORD) {
    93        if (reserved (curlex)) {
    94          ERROR (705, "reserved symbol", curlex);
    95        }
    96        MODE mode;
    97        IDENT *idf = void_decl (curlex, &mode);
    98        if (idf != NO_IDENT) {
    99          idf->common = cblck;
   100        }
   101        rc = scan (EXPECT_NONE);
   102        if (TOKEN ("(") && idf != NO_IDENT) {
   103          if (IS_ROW (idf->mode)) {
   104            ERROR (706, "already dimensioned", FTN_NAME (idf));
   105          }
   106          get_dims (idf, 1);
   107          rc = scan (EXPECT_NONE);
   108        }
   109      } else {
   110        SYNTAX (707, "common block");
   111        rc = scan (EXPECT_NONE);
   112      }
   113    }
   114  }
   115  
   116  void get_common (void)
   117  {
   118    int_4 go_on = TRUE;
   119    while (go_on) {
   120      SAVE_POS;
   121      int_4 rc = scan (EXPECT_NONE);
   122      if (rc == DECLAR) {
   123        skip_card (FALSE);
   124      } else if (TOKEN ("implicit")) {
   125        skip_card (FALSE);
   126      } else if (TOKEN ("save")) {
   127        skip_card (FALSE);
   128      } else if (TOKEN ("automatic")) {
   129        skip_card (FALSE);
   130      } else if (TOKEN ("parameter")) {
   131        skip_card (FALSE);
   132      } else if (TOKEN ("common")) {
   133        common ();
   134        skip_card (FALSE);
   135      } else if (TOKEN ("dimension")) {
   136        skip_card (FALSE);
   137      } else if (TOKEN ("equivalence")) {
   138        skip_card (FALSE);
   139      } else if (TOKEN ("external")) {
   140        skip_card (FALSE);
   141      } else if (TOKEN ("intrinsic")) {
   142        skip_card (FALSE);
   143      } else if (TOKEN ("data")) {
   144        skip_card (FALSE);
   145      } else if (rc == WORD && is_macro_decl (curlex)) {
   146        skip_card (FALSE);
   147      } else if (strlen (curlex) > 0) {
   148  // Backspace and done.
   149        RESTORE_POS;
   150        go_on = FALSE;
   151      }
   152    }
   153  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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