modules.c

     
   1  //! @file modules.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  //! Compile BLOCK DATA, FUNCTION, PROGRAM and SUBROUTINE.
  25  
  26  #include <vif.h>
  27  
  28  int_4 nmodules = 0;
  29  char *modules[MAX_MODULES];
  30  
  31  void common_errors (int_4 *nest)
  32  {
  33    RECORD str;
  34    _srecordf (str, "%s %s", prelex, curlex);
  35    if (TOKEN ("(")) {
  36      (*nest)++;
  37    } else if (TOKEN (")")) {
  38      (*nest)--;
  39    } else if (strlen (curlex) == 1 && strchr ("{}[];\\?~`@#$%", curlex[0]) != NULL) {
  40      SYNTAX (2201, "stray symbol");
  41    } else if (preret == WORD && curret == WORD) {
  42      if (!reserved (prelex)) {
  43        ADJACENT (2202, str);
  44      }
  45    } else if (IS_NUMBER (preret) && IS_NUMBER (curret)) {
  46      ADJACENT (2203, str);
  47    }
  48  }
  49  
  50  void skip_to_end (void)
  51  {
  52    int_4 rc, go_on = TRUE;
  53    while (go_on && (rc = scan (NULL)) != END_OF_MODULE) {
  54      if (TOKEN ("end")) {
  55        go_on = FALSE;
  56      } else {
  57        rc = scan (NULL);
  58        while (WITHIN) {
  59          rc = scan (NULL);
  60        }
  61      }
  62    }
  63  }
  64  
  65  void prescan (void)
  66  {
  67    SAVE_POS;
  68    int_4 rc, go_on = TRUE;
  69    while (go_on && (rc = scan (NULL)) != END_OF_MODULE) {
  70      LBL *statlbl = NULL;
  71      if (curlex[0] == '\0') {
  72        continue;
  73      }
  74      if (rc == LABEL) {
  75        sscanf (curlex, "%d", &source[curlin].label);
  76        if (nlabels >= MAX_LABELS) {
  77          ERROR (2204, "too many labels", NULL);
  78        }
  79        statlbl = &labels[nlabels];
  80        statlbl->index = nlabels;
  81        statlbl->num = source[curlin].label;
  82        statlbl->line = curlin;
  83        statlbl->nonexe = FALSE;
  84        statlbl->data = FALSE;
  85        statlbl->format = FALSE;
  86        statlbl->jumped = FALSE;
  87        nlabels++;
  88        rc = scan (NULL);
  89      }
  90      if (TOKEN ("end")) {
  91        go_on = FALSE;
  92      } else if (TOKEN ("data")) {
  93        if (statlbl != NULL) {
  94          statlbl->nonexe = TRUE;
  95          statlbl->data = TRUE;
  96        }
  97        skip_card ();
  98      } else if (TOKEN ("format")) {
  99        if (statlbl == NULL) {
 100          ERROR (2205, "format statement needs a label", NULL);
 101        }
 102        statlbl->nonexe = TRUE;
 103        statlbl->format = TRUE;
 104        skip_card ();
 105      } else {
 106        int_4 nest = 0;
 107        rc = scan (NULL);
 108        while (WITHIN) {
 109          common_errors (&nest);
 110          rc = scan (NULL);
 111        }
 112        if (nest != 0) {
 113          SYNTAX (2206, "unbalanced parentheses");
 114        }
 115      }
 116    }
 117    RESTORE_POS;
 118  }
 119  
 120  void code_args (int_4 proc, int_4 phase)
 121  {
 122    int_4 rc;
 123    code (proc, phase, procnam);
 124    code (proc, phase, " ");
 125    rc = scan (NULL);
 126    if (TOKEN ("(")) {
 127      rc = scan (NULL);
 128      if (TOKEN (")")) {
 129        code (proc, phase, "(void)");
 130      } else if (rc == WORD) {
 131        int_4 go_on;
 132        code (proc, phase, "(");
 133        do {
 134          int_4 apatch = code (proc, phase, NULL);
 135          if (rc == WORD) {
 136            add_local (curlex, NOTYPE, NOLEN, UNIQ, apatch, ARG, LOCAL, SOURCE);
 137          } else {
 138            EXPECT (2207, "variable");
 139          }
 140          rc = scan (NULL);
 141          if (TOKEN (",")) {
 142            go_on = TRUE;
 143            code (proc, phase, ", ");
 144            rc = scan (NULL);
 145          } else if (TOKEN (")")) {
 146            go_on = FALSE;
 147            code (proc, phase, ")");
 148          } else {
 149            go_on = FALSE;
 150            EXPECT (2208, ", or )");
 151          }
 152        } while (go_on);
 153      }
 154    } else {
 155      code (proc, phase, "(void)");
 156    }
 157    (void) rc;
 158    skip_card ();
 159  }
 160  
 161  void gen_code (void)
 162  {
 163  // Generate code for one module.
 164    code (nprocs, TITLE, newpage (modnam, "generated-code"));
 165    code (nprocs, PARAMETERS, newpage (modnam, "parameters"));
 166    code (nprocs, MESSAGES, newpage (modnam, "diagnostics"));
 167    merrors = 0;
 168    prescan ();
 169  //
 170    if (merrors == 0) {
 171      SAVE_POS;
 172      get_impl ();
 173      RESTORE_POS;
 174      get_decls ();
 175      RESTORE_POS;
 176      decl_autosave ();
 177      RESTORE_POS;
 178      decl_equiv ();
 179      merge_commons ();
 180      RESTORE_POS;
 181      decl_data ();
 182    }
 183    idfs_unused ();
 184    if (merrors == 0) {
 185      decl_macros ();
 186    } else {
 187      skip_to_end ();
 188      return;
 189    }
 190    if (merrors == 0) {
 191      gen_statements (NULL, 0);
 192      code_idfs (locals, nlocals, LOCAL, nprocs, DECL);
 193      code_exts (locals, nlocals, LOCAL, nprocs, DECL);
 194    } else {
 195      skip_to_end ();
 196      return;
 197    }
 198    if (merrors == 0) {
 199      patch_args ();
 200    }
 201  }
 202  
 203  void gen_program (void)
 204  {
 205    int_4 rc;
 206  // PROGRAM
 207    nprocs++;
 208    code (0, PROTOTYPE, "\n");
 209    code (0, PROTOTYPE, "prototype int_4 ");
 210    code (nprocs, PRE, "int_4 ");
 211    SAVE_POS;
 212    rc = scan (NULL);
 213    if (rc != WORD) {
 214      ERROR (2209, "missing name for ", "program");
 215      strcpy (modnam, "program");
 216    } else {
 217      strcpy (modnam, curlex);
 218    }
 219    _srecordf (procnam, "%s", edit_f (modnam));
 220    strcpy (retnam, "");
 221    if (strlen (program) == 0) {
 222      strcpy (program, procnam);
 223    } else {
 224      ERROR (2210, "redefinition", "program");
 225    }
 226    code_args (0, PROTOTYPE);
 227    code (0, PROTOTYPE, ";");
 228    RESTORE_POS;
 229    rc = scan (NULL);
 230    code_args (nprocs, PRE);
 231    code (nprocs, PRE, "\n");
 232    code (nprocs, PRE, "{\n");
 233    cpp_direct (nprocs, prelin, PRE);
 234    gen_code ();
 235    code (nprocs, POST, "}");
 236  }
 237  
 238  void gen_anon_program (void)
 239  {
 240  // ANONYMOUS PROGRAM
 241    if (nprocs > 1) {
 242      EXPECT (2211, "valid subprogram");
 243      return; 
 244    }
 245    curlin = 1; 
 246    curcol = START_OF_LINE;
 247    nprocs++;
 248    strcpy (modnam, "main");
 249    _srecordf (procnam, "%s", edit_f (modnam));
 250    strcpy (retnam, "");
 251    if (strlen (program) == 0) {
 252      strcpy (program, procnam);
 253    } else {
 254      ERROR (2212, "redefinition", "program");
 255    }
 256    code (0, PROTOTYPE, "\n");
 257    code (0, PROTOTYPE, "prototype int_4 ");
 258    code (0, PROTOTYPE, procnam);
 259    code (0, PROTOTYPE, " (void);");
 260    code (nprocs, PRE, "int_4 ");
 261    code (nprocs, PRE, procnam);
 262    code (nprocs, PRE, " (void)");
 263    code (nprocs, PRE, "\n");
 264    code (nprocs, PRE, "{\n");
 265    cpp_direct (nprocs, prelin, PRE);
 266    gen_code ();
 267    code (nprocs, POST, "}");
 268  }
 269  
 270  void gen_subroutine (void)
 271  {
 272  // SUBROUTINE
 273    int_4 rc;
 274    nprocs++;
 275    code (0, PROTOTYPE, "\n");
 276    if (compile_only || optimise < 3) {
 277      code (0, PROTOTYPE, "prototype int_4 ");
 278      code (nprocs, PRE, "int_4 ");
 279    } else {
 280      code (0, PROTOTYPE, "prototype static inline int_4 ");
 281      code (nprocs, PRE, "static inline int_4 ");
 282    }
 283    SAVE_POS;
 284    rc = scan (NULL);
 285    if (rc != WORD) {
 286      ERROR (2213, "missing name for ", "subroutine");
 287      strcpy (modnam, "routine");
 288    } else {
 289      strcpy (modnam, curlex);
 290    }
 291    _srecordf (procnam, "%s", edit_f (modnam));
 292    strcpy (retnam, "");
 293    code_args (0, PROTOTYPE);
 294    code (0, PROTOTYPE, ";");
 295    RESTORE_POS;
 296    rc = scan (NULL);
 297    code_args (nprocs, PRE);
 298    code (nprocs, PRE, "\n");
 299    code (nprocs, PRE, "{\n");
 300    cpp_direct (nprocs, prelin, PRE);
 301    gen_code ();
 302    code (nprocs, POST, "}");
 303  }
 304  
 305  void gen_block_data (void)
 306  {
 307  // BLOCK DATA
 308    RECORD str;
 309    int_4 rc = scan (NULL);
 310    nprocs++;
 311    if (!TOKEN ("data")) {
 312      EXPECT (2214, "block data");
 313    }
 314    rc = scan (NULL);
 315    if (prelin == curlin) {
 316      strcpy (modnam, curlex);
 317      rc = scan (NULL);
 318    } else {
 319      strcpy (modnam, "block_data");
 320    }
 321    strcpy (retnam, "");
 322    _srecordf (block, "%s", edit_f (modnam));
 323    if (compile_only || optimise < 3) {
 324      _srecordf (str, "int_4 %s (void)", block);
 325    } else {
 326      _srecordf (str, "static inline int_4 %s (void)", block);
 327    }
 328    code (0, PROTOTYPE, "\n");
 329    code (0, PROTOTYPE, "prototype ");
 330    code (0, PROTOTYPE, str);
 331    code (0, PROTOTYPE, ";");
 332    code (nprocs, PRE, str);
 333    code (nprocs, PRE, "{\n");
 334    cpp_direct (nprocs, prelin, PRE);
 335    gen_code ();
 336    code (nprocs, POST, "}");
 337    (void) rc;
 338  }
 339  
 340  void gen_function (void)
 341  {
 342    int_4 rc;
 343  // FUNCTION with implicit type.
 344    int_4 patchp, patchf;
 345    SAVE_POS;
 346    IDENT *ret;
 347    RECORD str;
 348    nprocs++;
 349    func = TRUE;
 350    code (0, PROTOTYPE, "\n");
 351    code (0, PROTOTYPE, "prototype ");
 352    if (compile_only == FALSE || optimise >= 3) {
 353      code (0, PROTOTYPE, "static inline ");
 354    }
 355    patchp = code (0, PROTOTYPE, NULL);
 356    code (0, PROTOTYPE, " ");
 357    if (compile_only == FALSE || optimise >= 3) {
 358      code (nprocs, PRE, "static inline ");
 359    }
 360    patchf = code (nprocs, PRE, NULL);
 361    code (nprocs, PRE, " ");
 362    rc = scan (NULL);
 363    if (rc != WORD) {
 364      ERROR (2215, "missing name for ", "function");
 365      strcpy (modnam, "function");
 366    } else {
 367      strcpy (modnam, curlex);
 368    }
 369    _srecordf (procnam, "%s", edit_f (modnam));
 370  // if (is_intrins (modnam)) {
 371  //   ERROR (2216, "redefining intrinsic function", modnam);
 372  // }
 373    ret = add_local (modnam, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
 374    ret->mode.fun = TRUE;
 375    ret->mode.save = AUTOMATIC;
 376    _srecordf (retnam, "%s", CID (ret));
 377    code_args (0, PROTOTYPE);
 378    code (0, PROTOTYPE, ";");
 379    RESTORE_POS;
 380    rc = scan (NULL);
 381    code_args (nprocs, PRE);
 382    code (nprocs, PRE, "\n");
 383    code (nprocs, PRE, "{\n");
 384    cpp_direct (nprocs, prelin, PRE);
 385    gen_code ();
 386    code (nprocs, POST, "}\n");
 387    _srecordf (str, "%s", wtype (&ret->mode, NOARG, FUN));
 388    patch (patchp, str);
 389    patch (patchf, str);
 390  }
 391  
 392  MODE gen_type_function (void)
 393  {
 394    int_4 rc;
 395  // TYPE FUNCTION
 396    MODE mode;
 397    f2c_type (curlex, &mode, NOARG, NOFUN);
 398    rc = scan (NULL);
 399    if (!TOKEN ("function")) {
 400      if (nprocs > 0) {
 401        EXPECT (2217, "function");
 402      } else {
 403        mode.type = NOTYPE;
 404        mode.len = 0;
 405      }
 406      return mode;
 407    } else {
 408      SAVE_POS;
 409      IDENT *ret;
 410      nprocs++;
 411      func = TRUE;
 412      code (0, PROTOTYPE, "\n");
 413      code (0, PROTOTYPE, "prototype ");
 414      if (compile_only == FALSE || optimise >= 3) {
 415        code (0, PROTOTYPE, "static inline ");
 416      }
 417      code (0, PROTOTYPE, f2c_type (prelex, NULL, NOARG, FUN));
 418      code (0, PROTOTYPE, " ");
 419      if (compile_only == FALSE || optimise >= 3) {
 420        code (nprocs, PRE, "static inline ");
 421      }
 422      code (nprocs, PRE, f2c_type (prelex, NULL, NOARG, FUN));
 423      code (nprocs, PRE, " ");
 424      rc = scan (NULL);
 425      if (rc != WORD) {
 426        ERROR (2218, "missing name for ", "function");
 427        strcpy (modnam, "function");
 428      } else {
 429        strcpy (modnam, curlex);
 430      }
 431      _srecordf (procnam, "%s", edit_f (modnam));
 432  //  if (is_intrins (modnam)) {
 433  //    ERROR (2219, "redefining intrinsic function", modnam);
 434  //  }
 435      ret = add_local (modnam, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
 436      ret->mode.fun = TRUE;
 437      ret->mode.save = AUTOMATIC;
 438      _srecordf (retnam, "%s", CID (ret));
 439      code_args (0, PROTOTYPE);
 440      code (0, PROTOTYPE, ";");
 441      RESTORE_POS;
 442      rc = scan (NULL);
 443      code_args (nprocs, PRE);
 444      code (nprocs, PRE, "\n");
 445      code (nprocs, PRE, "{\n");
 446      cpp_direct (nprocs, prelin, PRE);
 447      gen_code ();
 448      code (nprocs, POST, "}");
 449    }
 450    return mode;
 451  }
 452  
 453  void subprograms (void)
 454  {
 455    int_4 rc;
 456    RECORD type, kind, str, endof;
 457    while ((rc = scan (NULL)) != END_OF_MODULE && !abend) {
 458      nlocals = 0;
 459      type[0] = '\0';
 460  // Label '0' is the label for subprogram exit.
 461      labels[0].num = 0;
 462      labels[0].line = 0;
 463      labels[0].jumped = FALSE;
 464      nlabels = 1;
 465  //
 466      lbl = NULL;
 467      nloctmps = 0;
 468      func = FALSE;
 469      if (rc == END_OF_LINE) {
 470        continue;
 471      }
 472      kind[0] = '\0';
 473      end_statements = 0;
 474      if (rc == WORD) {
 475        if (TOKEN ("program")) {
 476          bufcpy (kind, "program", RECLN);
 477          gen_program ();
 478        } else if (TOKEN ("subroutine")) {
 479          bufcpy (kind, "subroutine", RECLN);
 480          gen_subroutine ();
 481        } else if (TOKEN ("block")) {
 482          bufcpy (kind, "block data", RECLN);
 483          gen_block_data ();
 484        } else if (TOKEN ("function")) {
 485          bufcpy (kind, "function", RECLN);
 486          gen_function ();
 487        } else {
 488          if (nprocs == 0) {
 489            gen_anon_program ();
 490            bufcpy (kind, "program", RECLN);
 491          }
 492        }
 493      } else if (rc == DECLAR) {
 494        bufcpy (kind, "function", RECLN);
 495        MODE ret = gen_type_function ();
 496        if (ret.type == NOTYPE && nprocs == 0) {
 497          gen_anon_program ();
 498          bufcpy (kind, "program", RECLN);
 499        } else {
 500          _srecordf (type, qtype (&ret));
 501        }
 502      } else if (rc == LABEL) {
 503        WARNING (2220, "ignored label", curlex);
 504      } else {
 505        if (nprocs == 0) {
 506          gen_anon_program ();
 507          bufcpy (kind, "program", RECLN);
 508        } else {
 509          EXPECT (2221, "valid subprogram");
 510        }
 511        return;
 512      }
 513      if (end_statements == 0) {
 514        EXPECT (2222, "end statement");
 515      }
 516      if (nprocs == 0) {
 517  //    BUG ("no subprogram found");
 518        FATAL (2223, "no subprogram", "check program statement");
 519      }
 520  // Prune 'sleeping' labels.
 521      for (int_4 k = 0; k < nlabels; k++) {
 522        LBL *L = &labels[k];
 523        if (!L->jumped) {
 524          patch (L->patch, NULL);
 525        }
 526      }
 527  //
 528      if (nprocs == pnprocs) {
 529        FATAL (2224, "invalid fortran source", modnam);
 530      }
 531      RECORD sub;
 532      _srecordf (endof, "** %-10s ** end of compilation %d", _bufsub (sub, modnam, 1, 10), nprocs);
 533      pnprocs = nprocs;
 534      code (nprocs, BANNER, newpage (modnam, modnam));
 535      if (strlen (type) > 0) {
 536        banner (nprocs, BANNER, _strupper (type));
 537        code (nprocs, BANNER, "\n");
 538        _srecordf (str, "  {\"%s\", 0}, // %s %s\n", modnam, type, kind);
 539        code (0, FREQ, str);
 540      } else {
 541        _srecordf (str, "  {\"%s\", 0}, // %s\n", modnam, kind);
 542        code (0, FREQ, str);
 543      }
 544      banner (nprocs, BANNER, _strupper (kind));
 545      code (nprocs, BANNER, "\n");
 546      banner (nprocs, BANNER, _strupper (modnam));
 547      code (nprocs, BANNER, "\n");
 548      if (!quiet_mode) {
 549        diagnostic (nprocs, endof);
 550      }
 551      proc_listing (nprocs);
 552    }
 553  }
 554  
 555  int_4 find_module (char *name)
 556  {
 557    for (int_4 k = 0; k < nmodules; k++) {
 558      if (same_name (name, modules[k])) {
 559        return TRUE;
 560      }
 561    }
 562    return FALSE;
 563  }
 564  
 565  void list_module (void)
 566  {
 567    int_4 rc = scan (NULL);
 568    if (rc == WORD) {
 569      if (nmodules >= MAX_MODULES) {
 570        FATAL (2225, "too many modules", NULL);
 571      }
 572      modules[nmodules++] = stralloc (curlex);
 573    } else {
 574      ERROR (2226, "missing name", "module");
 575    }
 576  }
 577  
 578  void scan_modules (void)
 579  {
 580    int_4 rc;
 581    while ((rc = scan (NULL)) != END_OF_MODULE && !abend) {
 582      if (rc == WORD) {
 583        if (TOKEN ("program")) {
 584          list_module ();
 585        } else if (TOKEN ("subroutine")) {
 586          list_module ();
 587        } else if (TOKEN ("function")) {
 588          list_module ();
 589        } else if (rc == DECLAR) {
 590          rc = scan (NULL);
 591          if (TOKEN ("function")) {
 592            list_module ();
 593          }
 594        } else if (TOKEN ("block")) {
 595          rc = scan (NULL);
 596          if (TOKEN ("data")) {
 597            list_module ();
 598          }
 599        }
 600      }
 601    }
 602  }
     


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