Algol 68 Genie

fpp.c

     
   1  //! @file fpp.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  //! Fortran preprocessor.
  25  
  26  #include <vif.h>
  27  
  28  void fpp (char *, char *, int_4 nest);
  29  
  30  int_4 register_file(char *name)
  31  {
  32    for (int_4 k = 1; k <= nfiles; k++) {
  33      if (strcmp (files[k].text, name) == 0) {
  34         return k;
  35      }
  36    }
  37    nfiles++;
  38    if (nfiles >= MAX_SOURCE_FILES) {
  39      FATAL (1701, "too many source files", NO_TEXT);
  40    }
  41    files[nfiles].num = nfiles;
  42    files[nfiles].text = f_stralloc (name);
  43    return nfiles;
  44  }
  45  
  46  void get_source (char *name, int_4 nest)
  47  {
  48    FILE *in;
  49    char *ext;
  50    int_4 lines = 1, nisn = 0, actfile, cntrls = 0;
  51    if (nest > MAX_NEST) {
  52      FATAL (1702, "include nesting too deep", name);
  53    }
  54    if (strlen (name) < 3) {
  55      FATAL (1703, "source file name", name);
  56    }
  57    ext = &name[strlen (name) - 2];
  58    if (EQUAL (ext, ".f") || EQUAL (ext, ".F")) {
  59      ;// Ok
  60    } else if (EQUAL (ext, ".ftn") || EQUAL (ext, ".FTN")) {
  61      ;// Ok
  62    } else if (EQUAL (ext, ".h") || EQUAL (ext, ".H")) {
  63      ;// Ok
  64    } else {
  65      FATAL (1704, "source file format", name);
  66    }
  67    if ((in = fopen (name, "r")) == NO_FILE) {
  68      FATAL (1705, "cannot read", name);
  69    };
  70    RECORD path;
  71    _srecordf (path, "%s", dirname (name));
  72    actfile = register_file(name);
  73    while (!feof (in)) {
  74      RECORD fetch;
  75      RECCLR (fetch);
  76      if (fgets (fetch, RECLN, in) != NO_TEXT) {
  77        int_4 len = strlen (fetch);
  78        if (len > 0) {
  79          for (int k = 0; k < len; k++) {
  80            if (fetch[k] == EOF || fetch[k] == '\0' || fetch[k] == '\n') {
  81              ;
  82            } else if (fetch[k] == '\r' && fetch[k + 1] == '\n') {
  83  // Assume ms-dos that has \r\n line ends.
  84              fetch[k] = '\n';
  85              fetch[k + 1] = '\0';
  86              len--;
  87            } else {
  88              if (!isprint (fetch[k])) {
  89                cntrls++;
  90                fetch[k] = '?';
  91              }
  92            }
  93          }
  94          if (fetch[0] == '#') {
  95            int_4 savfile = actfile;
  96            fpp (fetch, path, nest);
  97            actfile = savfile;
  98            lines++;
  99          } else {
 100            if (fetch[len - 1] == '\n') {
 101              fetch[--len] = '\0';
 102            }
 103            if (nftnlines == MAX_FTN_LINES - 1) { // One less - always terminating NULL line.
 104              MAX_FTN_LINES += INCREMENT;
 105              source = (FTN_LINE *) f_realloc (source, MAX_FTN_LINES * sizeof (FTN_LINE));
 106              memset (&source[nftnlines], 0, INCREMENT * sizeof (FTN_LINE));
 107            }
 108            source[nftnlines].file = &files[actfile];
 109            source[nftnlines].num = lines;
 110            source[nftnlines].len = len;
 111            source[nftnlines].jcl = FALSE;
 112            source[nftnlines].text = f_stralloc (fetch);
 113            if (fetch[0] == '\0' || IS_COMMENT (fetch[0])) {
 114              source[nftnlines].isn = 0;
 115            } else if (nisn > 0 && fetch[5] != ' ') {
 116              source[nftnlines].isn = nisn;
 117            } else {
 118              source[nftnlines].isn = ++nisn;
 119            }
 120            lines++;
 121            nftnlines++;
 122          }
 123        }
 124      }
 125    }
 126    files[nfiles].len = lines - 1;
 127    fclose (in);
 128    if (cntrls > 0) {
 129      WARNING (1706, "source has unrecognized characters", NO_TEXT);
 130    }
 131  }
 132  
 133  void fpp (char *cmd, char *path, int_4 nest)
 134  {
 135    if (cmd[0] == '#') {
 136      cmd++;
 137    }
 138    while (cmd[0] == ' ') {
 139      cmd++;
 140    }
 141    if (LEQUAL ("echo", cmd)) {
 142      cmd = &cmd[strlen ("echo")];
 143      while (cmd[0] == ' ') {
 144        cmd++;
 145      }
 146      int_4 N = strlen (cmd);
 147      if (N > 0 && cmd[N - 1] == '\n') {
 148        cmd[N - 1] = '\0';
 149      }
 150      ECHO (1707, cmd, NO_TEXT);
 151    } else if (LEQUAL ("pragma", cmd)) {
 152      cmd = &cmd[strlen ("pragma")];
 153      while (cmd[0] == ' ') {
 154        cmd++;
 155      }
 156      int_4 N = strlen (cmd);
 157      if (N > 0 && cmd[N - 1] == '\n') {
 158        cmd[N - 1] = '\0';
 159      }
 160      option (cmd);
 161    } else if (LEQUAL ("include", cmd)) {
 162      RECORD fn;
 163      (void) strtok (cmd, "'");
 164      char *str = strtok (NO_TEXT, "'");
 165      if (str != NO_TEXT) {
 166        _srecordf (fn, "%s/%s", path, str);
 167        get_source (fn, nest + 1);
 168      } else {
 169        FATAL (1708, "filename required", cmd);
 170      }
 171    } else {
 172      FATAL (1709, "preprocessor directive", cmd);
 173    }
 174  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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