Algol 68 Genie

implicit.c

     
   1  //! @file implicit.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  //! Implicit declaration routines.
  25  
  26  #include <vif.h>
  27  
  28  IDENT *impl_decl (char *name, MODE * mode)
  29  {
  30  // This routine is called with a subexpression as 'name'.
  31  //
  32  // Filter commons, arguments and equivalences.
  33    if (strchr (name, '.') != NULL) {
  34      return NULL;
  35    }
  36    if (strstr (name, "->") != NULL) {
  37      return NULL;
  38    }
  39    if (strchr (name, '*') != NULL) {
  40      return NULL;
  41    }
  42    if (!IS_VAR (name)) {
  43      ERROR (1901, "not a variable name", curlex);
  44      return NULL;
  45    }
  46  // Apparently a normal local variable.
  47    IDENT *idf = find_local (name, mode);
  48    if (idf != NULL) {
  49      if (idf->mode.type == NOTYPE) {
  50        impl_type (name, &idf->mode);
  51      }
  52    } else {
  53      if (nlocals >= MAX_IDENTS) {
  54        FATAL (1902, "too many identifiers", NULL);
  55        return NULL;
  56      }
  57      idf = &locals[nlocals++];
  58      memset (idf, 0, sizeof (IDENT));
  59      idf->line = curlin;
  60      CID (idf) = c_name (name);
  61      FID (idf) = stralloc (name);
  62      idf->external = FALSE;
  63      impl_type (name, &idf->mode);
  64      if (mode != NULL) {
  65        *mode = idf->mode;
  66      }
  67    }
  68    return idf;
  69  }
  70  
  71  void idfs_impl (void)
  72  {
  73  // Implicit-type remaining stuff
  74    int_4 k;
  75    for (k = 0; k < nlocals; k++) {
  76      IDENT *idf = &locals[k];
  77      if (idf->mode.type == NOTYPE && !idf->external) {
  78        int_4 dim = idf->mode.dim;
  79        impl_type (CID (idf), &(idf->mode));
  80        idf->mode.dim = dim;
  81      }
  82    }
  83  }
  84  
  85  void implicit (void)
  86  {
  87    int_4 k, rc, nest = 0;
  88    RECORD mode;
  89    RECCLR (mode);
  90    while ((rc = scan (NULL)) != END_OF_LINE) {
  91      if (TOKEN ("none")) {
  92        for (k = ord ('a'); k <= ord ('z'); k++) {
  93          f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
  94        }
  95      } else if (rc == DECLAR) {
  96        strcpy (mode, curlex);
  97      } else if (TOKEN ("automatic")) {
  98        strcpy (mode, curlex);
  99      } else if (TOKEN ("(")) {
 100        RECORD a, z;
 101        nest++;
 102        do {
 103          rc = scan (NULL);
 104          if (rc != WORD || strlen (curlex) > 1) {
 105            EXPECT (1903, "a-z");
 106            return;
 107          }
 108          strcpy (a, curlex);
 109          rc = scan (NULL);
 110          if (TOKEN ("-")) {
 111            rc = scan (NULL);
 112            if (rc != WORD || strlen (curlex) > 1) {
 113              EXPECT (1904, "a-z");
 114              return;
 115            }
 116            strcpy (z, curlex);
 117            for (k = ord (a[0]); k <= ord (z[0]); k++) {
 118              if (EQUAL (mode, "automatic")) {
 119                implic[k].mode.save = AUTOMATIC;
 120              } else {
 121                f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
 122              }
 123            }
 124          } else {
 125            UNSCAN;
 126            k = ord (a[0]);
 127            if (EQUAL (mode, "automatic")) {
 128              implic[k].mode.save = AUTOMATIC;
 129            } else {
 130              f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
 131            }
 132          }
 133          rc = scan (NULL);
 134        } while (TOKEN (","));
 135        if (TOKEN (")")) {
 136          UNSCAN;
 137        }
 138      } else if (TOKEN (")")) {
 139        nest--;
 140      } else if (TOKEN (",")) {
 141        continue;
 142      }
 143    }
 144    if (nest != 0) {
 145      SYNTAX (1905, "parenthesis nesting");
 146    }
 147  }
 148  
 149  void get_impl (void)
 150  {
 151    int_4 go_on = TRUE;
 152    default_impl ();
 153    while (go_on) {
 154      SAVE_POS;
 155      int_4 rc = scan (NULL);
 156      if (rc == DECLAR) {
 157        skip_card ();
 158      } else if (TOKEN ("implicit")) {
 159        implicit ();
 160        skip_card ();
 161      } else if (TOKEN ("save")) {
 162        skip_card ();
 163      } else if (TOKEN ("automatic")) {
 164        skip_card ();
 165      } else if (TOKEN ("parameter")) {
 166        skip_card ();
 167      } else if (TOKEN ("common")) {
 168        skip_card ();
 169      } else if (TOKEN ("dimension")) {
 170        skip_card ();
 171      } else if (TOKEN ("equivalence")) {
 172        skip_card ();
 173      } else if (TOKEN ("external")) {
 174        skip_card ();
 175      } else if (TOKEN ("intrinsic")) {
 176        skip_card ();
 177      } else if (TOKEN ("data")) {
 178        skip_card ();
 179      } else if (strlen (curlex) > 0) {
 180  // Backspace and done.
 181        RESTORE_POS;
 182        go_on = FALSE;
 183      }
 184    }
 185  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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