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-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  //! 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, '.') != NO_TEXT) {
    34      return NO_IDENT;
    35    }
    36    if (strstr (name, "->") != NO_TEXT) {
    37      return NO_IDENT;
    38    }
    39    if (strchr (name, '*') != NO_TEXT) {
    40      return NO_IDENT;
    41    }
    42    if (!IS_VAR (name)) {
    43      ERROR (2201, "not a variable name", curlex);
    44      return NO_IDENT;
    45    }
    46  // Apparently a normal local variable.
    47    IDENT *idf = find_local (name, mode);
    48    if (idf != NO_IDENT) {
    49      if (idf->mode.type == NOTYPE) {
    50        impl_type (name, &idf->mode);
    51      }
    52    } else {
    53      if (nlocals >= MAX_IDENTS) {
    54        FATAL (2202, "too many identifiers", NO_TEXT);
    55        return NO_IDENT;
    56      }
    57      idf = &locals[nlocals++];
    58      memset (idf, 0, sizeof (IDENT));
    59      idf->line = curlin;
    60      C_NAME (idf) = c_name (name);
    61      FTN_NAME (idf) = f_stralloc (name);
    62      idf->external = FALSE;
    63      impl_type (name, &idf->mode);
    64      if (mode != NO_MODE) {
    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 (C_NAME (idf), &(idf->mode));
    80        idf->mode.dim = dim;
    81      }
    82    }
    83  }
    84  
    85  void implicit (void)
    86  {
    87    int_4 k, rc, set = 0, nest = 0;
    88    NEW_RECORD (mode);
    89    while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
    90      if (TOKEN ("none")) {
    91        for (k = ord ('a'); k <= ord ('z'); k++) {
    92          f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
    93          set++;
    94        }
    95      } else if (rc == DECLAR) {
    96        RECCPY (mode, curlex);
    97      } else if (TOKEN ("automatic")) {
    98        RECCPY (mode, curlex);
    99      } else if (TOKEN ("save")) {
   100        RECCPY (mode, curlex);
   101      } else if (TOKEN ("undefined")) {
   102        RECCPY (mode, curlex);
   103      } else if (TOKEN ("(") && strlen (mode) > 0) {
   104        NEW_RECORD (a);
   105        NEW_RECORD (z);
   106        nest++;
   107        do {
   108          rc = scan (EXPECT_NONE);
   109          if (rc != WORD || strlen (curlex) > 1) {
   110            EXPECT (2203, "a-z");
   111            return;
   112          }
   113          RECCPY (a, curlex);
   114          rc = scan (EXPECT_NONE);
   115          if (TOKEN ("-")) {
   116            rc = scan (EXPECT_NONE);
   117            if (rc != WORD || strlen (curlex) > 1) {
   118              EXPECT (2204, "character range");
   119              return;
   120            }
   121            RECCPY (z, curlex);
   122            for (k = ord (a[0]); k <= ord (z[0]); k++) {
   123              if (EQUAL (mode, "automatic")) {
   124                implic[k].mode.save = AUTOMATIC;
   125              } else if (EQUAL (mode, "save")) {
   126                implic[k].mode.save = STATIC;
   127              } else if (EQUAL (mode, "undefined")) {
   128                f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
   129              } else {
   130                f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
   131              }
   132            }
   133            set++;
   134          } else {
   135            UNSCAN;
   136            k = ord (a[0]);
   137            if (EQUAL (mode, "automatic")) {
   138              implic[k].mode.save = AUTOMATIC;
   139            } else if (EQUAL (mode, "save")) {
   140              implic[k].mode.save = STATIC;
   141            } else if (EQUAL (mode, "undefined")) {
   142              f2c_type ("none", &(implic[k].mode), NOARG, NOFUN);
   143            } else {
   144              f2c_type (mode, &(implic[k].mode), NOARG, NOFUN);
   145            }
   146            set++;
   147          }
   148          rc = scan (EXPECT_NONE);
   149        } while (TOKEN (","));
   150        if (TOKEN (")")) {
   151          UNSCAN;
   152        }
   153      } else if (TOKEN (")")) {
   154        nest--;
   155      } else if (TOKEN (",")) {
   156        continue;
   157      } else {
   158        SYNTAX (2205, "implicit statement");
   159      }
   160    }
   161    if (set == 0) {
   162      SYNTAX (2206, "implicit statement");
   163    }
   164    if (nest != 0) {
   165      SYNTAX (2207, "parenthesis nesting");
   166    }
   167  }
   168  
   169  void get_impl (void)
   170  {
   171    int_4 go_on = TRUE;
   172    default_impl ();
   173    while (go_on) {
   174      SAVE_POS (1);
   175      int_4 rc = scan (EXPECT_NONE);
   176      if (rc == DECLAR) {
   177        skip_card (FALSE);
   178      } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
   179        implicit ();
   180        skip_card (FALSE);
   181      } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
   182        skip_card (FALSE);
   183      } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
   184        skip_card (FALSE);
   185      } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
   186        skip_card (FALSE);
   187      } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
   188        skip_card (FALSE);
   189      } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
   190        skip_card (FALSE);
   191      } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
   192        skip_card (FALSE);
   193      } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
   194        skip_card (FALSE);
   195      } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
   196        skip_card (FALSE);
   197      } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
   198        skip_card (FALSE);
   199      } else if (rc == WORD && IS_MACRO_DECLARATION) {
   200        skip_card (FALSE);
   201      } else if (strlen (curlex) > 0) {
   202  // Backspace and done.
   203        RESTORE_POS (1);
   204        go_on = FALSE;
   205      }
   206    }
   207  }


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)