Algol 68 Genie

data.c

     
   1  //! @file data.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 DATA statements.
  25  
  26  #include <vif.h>
  27  
  28  //
  29  // DATA STATEMENT
  30  //
  31  
  32  void const_list (MODE * mode, int_4 *items)
  33  {
  34    while (WITHIN) {
  35      int_4 rc = scan (NULL);
  36      if (!WITHIN) {
  37        ;
  38      } else {
  39        int_8 repeat = 1;
  40        if (curret == INT_NUMBER) {
  41          repeat = strtoll (curlex, NULL, 10);
  42          rc = scan (NULL);
  43          if (TOKEN ("*")) {
  44            rc = scan (NULL);
  45          } else {
  46            repeat = 1;
  47            UNSCAN;
  48          }
  49        }
  50        EXPR reg;
  51        factor (&reg);
  52        if (reg.variant != EXPR_CONST) {
  53          EXPECT (701, "constant");
  54        } else if (!accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
  55          MODE_ERROR (702, qtype (&(reg.mode)), qtype (mode));
  56        }
  57        for (int_4 k = 0; k < repeat; k++) {
  58          if (reg.mode.type == CHARACTER && mode->type == INTEGER) {
  59            RECORD str, buf;
  60            _srecordf (str, "%d", _int4 (get_uniq_str (reg.str, buf)));
  61            code (nprocs, DATA, str);
  62          } else {
  63            code (nprocs, DATA, reg.str);
  64          }
  65          if (k < repeat - 1) {
  66            code (nprocs, DATA, ",\n");
  67          }
  68        }
  69        (*items) += (int_4) repeat;
  70        rc = scan (NULL);
  71        if (TOKEN ("/")) {
  72          return;
  73        } else if (TOKEN (",")) {
  74          code (nprocs, DATA, ",\n");
  75        }
  76      }
  77      (void) rc;
  78    }
  79  }
  80  
  81  void data_elem (char *data, char *datk, char *datn, MODE * mode, int_4 *items)
  82  {
  83  #define CIRCULAR\
  84    {\
  85      _srecordf (str, "if (%s >= %s) {\n", datk, datn);\
  86      code (nprocs, BODY, str);\
  87      _srecordf (str, "%s = 0;\n", datk);\
  88      code (nprocs, BODY, str);\
  89      code (nprocs, BODY, "}\n");\
  90    }
  91  //
  92    EXPR reg;
  93    factor (&reg);
  94    if (reg.idf != NULL && reg.idf->mode.save == AUTOMATIC) {
  95      ERROR (703, "variable is automatic", CID (reg.idf));
  96    }
  97    if (reg.variant == EXPR_VAR && reg.mode.dim == 0) {
  98      RECORD str;
  99      *mode = reg.idf->mode;
 100      CIRCULAR;
 101      if (mode->type == CHARACTER) {
 102        if (mode->len == 0) {
 103          _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
 104        } else {
 105          _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
 106        }
 107      } else {
 108        _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
 109      }
 110      code (nprocs, BODY, str);
 111      (*items)++;
 112    } else if (reg.variant == EXPR_SLICE) {
 113      RECORD str;
 114      *mode = reg.idf->mode;
 115      CIRCULAR;
 116      if (mode->type == CHARACTER) {
 117        if (mode->len == 0) {
 118          _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
 119        } else {
 120          _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
 121        }
 122      } else {
 123        _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
 124      }
 125      code (nprocs, BODY, str);
 126      (*items)++;
 127    } else if (reg.variant == EXPR_VAR && reg.mode.dim > 0) {
 128      RECORD str, tmpa, tmpk;
 129      IDENT *ptr;
 130      *mode = reg.idf->mode;
 131      mode->dim = 0;
 132      _srecordf (tmpa, "_arr_%d", nloctmps++);
 133      ptr = add_local (tmpa, mode->type, mode->len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 134      ptr->alias = reg.idf;
 135      _srecordf (tmpk, "_k_%d", nloctmps++);
 136      add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 137      _srecordf (str, "for (%s = (%s *) %s, %s = 0; %s < ", tmpa, wtype (mode, NOARG, NOFUN), reg.str, tmpk, tmpk);
 138      code (nprocs, BODY, str);
 139      code_arrlen (reg.idf);
 140      _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
 141      code (nprocs, BODY, str);
 142      CIRCULAR;
 143      if (mode->type == CHARACTER) {
 144        if (mode->len == 0) {
 145          _srecordf (str, "strcpy (*(%s), %s[%s++]);\n", tmpa, data, datk);
 146        } else {
 147          _srecordf (str, "bufcpy (*(%s), %s[%s++], %d);\n", tmpa, data, datk, mode->len);
 148        }
 149      } else {
 150        _srecordf (str, "%s[%s] = %s[%s++];\n", reg.str, tmpk, data, datk);
 151      }
 152      code (nprocs, BODY, str);
 153      code (nprocs, BODY, "}\n");
 154      (*mode) = reg.idf->mode;
 155      (*items)++;
 156    } else {
 157      ERROR (704, "cannot initialise", reg.str);
 158    }
 159  #undef CIRCULAR
 160  }
 161  
 162  void data_list (char *data, char *datk, char *datn, MODE * mode, int_4 lpatch, int_4 *nest, int_4 *items)
 163  {
 164    while (WITHIN) {
 165      int_4 rc = scan (NULL);
 166      if (!WITHIN) {
 167        ;
 168      } else if (TOKEN ("/")) {
 169        return;
 170      } else if (TOKEN (",")) {
 171        if (*nest == 0) {
 172          code (nprocs, DATA, "\n");
 173        }
 174      } else if (TOKEN ("(")) {
 175        SAVE_PRE;
 176  // Quick lookahead.
 177        int_4 loop = impl_do ();
 178  // Restore.
 179        RESTORE_POS;
 180        rc = scan ("(");
 181  // Decide.
 182        if (loop) {
 183          (*nest)++;
 184          int_4 where = code (nprocs, BODY, NULL);
 185          data_list (data, datk, datn, mode, where, nest, items);
 186        } else {
 187          data_elem (data, datk, datn, mode, items);
 188        }
 189      } else if (TOKEN (")")) {
 190  // Expression closed by ')'
 191        (*nest)--;
 192        return;
 193      } else if (rc == WORD) {
 194        if (*nest == 0) {
 195          data_elem (data, datk, datn, mode, items);
 196        } else {
 197  // Implied do-loop?
 198          SAVE_PRE;
 199          rc = scan (NULL);
 200          if (!TOKEN ("=")) {
 201  // Not an implied do-loop.
 202            RESTORE_POS;
 203            rc = scan (NULL);
 204            data_elem (data, datk, datn, mode, items);
 205          } else {
 206  // Implied do-loop!
 207            RECORD lid, loop;
 208            EXPR from, to, by;
 209            MODE nmode;
 210            IDENT *idf = impl_decl (prelex, &nmode);
 211            if (idf->arg || idf->alias != NULL) {
 212              _srecordf (lid, "*%s", CID (idf));
 213            } else if (idf->common == EXTERN) {
 214              _srecordf (lid, "%s->%s", commons[idf->common], CID (idf));
 215            } else if (idf->common > 0) {
 216              _srecordf (lid, "%s.%s", commons[idf->common], CID (idf));
 217            } else {
 218              _srecordf (lid, "%s", CID (idf));
 219            }
 220            rc = scan (NULL);
 221            express (&from, idf->mode.type, idf->mode.len);
 222            rc = scan (",");
 223            rc = scan (NULL);
 224            express (&to, idf->mode.type, idf->mode.len);
 225            rc = scan (NULL);
 226            if (TOKEN (",")) {
 227              rc = scan (NULL);
 228              express (&by, idf->mode.type, idf->mode.len);
 229              _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", lid, from.str, lid, to.str, lid, by.str);
 230              rc = scan (NULL);
 231            } else {
 232              _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", lid, from.str, lid, to.str, lid);
 233            }
 234            patch (lpatch, loop);
 235            if (TOKEN (")")) {
 236  // Implied DO loop closed by ')'.
 237              (*nest)--;
 238              code (nprocs, BODY, "}; // implied DO \n");
 239            } else {
 240              EXPECT (705, ")");
 241            }
 242            return;
 243          }
 244        }
 245      } else {
 246        data_elem (data, datk, datn, mode, items);
 247      }
 248    }
 249  }
 250  
 251  void do_data (int_4 *nest)
 252  {
 253    int_4 rc, go_on = TRUE;
 254    RECORD str;
 255    _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
 256    code (nprocs, BODY, str);
 257    while (go_on) {
 258      int_4 items = 0, dpatch;
 259      RECORD data, datk, datn;
 260      MODE mode;
 261      _srecordf (data, "_data_l_%d", nglobtmps);
 262      _srecordf (datk, "_data_k_%d", nglobtmps);
 263      _srecordf (datn, "_data_n_%d", nglobtmps++);
 264      add_local (datk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 265      _srecordf (str, "%s = 0;\n", datk);
 266      code (nprocs, BODY, str);
 267      data_list (data, datk, datn, &mode, ERR, nest, &items);
 268      if (!TOKEN ("/")) {
 269        EXPECT (706, "/");
 270      }
 271      mode.dim = 0;
 272      code (nprocs, DATA, "\n");
 273      cpp_direct (nprocs, curlin, DATA);
 274      _srecordf (str, "#define %s ", datn);
 275      code (nprocs, DATA, str);
 276      dpatch = code (nprocs, DATA, NULL);
 277      code (nprocs, DATA, "\n");
 278      _srecordf (str, "static %s %s[%s] = {\n", wtype (&mode, NOARG, NOFUN), data, datn);
 279      code (nprocs, DATA, str);
 280      items = 0;
 281      const_list (&mode, &items);
 282      _srecordf (str, "%d", items);
 283      patch (dpatch, str);
 284      code (nprocs, DATA, "\n");
 285      code (nprocs, DATA, "};\n");
 286      if (!TOKEN ("/")) {
 287        EXPECT (707, "/");
 288      }
 289      rc = scan (NULL);
 290      go_on = TOKEN (",");
 291    }
 292    code (nprocs, BODY, "}\n");
 293    if (WITHIN) {
 294      SYNTAX (708, curlex);
 295    }
 296    (void) rc;
 297  }
 298  
 299  void decl_data (void)
 300  {
 301    int_4 go_on = TRUE;
 302    while (go_on) {
 303      SAVE_POS;
 304      int_4 rc = scan (NULL);
 305      if (rc == DECLAR) {
 306        skip_card ();
 307      } else if (TOKEN ("implicit")) {
 308        skip_card ();
 309      } else if (TOKEN ("save")) {
 310        skip_card ();
 311      } else if (TOKEN ("automatic")) {
 312        skip_card ();
 313      } else if (TOKEN ("parameter")) {
 314        skip_card ();
 315      } else if (TOKEN ("common")) {
 316        skip_card ();
 317      } else if (TOKEN ("dimension")) {
 318        skip_card ();
 319      } else if (TOKEN ("equivalence")) {
 320        skip_card ();
 321      } else if (TOKEN ("external")) {
 322        skip_card ();
 323      } else if (TOKEN ("intrinsic")) {
 324        skip_card ();
 325      } else if (TOKEN ("data")) {
 326        int_4 nest = 0;
 327        do_data (&nest);
 328        skip_card ();
 329      } else if (strlen (curlex) > 0) {
 330  // Backspace and done.
 331        RESTORE_POS;
 332        go_on = FALSE;
 333      }
 334    }
 335  }
 336
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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