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      express (&reg, INTEGER, 4);
    42      if (reg.variant != EXPR_CONST) {
    43        if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
    44          ;
    45        } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
    46          ;
    47        } else if (reg.variant == EXPR_VAR) {
    48          ERROR (1101, "must be common or parameter", FTN_NAME (reg.idf));  
    49        }
    50        idf->variable = TRUE;
    51        idf->mode.save = AUTOMATIC;
    52      }
    53      rc = scan (EXPECT_NONE);
    54      int varying = FALSE;
    55      if (TOKEN (":")) {
    56        idf->lwb[idf->mode.dim] = f_stralloc (reg.str);
    57        rc = scan (EXPECT_NONE);
    58        if (TOKEN ("*")) {
    59  // (lwb : *)
    60          idf->upb[idf->mode.dim] = f_stralloc ("0");
    61          idf->len[idf->mode.dim++] = f_stralloc ("VARY");
    62          varying = TRUE;
    63        } else {
    64          express (&reg, INTEGER, 4);
    65          if (reg.variant != EXPR_CONST) {
    66            if (reg.variant == EXPR_VAR && reg.idf->arg == ARG) {
    67              ;
    68            } else if (reg.variant == EXPR_VAR && reg.idf->common > 0) {
    69              ;
    70            } else if (reg.variant == EXPR_VAR) {
    71              ERROR (1102, "must be common or parameter", FTN_NAME (reg.idf));  
    72            }
    73            idf->variable = TRUE;
    74            idf->mode.save = AUTOMATIC;
    75          }
    76          idf->upb[idf->mode.dim] = f_stralloc (reg.str);
    77        }
    78        rc = scan (EXPECT_NONE);
    79      } else {
    80        idf->lwb[idf->mode.dim] = f_stralloc ("1");
    81        idf->upb[idf->mode.dim] = f_stralloc (reg.str);
    82      }
    83      if (! varying) {
    84        NEW_RECORD (buf);
    85        if (strcmp (idf->lwb[idf->mode.dim], "1") == 0) {
    86          _srecordf (str, "%s", idf->upb[idf->mode.dim]);
    87        } else {
    88          _srecordf (str, "%s - %s + 1", idf->upb[idf->mode.dim], idf->lwb[idf->mode.dim]);
    89        }
    90        fold_int_4 (buf, str);
    91        idf->len[idf->mode.dim++] = f_stralloc (buf);
    92      }
    93    }
    94    if (TOKEN (",")) {
    95      if (dim < MAX_DIMS) {
    96        get_dims (idf, dim + 1);
    97      } else {
    98        ERROR (1103, "too many dimensions", NO_TEXT);
    99      }
   100    }
   101    (void) rc;
   102  }
   103  
   104  void dimension (void)
   105  {
   106    int_4 rc = scan (EXPECT_NONE);
   107    while (rc != END_OF_LINE) {
   108      MODE mode;
   109      if (rc == WORD) {
   110        if (reserved (curlex)) {
   111          ERROR (1104, "reserved symbol", curlex);
   112        }
   113        IDENT *idf = void_decl (curlex, &mode);
   114        rc = scan ("(");
   115        if (idf != NO_IDENT) {
   116          if (IS_ROW (idf->mode)) {
   117            ERROR (1105, "already dimensioned", C_NAME (idf));
   118          }
   119          get_dims (idf, 1);
   120          CHECKPOINT (1106, ")");
   121          rc = scan (EXPECT_NONE);
   122        }
   123      }
   124      if (TOKEN (",")) {
   125        rc = scan (EXPECT_NONE);
   126        if (! WITHIN) {
   127          SYNTAX (1107, NO_TEXT);
   128        }
   129      } else {
   130        if (rc != END_OF_LINE) {
   131          SYNTAX (1108, NO_TEXT);
   132          rc = scan (EXPECT_NONE);
   133        }
   134      }
   135    }
   136  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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