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-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  //! 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", NULL);
  40    }
  41    files[nfiles].num = nfiles;
  42    files[nfiles].text = 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;
  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")) == NULL) {
  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) != NULL) {
  77        int_4 len = strlen (fetch);
  78        if (len > 1) {
  79          if (fetch[0] == '#') {
  80            int_4 savfile = actfile;
  81            fpp (fetch, path, nest);
  82            actfile = savfile;
  83            lines++;
  84          } else {
  85            if (fetch[len - 1] == '\n') {
  86              fetch[len - 1] = '\0';
  87            }
  88            if (nftnlines == MAX_FTN_LINES) {
  89              MAX_FTN_LINES += INCREMENT;
  90              source = (FTN_LINE *) f_realloc (source, MAX_FTN_LINES * sizeof (FTN_LINE));
  91            }
  92            source[nftnlines].file = &files[actfile];
  93            source[nftnlines].num = lines;
  94            source[nftnlines].len = len;
  95            source[nftnlines].inc = nest;
  96            source[nftnlines].text = stralloc (fetch);
  97            if (fetch[0] == '\0' || IS_COMMENT (fetch[0])) {
  98              source[nftnlines].isn = 0;
  99            } else if (nisn > 0 && fetch[5] != ' ') {
 100              source[nftnlines].isn = nisn;
 101            } else {
 102              source[nftnlines].isn = ++nisn;
 103            }
 104            lines++;
 105            nftnlines++;
 106          }
 107        }
 108      }
 109    }
 110    files[nfiles].len = lines - 1;
 111    fclose (in);
 112  }
 113  
 114  void fpp (char *cmd, char *path, int_4 nest)
 115  {
 116    if (cmd[0] == '#') {
 117      cmd++;
 118    }
 119    while (cmd[0] == ' ') {
 120      cmd++;
 121    }
 122    if (LEQUAL ("echo", cmd)) {
 123      cmd = &cmd[strlen ("echo")];
 124      while (cmd[0] == ' ') {
 125        cmd++;
 126      }
 127      int_4 N = strlen (cmd);
 128      if (N > 0 && cmd[N - 1] == '\n') {
 129        cmd[N - 1] = '\0';
 130      }
 131      ECHO (1706, cmd, NULL);
 132    } else if (LEQUAL ("pragma", cmd)) {
 133      cmd = &cmd[strlen ("pragma")];
 134      while (cmd[0] == ' ') {
 135        cmd++;
 136      }
 137      int_4 N = strlen (cmd);
 138      if (N > 0 && cmd[N - 1] == '\n') {
 139        cmd[N - 1] = '\0';
 140      }
 141      option (cmd);
 142    } else if (LEQUAL ("include", cmd)) {
 143      RECORD fn;
 144      (void) strtok (cmd, "'");
 145      char *str = strtok (NULL, "'");
 146      if (str != NULL) {
 147        _srecordf (fn, "%s/%s", path, str);
 148        get_source (fn, nest + 1);
 149      } else {
 150        FATAL (1707, "filename required", cmd);
 151      }
 152    } else {
 153      FATAL (1708, "preprocessor directive", cmd);
 154    }
 155  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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