Algol 68 Genie

dimension.c

     1  //! @file dimension.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 DIMENSION.
    25  
    26  #include <vif.h>
    27  
    28  void get_dims (IDENT * idf, int_4 dim)
    29  {
    30    EXPR reg;
    31    NEW_RECORD (str);
    32    int_4 rc;
    33    memset (&reg, 0, sizeof (EXPR));
    34    rc = scan (EXPECT_NONE);
    35    if (TOKEN ("*")) {
    36      idf->lwb[idf->mode.dim] = f_stralloc ("1");
    37      idf->upb[idf->mode.dim] = f_stralloc ("0");
    38      idf->len[idf->mode.dim++] = f_stralloc ("VARY");
    39      rc = scan (EXPECT_NONE);
    40    } else {
    41      macro_depth = 0;
    42      express (&reg, INTEGER, 4);
    43      if (reg.variant != EXPR_CONST) {
    44        if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
    45          ;
    46        } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
    47          ;
    48        } else if (reg.variant == EXPR_VAR) {
    49          ERROR (1201, "must be common or parameter", F_NAME (reg.idf));  
    50        }
    51        idf->variable = TRUE;
    52        idf->mode.save = AUTOMATIC;
    53      }
    54      rc = scan (EXPECT_NONE);
    55      int varying = FALSE;
    56      if (TOKEN (":")) {
    57        idf->lwb[idf->mode.dim] = f_stralloc (reg.str);
    58        rc = scan (EXPECT_NONE);
    59        if (TOKEN ("*")) {
    60  // (lwb : *)
    61          idf->upb[idf->mode.dim] = f_stralloc ("0");
    62          idf->len[idf->mode.dim++] = f_stralloc ("VARY");
    63          varying = TRUE;
    64        } else {
    65          macro_depth = 0;
    66          express (&reg, INTEGER, 4);
    67          if (reg.variant != EXPR_CONST) {
    68            if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
    69              ;
    70            } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
    71              ;
    72            } else if (reg.variant == EXPR_VAR) {
    73              ERROR (1202, "must be common or parameter", F_NAME (reg.idf));  
    74            }
    75            idf->variable = TRUE;
    76            idf->mode.save = AUTOMATIC;
    77          }
    78          idf->upb[idf->mode.dim] = f_stralloc (reg.str);
    79        }
    80        rc = scan (EXPECT_NONE);
    81      } else {
    82        idf->lwb[idf->mode.dim] = f_stralloc ("1");
    83        idf->upb[idf->mode.dim] = f_stralloc (reg.str);
    84      }
    85      if (! varying) {
    86        NEW_RECORD (buf);
    87        if (strcmp (idf->lwb[idf->mode.dim], "1") == 0) {
    88          _srecordf (str, "%s", idf->upb[idf->mode.dim]);
    89        } else {
    90          _srecordf (str, "%s - %s + 1", idf->upb[idf->mode.dim], idf->lwb[idf->mode.dim]);
    91        }
    92        fold_int_4 (buf, str);
    93        idf->len[idf->mode.dim++] = f_stralloc (buf);
    94      }
    95    }
    96    if (TOKEN (",")) {
    97      if (dim < MAX_DIMS) {
    98        get_dims (idf, dim + 1);
    99      } else {
   100        ERROR (1203, "too many dimensions", NO_TEXT);
   101      }
   102    }
   103    (void) rc;
   104  }
   105  
   106  void dimension (void)
   107  {
   108    int_4 rc = scan (EXPECT_NONE), set = 0;
   109    while (rc != END_OF_LINE) {
   110      MODE mode;
   111      if (rc == WORD) {
   112        if (/* reserved (curlex) */ FALSE) {
   113          ERROR (1204, "reserved symbol", curlex);
   114        }
   115        set++;
   116        IDENT *idf = void_decl (curlex, &mode);
   117        rc = scan ("(");
   118        if (idf != NO_IDENT) {
   119          if (IS_ROW (idf->mode)) {
   120            ERROR (1205, "variable already dimensioned", F_NAME (idf));
   121          }
   122          get_dims (idf, 1);
   123          CHECKPOINT (1206, ")");
   124          rc = scan (EXPECT_NONE);
   125        }
   126      }
   127      if (TOKEN (",")) {
   128        rc = scan (EXPECT_NONE);
   129        if (! WITHIN) {
   130          SYNTAX (1207, NO_TEXT);
   131        }
   132      } else {
   133        if (rc != END_OF_LINE) {
   134          SYNTAX (1208, NO_TEXT);
   135          rc = scan (EXPECT_NONE);
   136        }
   137      }
   138    }
   139    if (set == 0) {
   140      SYNTAX (1209, "dimension statement");
   141    }
   142  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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