Algol 68 Genie

slice.c

     
   1  //! @file slice.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 array slices.
  25  
  26  #include <vif.h>
  27  
  28  void code_index (RECORD index, IDENT * idf, int_4 dim)
  29  {
  30    RECORD str;
  31    EXPR reg;
  32    express (&reg, INTEGER, 4);
  33    if (EQUAL (idf->lwb[dim], "0")) {
  34      if (dim == 0) {
  35        _srecordf (str, "%s", reg.str);
  36      } else {
  37        _srecordf (str, "(%s)", reg.str);
  38      }
  39    } else {
  40      RECORD buf;
  41      _srecordf (str, "%s - %s", reg.str, idf->lwb[dim]);
  42      fold_int_4 (buf, str);
  43      if (dim == 0) {
  44        _srecordf (str, "%s", buf);
  45      } else {
  46        _srecordf (str, "(%s)", buf);
  47      }
  48    }
  49    (void) scan (EXPECT_NONE);
  50    if (TOKEN (":")) {
  51      SYNTAX (2701, "range not allowed");
  52    } else if (TOKEN (",")) {
  53      RECORD deep;
  54      RECCLR (deep);
  55      (void) scan (EXPECT_NONE);
  56      code_index (deep, idf, dim + 1);
  57      if (strcmp (idf->len[dim], "VARY") == 0) {
  58        ERROR (2702, "dimension cannot vary", NO_TEXT);
  59      }
  60      RECORD prod, fact;
  61      _srecordf (prod, "(%s) * (%s)", idf->len[dim], deep);
  62      fold_int_4 (fact, prod);
  63      if (strcmp (fact, "0") == 0) {
  64        _srecordf (index, "%s", str);
  65      } else {
  66        _srecordf (index, "%s + %s", str, fact);
  67      }
  68    } else if (TOKEN (")")) {
  69      bufcpy (index, str, RECLN);
  70      return;
  71    }
  72  }
  73  
  74  void code_store_index (EXPR *loc, RECORD index, IDENT * idf, int_4 dim)
  75  {
  76    RECCLR (index);
  77    code_index (index, idf, 0);
  78  // Sanity check.
  79    int_4 value;
  80    if (isint_4 (index, &value) && value < 0) {
  81      ERROR (2703, "index out of range", FTN_NAME (idf));
  82    }
  83  // FORTRAN code, like m[(i + W1 * (j * W2 * k)]
  84    fold_int_4 (loc->elem, index);
  85  }
  86  
  87  void factor_slice_char (EXPR *loc, IDENT *idf)
  88  {
  89    RECORD ldf, index;
  90    RECCLR (index);
  91  // Code identifier name.
  92    (void) idf_full_c_name (ldf, idf);
  93  // 
  94    if (IS_ROW (idf->mode)) { 
  95  // Assume idf(i1, .., iN) possibly followed by (lwb : upb)
  96      (void) scan (EXPECT_NONE);
  97      code_store_index (loc, index, idf, 0);
  98      _srecordf (ldf, "%s[%s]", ldf, index);
  99      (void) scan (EXPECT_NONE); // Skip ")"
 100      if (!TOKEN ("(")) {
 101  // idf(i1, ..., iN), no substring.
 102        UNSCAN;
 103        bufcpy (loc->str, ldf, RECLN);
 104        loc->variant = EXPR_SLICE;
 105        loc->idf = idf;
 106        loc->mode = idf->mode;
 107        return;
 108      }
 109    }
 110  // The trimmer (lwb : upb)
 111    EXPR ini, fin;
 112    int_4 denot = (IS_SCALAR (idf->mode));
 113    (void) scan (EXPECT_NONE);
 114    if (TOKEN (":")) {
 115      _srecordf (ini.str, "1");
 116      ini.mode.type = INTEGER;
 117      ini.mode.len = 4;
 118      ini.variant = EXPR_CONST;
 119    } else {
 120      express (&ini, INTEGER, 4);
 121      denot &= (ini.variant == EXPR_CONST);
 122      (void) scan (EXPECT_NONE);
 123    }
 124    CHECKPOINT (2704, ":");
 125  // ldf(lwb : upb)
 126    (void) scan (EXPECT_NONE);
 127    if (TOKEN (")")) {
 128      UNSCAN;
 129      _srecordf (fin.str, "%d", idf->mode.len);
 130      fin.mode.type = INTEGER;
 131      fin.mode.len = 4;
 132      fin.variant = EXPR_CONST;
 133    } else {
 134      express (&fin, INTEGER, 4);
 135      denot &= (fin.variant == EXPR_CONST);
 136    }
 137    if (lhs_factor) { // A permanent stub ...
 138      bufcat (ini.str, " - 1", RECLN);
 139      (void) fold_expr (&ini, INTEGER);
 140      _srecordf (loc->str, "(char *) &(%s[%s])", ldf, ini.str);
 141      loc->variant = EXPR_SUBSTR;
 142      loc->idf = idf;
 143      loc->mode = idf->mode;
 144    } else {
 145  // Optimize substring with all constant parameters.
 146      denot &= (idf->parm != NO_TEXT);
 147      if (denot) {
 148        RECORD cdf, sub, tmp;
 149        get_uniq_str (idf->parm, cdf);
 150        _srecordf (sub, "\"%s\"", _bufsub (tmp, cdf, atoi (ini.str), atoi (fin.str)));
 151        _srecordf (cdf, "_dc_%d", code_uniq_str (sub));
 152        _srecordf (loc->str, "%s", cdf);
 153        loc->mode = (MODE) {.type = CHARACTER, .len = strlen (sub) - 2, .dim = 0};
 154        loc->variant = EXPR_CONST;
 155      } else {
 156  // General form of substring.
 157        RECORD tmp;
 158        _srecordf (tmp, "%s", edit_tmp (nloctmps++));
 159        if (idf->mode.len > 0) {
 160          add_local (tmp, idf->mode.type, idf->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 161        } else { // Should not copy into zero-length string.
 162          add_local (tmp, idf->mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 163        }
 164  // _bufsub returns buffer address, so no gcc statement expression needed.
 165        _srecordf (loc->str, "_bufsub ((char *) %s, (char *) %s, %s, %s)", tmp, ldf, ini.str, fin.str);
 166        loc->variant = EXPR_SUBSTR;
 167        loc->idf = idf;
 168        loc->mode = idf->mode;
 169      }
 170    }
 171    (void) scan (")");
 172  }
 173  
 174  void factor_slice (EXPR *loc, IDENT *idf)
 175  {
 176    RECORD index;
 177    RECCLR (index);
 178    (void) idf_full_c_name (loc->str, idf);
 179    (void) scan (EXPECT_NONE);
 180    code_store_index (loc, index, idf, 0);
 181    bufcat (loc->str, "[", RECLN);
 182    bufcat (loc->str, loc->elem, RECLN);
 183    bufcat (loc->str, "]", RECLN);
 184    loc->variant = EXPR_SLICE;
 185    loc->idf = idf;
 186    loc->mode = idf->mode;
 187  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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