Algol 68 Genie

decls.c

     
   1  //! @file decls.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  //! Compile declarations.
  25  
  26  #include <vif.h>
  27  
  28  void idfs_reset (void)
  29  {
  30  // Before explicit declarations reset implicit ones.
  31  // Then do explicit declarations, followed by implicit ones.
  32    int_4 k;
  33    for (k = 0; k < nlocals; k++) {
  34      IDENT *idf = &locals[k];
  35      if (idf->parm == NO_TEXT && !idf->mode.fun) {
  36        idf->mode.type = NOTYPE;
  37      }
  38    }
  39  }
  40  
  41  void idfs_unused (void)
  42  {
  43  // Before explicit declarations reset implicit ones.
  44  // Then do explicit declarations, followed by implicit ones.
  45    int_4 k;
  46    for (k = 0; k < nlocals; k++) {
  47      IDENT *idf = &locals[k];
  48      idf->used = FALSE;
  49    }
  50  }
  51  
  52  void get_init (IDENT *idf, MODE *mode)
  53  {
  54    EXPR reg;
  55    memset (&reg, 0, sizeof (EXPR));
  56    (void) scan (EXPECT_NONE);
  57    factor (&reg);
  58    if (accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
  59      cpp_direct (nprocs, prelin, BODY);
  60      RECORD str;
  61      if (mode->type == CHARACTER) {
  62        _srecordf (str, "bufcpy (%s, %s, %d);\n", C_NAME (idf), reg.str, mode->len);
  63      } else {
  64        _srecordf (str, "%s = %s;\n", C_NAME (idf), reg.str);
  65      }
  66      code (nprocs, BODY, str);
  67    } else {
  68      ERROR (801, "expect type", qtype (mode));
  69    }
  70  }
  71  
  72  void dec_local (void)
  73  {
  74    int_4 rc;
  75    MODE mode;
  76    RECORD base;
  77    RECCLR (base);
  78    strcpy (base, curlex);
  79  // Remove length specification.
  80    char *star = strchr (base, '*');
  81    if (star != NO_TEXT) {
  82      *star = '\0';
  83    }
  84  // 
  85    f2c_type (curlex, &mode, NOARG, NOFUN);
  86    rc = scan (EXPECT_NONE);
  87    if (rc == END_OF_LINE) {
  88      EXPECT (802, "identifier");
  89    }
  90    while (rc != END_OF_LINE) {
  91      IDENT *idf = NO_IDENT;
  92  // Identifier, store with leading mode unless length N is specified as idf*N.
  93      RECORD name;
  94      RECCLR (name);
  95      if (rc != WORD) {
  96        EXPECT (803, "identifier");
  97      } else {
  98        strcpy (name, curlex);
  99        rc = scan (EXPECT_NONE);
 100        if (!TOKEN ("*")) {
 101  // identifier
 102          idf = add_local (name, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
 103        } else {
 104  // identifier*length
 105          RECORD length;
 106          rc = scan (EXPECT_NONE);
 107          bufcpy (length, curlex, RECLN);
 108          if (TOKEN ("(")) {
 109  // identifier*(length)
 110            rc = scan (EXPECT_NONE);
 111            bufcpy (length, curlex, RECLN);
 112            (void) scan (")");
 113          }
 114          if (rc == WORD) {
 115            IDENT *ldf = find_local (length, NO_MODE);
 116            if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
 117              SYNTAX (804, length);
 118            } else if (ldf->mode.type != INTEGER) {
 119              EXPECT (805, "integer");
 120            } else {
 121              RECORD new;
 122              RECCLR (new);
 123              snprintf (new, RECLN, "%s*%s", base, ldf->parm);
 124              MODE mode_n;
 125              f2c_type (new, &mode_n, NOARG, NOFUN);
 126              norm_mode (&mode_n);
 127              idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
 128            }
 129            rc = scan (EXPECT_NONE);
 130          } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
 131            RECORD new;
 132            RECCLR (new);
 133            MODE mode_n;
 134        if (EQUAL (length, "*")) {
 135              snprintf (new, RECLN, "%s*(*)", base);
 136        } else {
 137              snprintf (new, RECLN, "%s*%s", base, length);
 138        }
 139            f2c_type (new, &mode_n, NOARG, NOFUN);
 140            norm_mode (&mode_n);
 141            idf = add_local (name, mode_n.type, mode_n.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
 142            rc = scan (EXPECT_NONE);
 143          } else {
 144            SYNTAX (806, name);
 145          }
 146        }
 147  //
 148      }
 149      if (TOKEN ("(") && idf != NO_IDENT) {
 150        if (IS_ROW (idf->mode)) {
 151          ERROR (807, "already dimensioned", C_NAME (idf));
 152        }
 153        get_dims (idf, 1);
 154        rc = scan (EXPECT_NONE);
 155        if (TOKEN ("*")) {
 156          RECORD length;
 157          rc = scan (EXPECT_NONE);
 158          bufcpy (length, curlex, RECLN);
 159          if (TOKEN ("(")) {
 160  // identifier*(length)
 161            rc = scan (EXPECT_NONE);
 162            bufcpy (length, curlex, RECLN);
 163            (void) scan (")");
 164          }
 165          if (rc == WORD) {
 166            IDENT *ldf = find_local (length, NO_MODE);
 167            if (ldf == NO_IDENT || ldf->parm == NO_TEXT) {
 168              SYNTAX (808, length);
 169            } else if (ldf->mode.type != INTEGER) {
 170              EXPECT (809, "integer");
 171            } else {
 172              RECORD new;
 173              RECCLR (new);
 174              snprintf (new, RECLN, "%s*%s", base, ldf->parm);
 175              MODE mode_n;
 176              f2c_type (new, &mode_n, NOARG, NOFUN);
 177              norm_mode (&mode_n);
 178              idf->mode.type = mode_n.type;
 179              idf->mode.len = mode_n.len;
 180            }
 181            rc = scan (EXPECT_NONE);
 182          } else if (rc == INT_NUMBER || EQUAL (length, "*")) {
 183            RECORD new;
 184            RECCLR (new);
 185            snprintf (new, RECLN, "%s*%s", base, length);
 186            MODE mode_n;
 187            f2c_type (new, &mode_n, NOARG, NOFUN);
 188            norm_mode (&mode_n);
 189            idf->mode.type = mode_n.type;
 190            idf->mode.len = mode_n.len;
 191            rc = scan (EXPECT_NONE);
 192          } else {
 193            SYNTAX (810, name);
 194          }
 195        }
 196  //
 197      } else if (TOKEN ("/") && idf != NO_IDENT) {
 198        get_init (idf, &mode);
 199        rc = scan (EXPECT_NONE);
 200        if (!TOKEN ("/")) {
 201          EXPECT (811, "/");
 202        } 
 203        rc = scan (EXPECT_NONE);
 204      }
 205      if (TOKEN (",")) {
 206        rc = scan (EXPECT_NONE);
 207        if (! WITHIN) {
 208          SYNTAX (812, NO_TEXT);
 209        }
 210      } else {
 211        if (rc != END_OF_LINE) {
 212          SYNTAX (813, NO_TEXT);
 213          rc = scan (EXPECT_NONE);
 214        }
 215      }
 216    }
 217  }
 218  
 219  IDENT *extf_decl (char *name, MODE *mode)
 220  {
 221    IDENT *idf = impl_decl (name, mode);
 222    if (idf->external) {
 223      ERROR (814, "already set external", C_NAME (idf));
 224    } else if (idf->intrinsic) {
 225      ERROR (815, "already set intrinsic", C_NAME (idf));
 226    } else {
 227      idf->external = TRUE;
 228    }
 229    return idf;
 230  }
 231  
 232  static void externals (void)
 233  {
 234    int_4 rc;
 235    while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
 236      if (TOKEN (",")) {
 237        ;
 238      } else if (rc == WORD) {
 239        MODE mode;
 240        extf_decl (curlex, &mode);
 241      } else {
 242        EXPECT (816, "subprogram name");
 243      }
 244    }
 245  }
 246  
 247  static void intrinsics (void)
 248  {
 249    int_4 rc;
 250    while ((rc = scan (EXPECT_NONE)) != END_OF_LINE) {
 251      if (TOKEN (",")) {
 252        ;
 253      } else if (!is_intrins (curlex)){
 254        EXPECT (817, "intrinsic funcion name");
 255      } else {
 256        RECORD name;
 257        bufcpy (name, curlex, RECLN);
 258        IDENT *idf = add_local (name, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
 259        if (idf->external) {
 260          ERROR (818, "already set external", C_NAME (idf));
 261        } else if (idf->intrinsic) {
 262          ERROR (819, "already set intrinsic", C_NAME (idf));
 263        } else {
 264          idf->intrinsic = TRUE;
 265        }
 266      }
 267    }
 268  }
 269  
 270  void get_decls (void)
 271  {
 272    int_4 go_on = TRUE;
 273    idfs_reset ();
 274    while (go_on) {
 275      SAVE_POS;
 276      int_4 rc = scan (EXPECT_NONE);
 277      if (rc == DECLAR) {
 278        dec_local ();
 279        skip_card (FALSE);
 280      } else if (TOKEN ("implicit")) {
 281        skip_card (FALSE);
 282      } else if (TOKEN ("save")) {
 283        skip_card (FALSE);
 284      } else if (TOKEN ("automatic")) {
 285        skip_card (FALSE);
 286      } else if (TOKEN ("parameter")) {
 287        parameter ();
 288        skip_card (FALSE);
 289      } else if (TOKEN ("common")) {
 290        common ();
 291        skip_card (FALSE);
 292      } else if (TOKEN ("dimension")) {
 293        dimension ();
 294        skip_card (FALSE);
 295      } else if (TOKEN ("equivalence")) {
 296        skip_card (FALSE);
 297      } else if (TOKEN ("external")) {
 298        externals ();
 299      } else if (TOKEN ("intrinsic")) {
 300        intrinsics ();
 301      } else if (TOKEN ("data")) {
 302        skip_card (FALSE);
 303      } else if (strlen (curlex) > 0) {
 304  // Backspace and done.
 305        RESTORE_POS;
 306        go_on = FALSE;
 307      }
 308    }
 309    idfs_impl ();
 310  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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