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-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  //! Compile DIMENSION statements.
  25  
  26  #include <vif.h>
  27  
  28  void get_dims (IDENT * idf, int_4 dim)
  29  {
  30    EXPR reg;
  31    RECORD str;
  32    int_4 rc;
  33    memset (&reg, 0, sizeof (EXPR));
  34    rc = scan (NULL);
  35    if (TOKEN ("*")) {
  36      idf->lwb[idf->mode.dim] = stralloc ("1");
  37      idf->upb[idf->mode.dim] = stralloc ("0");
  38      idf->len[idf->mode.dim++] = stralloc ("VARY");
  39      rc = scan (NULL);
  40    } else {
  41      express (&reg, INTEGER, 4);
  42      if (reg.variant != EXPR_CONST) {
  43        idf->variable = TRUE;
  44        idf->mode.save = AUTOMATIC;
  45      }
  46      rc = scan (NULL);
  47      int varying = FALSE;
  48      if (TOKEN (":")) {
  49        idf->lwb[idf->mode.dim] = stralloc (reg.str);
  50        rc = scan (NULL);
  51        if (TOKEN ("*")) {
  52  // (lwb : *)
  53          idf->upb[idf->mode.dim] = stralloc ("0");
  54          idf->len[idf->mode.dim++] = stralloc ("VARY");
  55          varying = TRUE;
  56        } else {
  57          express (&reg, INTEGER, 4);
  58          if (reg.variant != EXPR_CONST) {
  59            idf->variable = TRUE;
  60            idf->mode.save = AUTOMATIC;
  61          }
  62          idf->upb[idf->mode.dim] = stralloc (reg.str);
  63        }
  64        rc = scan (NULL);
  65      } else {
  66        idf->lwb[idf->mode.dim] = stralloc ("1");
  67        idf->upb[idf->mode.dim] = stralloc (reg.str);
  68      }
  69      if (! varying) {
  70        RECORD buf;
  71        if (strcmp (idf->lwb[idf->mode.dim], "1") == 0) {
  72          _srecordf (str, "%s", idf->upb[idf->mode.dim]);
  73        } else {
  74          _srecordf (str, "%s - %s + 1", idf->upb[idf->mode.dim], idf->lwb[idf->mode.dim]);
  75        }
  76        fold_int_4 (buf, str);
  77        idf->len[idf->mode.dim++] = stralloc (buf);
  78      }
  79    }
  80    if (TOKEN (",")) {
  81      if (dim < MAX_DIMS) {
  82        get_dims (idf, dim + 1);
  83      } else {
  84        ERROR (1001, "too many dimensions", NULL);
  85      }
  86    }
  87    (void) rc;
  88  }
  89  
  90  void dimension (void)
  91  {
  92    int_4 rc = scan (NULL);
  93    while (rc != END_OF_LINE) {
  94      MODE mode;
  95      if (rc == WORD) {
  96        IDENT *idf = void_decl (curlex, &mode);
  97        rc = scan ("(");
  98        if (idf != NULL) {
  99          if (idf->mode.dim != 0) {
 100            ERROR (1002, "already dimensioned", CID (idf));
 101          }
 102          get_dims (idf, 1);
 103          CHECKPOINT (1003, ")");
 104          rc = scan (NULL);
 105        }
 106      }
 107      if (TOKEN (",")) {
 108        rc = scan (NULL);
 109        if (! WITHIN) {
 110          SYNTAX (1004, NULL);
 111        }
 112      } else {
 113        if (rc != END_OF_LINE) {
 114          SYNTAX (1005, NULL);
 115          rc = scan (NULL);
 116        }
 117      }
 118    }
 119  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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