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

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