Algol 68 Genie

tidy.c

     1  //! @file yidy.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  //! Vintage Fortran tidying tool.
    25  
    26  #include <vif.h>
    27  
    28  #define ALLOW_ANON (nprocs >= 0)
    29  
    30  void tidy_executable (void);
    31  void tidy_statements (LBL *, int_4);
    32  
    33  void tidy_to_upper (void)
    34  {
    35  // Make uppercase, backwards.
    36    if (tidy) {
    37      char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
    38      while (*p != '\0') {
    39        if (isspace (*q)) {
    40          q--;
    41        } else {
    42          *q = toupper (*q);
    43          q--;
    44          p++;
    45        }
    46      }
    47    }
    48  }
    49  
    50  void tidy_to_lower (void)
    51  {
    52  // Make lowercase, backwards.
    53    if (tidy) {
    54      char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
    55      while (*p != '\0') {
    56        if (isspace (*q)) {
    57     q--;
    58        } else {
    59     *q = tolower (*q);
    60     q--;
    61     p++;
    62        }
    63      }
    64    }
    65  }
    66  
    67  void tidy_skip_card (void)
    68  {
    69    if (prelin == curlin) {
    70      int_4 rc;
    71      do {
    72        rc = scan (EXPECT_NONE);
    73      }
    74      while (rc != END_OF_LINE && rc != END_OF_MODULE);
    75    } else if (CUR_LIN.text == NO_TEXT) {
    76      return;
    77    } else if (strlen (CUR_LIN.text) >= 6 && POS(5) != ' ') {
    78      int_4 rc;
    79      do {
    80        rc = scan (EXPECT_NONE);
    81      }
    82      while (rc != END_OF_LINE && rc != END_OF_MODULE);
    83    }
    84  }
    85  
    86  LBL *find_relabel (char *lab)
    87  {
    88    int_4 k, num;
    89    sscanf (lab, "%d", &num);
    90    for (k = 0; k < nlabels; k++) {
    91      LBL *L = &labels[k];
    92      if (num == L->num) {
    93        return L;
    94      }
    95    }
    96    FATAL (3201, "no such label", curlex);
    97  }
    98  
    99  void replace_label (int_4 label)
   100  {
   101    NEW_RECORD (repl);
   102    _srecordf (repl, "%d", label);
   103    int_4 len_orig = strlen (curlex), len_repl = strlen (repl);
   104    int_4 delta = len_repl - len_orig;
   105    char *p = CUR_LIN.text;
   106    if ((strlen (p) + delta) > RECLN) {
   107      FATAL (3202, "cannot replace label", NO_TEXT);
   108    }
   109    NEW_RECORD (sub);
   110    RECCPY (sub, p);
   111    int_4 k = 0;
   112  // Recalibrate current position.
   113    while (curcol >= 0 && !isdigit (CUR_COL)) {
   114      curcol--;
   115    }
   116    curcol++;
   117  //
   118    for (; k < curcol - len_orig; k++) {
   119      p[k] = sub[k];
   120    }
   121    for (int_4 n = 0; repl[n] != '\0'; n++, k++) {
   122      p[k] = repl[n];
   123    }
   124    for (int_4 n = curcol; sub[n] != '\0'; n++, k++) {
   125      p[k] = sub[n];
   126    }
   127    for (; sub[k] != '\0'; k++) {
   128      p[k] = '\0';
   129    }
   130    CUR_LIN.len += delta;
   131    curcol += delta;
   132  }
   133  
   134  void tidy_prescan (void)
   135  {
   136    SAVE_POS (1);
   137    int_4 rc, go_on = TRUE;
   138    while (go_on) {
   139      rc = scan (EXPECT_NONE);
   140      if (rc == END_OF_MODULE) {
   141        go_on = FALSE;
   142      }
   143      if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
   144        go_on = FALSE;
   145      } else if (rc != TEXT) {
   146        tidy_to_lower ();
   147      }
   148    }
   149    RESTORE_POS (1);
   150  }
   151  
   152  void tidy_subprogram (void)
   153  {
   154    SAVE_POS (1);
   155    int_4 rc = scan (EXPECT_NONE);
   156    if (rc == WORD) {
   157      if (TOKEN ("program")) {
   158        tidy_to_upper ();
   159        tidy_skip_card ();
   160        return;
   161      } else if (TOKEN ("subroutine")) {
   162        tidy_to_upper ();
   163        tidy_skip_card ();
   164        return;
   165      } else if (TOKEN ("block")) {
   166        tidy_to_upper ();
   167        rc = scan (EXPECT_NONE);
   168        if (TOKEN ("data")) {
   169          tidy_to_upper ();
   170        }
   171        tidy_skip_card ();
   172        return;
   173      } else if (TOKEN ("function")) {
   174        tidy_to_upper ();
   175        tidy_skip_card ();
   176        return;
   177      } else {
   178        if (ALLOW_ANON) {
   179          tidy_skip_card ();
   180        }
   181      }
   182    } else if (rc == DECLAR) {
   183      tidy_to_upper ();
   184      tidy_subprogram ();
   185    }
   186    RESTORE_POS (1);
   187  }
   188  
   189  static void tidy_decls (void)
   190  {
   191    int_4 go_on = TRUE;
   192    while (go_on) {
   193      SAVE_POS (1);
   194      int_4 rc = scan (EXPECT_NONE);
   195      if (rc == DECLAR) {
   196        tidy_to_upper ();
   197        tidy_skip_card ();
   198      } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
   199        tidy_to_upper ();
   200        rc = scan (EXPECT_NONE);
   201        if (rc == DECLAR) {
   202          tidy_to_upper ();
   203        }
   204        tidy_skip_card ();
   205      } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
   206        tidy_to_upper ();
   207        tidy_skip_card ();
   208      } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
   209        tidy_to_upper ();
   210        tidy_skip_card ();
   211      } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
   212        tidy_to_upper ();
   213        tidy_skip_card ();
   214      } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
   215        tidy_to_upper ();
   216        tidy_skip_card ();
   217      } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
   218        tidy_to_upper ();
   219        tidy_skip_card ();
   220      } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
   221        tidy_to_upper ();
   222        tidy_skip_card ();
   223      } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
   224        tidy_to_upper ();
   225        tidy_skip_card ();
   226      } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
   227        tidy_to_upper ();
   228        tidy_skip_card ();
   229      } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
   230        tidy_to_upper ();
   231        tidy_skip_card ();
   232      } else if (rc == WORD && IS_MACRO_DECLARATION) {
   233        tidy_skip_card ();
   234      } else if (strlen (curlex) > 0) {
   235  // Backspace and done.
   236        RESTORE_POS (1);
   237        go_on = FALSE;
   238      }
   239    }
   240  }
   241  
   242  void tidy_vif_extensions(void)
   243  {
   244    if (TOKEN ("exit")) {
   245      tidy_to_upper ();
   246      tidy_skip_card ();
   247    } else if (TOKEN ("break")) {
   248      tidy_to_upper ();
   249      tidy_skip_card ();
   250    } else if (TOKEN ("cycle")) {
   251      tidy_to_upper ();
   252      tidy_skip_card ();
   253    } else {
   254      ERROR (3203, "syntax", curlex);
   255      tidy_skip_card ();
   256    }
   257  }
   258  
   259  void tidy_jump (void)
   260  {
   261    int_4 rc = scan (EXPECT_LABEL);
   262    if (rc == LABEL) {
   263  // GOTO label
   264      LBL *L = find_relabel (curlex);
   265      replace_label (L->renum);
   266      tidy_skip_card ();
   267    } else if (TOKEN ("(")) {
   268  // GOTO (...), expr
   269      rc = scan (EXPECT_LABEL);
   270      while (rc == LABEL) {
   271        LBL *L = find_relabel (curlex);
   272        replace_label (L->renum);
   273        rc = scan (EXPECT_NONE);
   274        if (TOKEN (",")) {
   275          rc = scan (EXPECT_LABEL);
   276        }
   277      };
   278      CHECKPOINT (3204, ")");
   279      tidy_skip_card ();
   280    } else if (rc == WORD) {
   281  // GOTO idf [, (...)]
   282      IDENT *idf = find_local (curlex, NO_MODE);
   283      if (idf == NO_IDENT ) {
   284        return;
   285      }
   286      if (idf->mode.type != INTEGER) {
   287        EXPECT (3205, "integer variable");
   288      }
   289      EXPR var; MODE mode;
   290      var.str[0] = '\0';
   291      factor_variable (&var, idf, &mode, curlex);
   292      rc = scan (EXPECT_NONE);
   293      if (TOKEN (",") || TOKEN ("(")) {
   294    // Emit indicated labels.
   295        if (TOKEN (",")) {
   296          rc = scan (EXPECT_NONE);
   297        }
   298        CHECKPOINT (3206, "(");
   299        rc = scan (EXPECT_LABEL);
   300        while (rc == LABEL) {
   301          LBL *L = find_relabel (curlex);
   302          replace_label (L->renum);
   303          rc = scan (EXPECT_LABEL);
   304          if (TOKEN (",")) {
   305            rc = scan (EXPECT_LABEL);
   306          }
   307        }
   308        CHECKPOINT (3207, ")");
   309        tidy_skip_card ();
   310      } else {
   311      // Default, emit all labels.
   312        tidy_skip_card ();
   313      }
   314    }
   315  }
   316  
   317  void tidy_block_if (EXPR *reg, int_4 depth)
   318  {
   319  // Block IF.
   320    int_4 rc;
   321    tidy_skip_card ();
   322    NEW_RECORD (str);
   323    if (reg->mode.type != LOGICAL) {
   324      EXPECT (3208, "logical expression");
   325    }
   326    tidy_statements (NO_LABEL, depth + 1);
   327    while (TOKEN ("elseif")) {
   328      EXPR reh;
   329      rc = scan ("(");
   330      rc = scan (EXPECT_NONE);
   331      macro_depth = 0;
   332      express (&reh, NOTYPE, NOLEN);
   333      rc = scan (")");
   334      rc = scan ("THEN");
   335      if (reh.mode.type != LOGICAL) {
   336        EXPECT (3209, "logical expression");
   337      }
   338      tidy_statements (NO_LABEL, depth + 1);
   339    }
   340    if (TOKEN ("else")) {
   341      tidy_skip_card ();
   342      tidy_statements (NO_LABEL, depth + 1);
   343    }
   344    if (TOKEN ("endif")) {
   345      tidy_skip_card ();
   346    } else {
   347      EXPECT (3210, "endif");
   348    }
   349    (void) rc;
   350  }
   351  
   352  void tidy_arith_if (EXPR *reg)
   353  {
   354  // Arithmetic IF.
   355    int_4 rc;
   356    NEW_RECORD (str);
   357    NEW_RECORD (tmp);
   358    LBL *L;
   359  // Gather the labels
   360    L = find_relabel (curlex);
   361    replace_label (L->renum);
   362    rc = scan (",");
   363    rc = scan (EXPECT_NONE);
   364    if (rc != INT_NUMBER) {
   365      EXPECT (3211, "label");
   366      return;
   367    }
   368    L = find_relabel (curlex);
   369    replace_label (L->renum);
   370    rc = scan (",");
   371    if (rc == END_OF_LINE) {
   372    // CRAY FORTRAN two-branch arithmetic statement.
   373      ;
   374    } else {
   375    // ANSI FORTRAN three-branch arithmetic statement.
   376      rc = scan (EXPECT_NONE);
   377      if (rc != INT_NUMBER) {
   378        EXPECT (3212, "label");
   379        return;
   380      }
   381      L = find_relabel (curlex);
   382      replace_label (L->renum);
   383    }
   384    tidy_skip_card ();
   385  }
   386  
   387  void tidy_conditional (int_4 depth, logical_4 block_allowed)
   388  {
   389    int_4 rc = scan ("(");
   390    EXPR reg;
   391    rc = scan (EXPECT_NONE);
   392    macro_depth = 0;
   393    express (&reg, NOTYPE, NOLEN);
   394    rc = scan (")");
   395    rc = scan (EXPECT_NONE);
   396    if (TOKEN ("then") && block_allowed) {
   397      tidy_to_upper ();
   398      tidy_block_if (&reg, depth);
   399    } else if (rc == INT_NUMBER) {
   400      tidy_arith_if (&reg);
   401    } else {
   402  // Logical IF.
   403      NEW_RECORD (str);
   404      if (reg.mode.type != LOGICAL) {
   405        EXPECT (3213, "logical expression");
   406      }
   407      _srecordf (str, "if (%s) {\n", reg.str);
   408      if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
   409        tidy_to_upper ();
   410        tidy_conditional (depth, FALSE);
   411      } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
   412        SYNTAX (3214, "invalid statement in logical IF");
   413      } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
   414        SYNTAX (3215, "invalid statement in logical IF");
   415      } else {
   416        tidy_executable ();
   417      }
   418    }
   419  }
   420  
   421  void tidy_do_loop (LBL * curlbl, int_4 depth)
   422  {
   423    LBL *L;
   424    NEW_RECORD (str);
   425    int_4 rc = scan (EXPECT_LABEL);
   426    if (rc != LABEL) {
   427      L = NO_LABEL;
   428    } else {
   429      L = find_relabel (curlex);
   430      replace_label (L->renum);
   431      if (curlbl != NO_LABEL && L->line > curlbl->line) {
   432        ERROR (3216, "incorrect loop nesting", NO_TEXT);
   433        return;
   434      }
   435      rc = scan (EXPECT_NONE);
   436    }
   437    if (TOKEN ("repeat")) {
   438      tidy_to_upper ();
   439      tidy_skip_card ();
   440      tidy_statements (L, depth + 1);
   441    } else if (TOKEN ("while")) {
   442      tidy_to_upper ();
   443      tidy_skip_card ();
   444    } else {
   445      tidy_skip_card ();
   446      tidy_statements (L, depth + 1);
   447    }
   448  }
   449  
   450  static void tidy_io_specs (char *proc)
   451  {
   452    int_4 rc, parm = 1;
   453  // We accept that only a unit specification follows.
   454    if (curret == INT_NUMBER) {
   455      if (EQUAL (proc, "print")) {
   456        LBL *L = find_relabel (curlex);
   457        replace_label (L->renum);
   458        return;
   459      }
   460      if (EQUAL (proc, "accept")) {
   461        LBL *L = find_relabel (curlex);
   462        replace_label (L->renum);
   463        return;
   464      }
   465    }
   466    if (curret == WORD) {
   467      return;
   468    }
   469    if (TOKEN ("(")) {
   470      rc = scan (EXPECT_NONE); 
   471    } else {
   472      EXPECT (3217, "(");
   473      return;
   474    }
   475  //
   476    while (!TOKEN (")") && rc != END_OF_MODULE) {
   477  // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str |  DISP=str |  END=n | ERR=n])
   478      if (TOKEN ("unit") && lookahead ("=")) {
   479        rc = scan ("=");
   480        rc = scan (EXPECT_NONE);
   481      } else if (TOKEN ("rec") && lookahead ("=")) {
   482        EXPR rec;
   483        rc = scan ("=");
   484        rc = scan (EXPECT_NONE);
   485        macro_depth = 0;
   486        express (&rec, INTEGER, 4);
   487      } else if (TOKEN ("file") && lookahead ("=")) {
   488        EXPR reg;
   489        rc = scan ("=");
   490        rc = scan (EXPECT_NONE);
   491        macro_depth = 0;
   492        if (express (&reg, CHARACTER, NOLEN)) {
   493          ;
   494        }
   495      } else if (TOKEN ("form") && lookahead ("=")) {
   496        rc = scan ("=");
   497        rc = scan (EXPECT_NONE);
   498        if (MATCH ("formatted")) {
   499          ;
   500        } else if (MATCH ("unformatted")) {
   501          ;
   502        } else {
   503          SYNTAX (3218, curlex);
   504        }
   505      } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
   506        rc = scan ("=");
   507        rc = scan (EXPECT_NONE);
   508        if (MATCH ("read")) {
   509          ;
   510        } else if (MATCH ("write")) {
   511          ;
   512        } else if (MATCH ("readwrite")) {
   513          ;
   514        } else if (MATCH ("direct")) {
   515          ;
   516        } else {
   517          SYNTAX (3219, curlex);
   518        }
   519      } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
   520  // Straight from JCL :-)
   521        rc = scan ("=");
   522        rc = scan (EXPECT_NONE);
   523        if (MATCH ("old")) {
   524          ;
   525        } else if (MATCH ("new")) {
   526          ;
   527        } else if (MATCH ("keep")) {
   528          ;
   529        } else if (MATCH ("delete")) {
   530          ;
   531        } else if (MATCH ("unknown")) {
   532          ;
   533        } else {
   534          SYNTAX (3220, curlex);
   535        }
   536      } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
   537        EXPR rec;
   538        rc = scan ("=");
   539        rc = scan (EXPECT_NONE);
   540        macro_depth = 0;
   541        express (&rec, INTEGER, 4);
   542      } else if (TOKEN ("fmt") && lookahead ("=")) {
   543        rc = scan ("=");
   544        rc = scan (EXPECT_NONE);
   545        if (TOKEN ("*")) {
   546          ;
   547        } else if (rc == INT_NUMBER) {
   548          ;
   549        } else if (rc == WORD) {
   550          EXPR fmt;
   551          macro_depth = 0;
   552          express (&fmt, NOTYPE, NOLEN);
   553          ;
   554        } else if (rc == TEXT) {
   555          (void) format_str (curlex);
   556        } else {
   557          SYNTAX (3221, curlex);
   558        }
   559      } else if (TOKEN ("end") && lookahead ("=")) {
   560        rc = scan ("=");
   561        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   562          LBL *L = find_relabel (curlex);
   563          replace_label (L->renum);
   564        } else {
   565          EXPECT (3222, "label");
   566        }
   567      } else if (TOKEN ("err") && lookahead ("=")) {
   568        rc = scan ("=");
   569        if ((rc = scan (EXPECT_LABEL)) == LABEL) {
   570          LBL *L = find_relabel (curlex);
   571          replace_label (L->renum);
   572        } else {
   573          EXPECT (3223, "label");
   574        }
   575      } else if (TOKEN ("iostat") && lookahead ("=")) {
   576        rc = scan ("=");
   577        rc = scan (EXPECT_NONE);
   578      } else {
   579        if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
   580          if (parm == 1 && rc == INT_NUMBER) {
   581            ;
   582          } else if (parm == 2 && TOKEN ("*")) {
   583            ;
   584          } else if (parm == 2 && rc == WORD) {
   585            EXPR fmt;
   586            macro_depth = 0;
   587            express (&fmt, NOTYPE, NOLEN);
   588          } else if (parm == 2 && rc == TEXT) {
   589            (void) format_str (curlex);
   590          } else if (parm == 2 && rc == INT_NUMBER) {
   591            LBL *L = find_relabel (curlex);
   592            replace_label (L->renum);
   593          } else if (parm == 3) {
   594            ;
   595          } else {
   596            SYNTAX (3224, curlex);
   597          }
   598        } else {
   599          if (parm == 1) {
   600            ;
   601          } else if (parm == 2 && TOKEN ("*")) {
   602            ;
   603          } else if (parm == 2 && rc == WORD) {
   604            EXPR fmt;
   605            macro_depth = 0;
   606            express (&fmt, NOTYPE, NOLEN);
   607          } else if (parm == 2 && rc == TEXT) {
   608            (void) format_str (curlex);
   609          } else if (parm == 2 && rc == INT_NUMBER) {
   610            LBL *L = find_relabel (curlex);
   611            replace_label (L->renum);
   612          } else {
   613            SYNTAX (3225, curlex);
   614          }
   615        }
   616      }
   617  // Next item.
   618      parm++;
   619      rc = scan (EXPECT_NONE); 
   620      if (TOKEN (",")) {
   621        rc = scan (EXPECT_NONE); 
   622      } else if (TOKEN (")")) {
   623        ;
   624      } else {
   625        SYNTAX (3226, curlex);
   626      }
   627    }
   628  }
   629  static LBL *relbl = NO_LABEL;
   630  
   631  void tidy_executable (void)
   632  {
   633    int_4 rc = curret;
   634    if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
   635      tidy_to_upper ();
   636      tidy_skip_card ();
   637    } else if (TOKEN ("continue") && IS_NOT_ASSIGNMENT) {
   638      tidy_to_upper ();
   639      tidy_skip_card ();
   640    } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
   641      tidy_to_upper ();
   642      tidy_jump ();
   643    } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
   644      tidy_to_upper ();
   645      tidy_skip_card ();
   646    } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
   647      tidy_to_upper ();
   648      tidy_skip_card ();
   649    } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
   650      ERROR (3227, "obsolete feature", "entry");
   651      tidy_skip_card ();
   652    } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
   653      tidy_to_upper ();
   654      tidy_skip_card ();
   655    } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
   656      tidy_io_specs ("open");
   657      tidy_skip_card ();
   658    } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
   659      tidy_io_specs ("close");
   660      tidy_skip_card ();
   661    } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
   662      tidy_io_specs ("endfile");
   663      tidy_skip_card ();
   664    } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
   665      tidy_io_specs ("backspace");
   666      tidy_skip_card ();
   667    } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
   668      tidy_io_specs ("rewind");
   669      tidy_skip_card ();
   670    } else if (TOKEN ("decode") && IS_NOT_ASSIGNMENT) {
   671      tidy_io_specs ("decode");
   672      tidy_skip_card ();
   673    } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
   674      tidy_io_specs ("encode");
   675      tidy_skip_card ();
   676    } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
   677      tidy_io_specs ("read");
   678      tidy_skip_card ();
   679    } else if (TOKEN ("accept") && IS_NOT_ASSIGNMENT) {
   680      tidy_io_specs ("accept");
   681      tidy_skip_card ();
   682    } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
   683      tidy_io_specs ("write");
   684      tidy_skip_card ();
   685    } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
   686      tidy_io_specs ("print");
   687      tidy_skip_card ();
   688    } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
   689      tidy_io_specs ("punch");
   690      tidy_skip_card ();
   691    } else if (rc == WORD) {
   692      SAVE_POS (1);
   693      rc = scan (EXPECT_NONE);
   694      if (rc == END_OF_LINE || rc == END_OF_MODULE) {
   695        RESTORE_POS (1);
   696        tidy_vif_extensions ();
   697      } else {
   698        UNSCAN;
   699        tidy_skip_card ();
   700      }
   701    }
   702  }
   703  
   704  void tidy_statements (LBL * dolbl, int_4 depth)
   705  {
   706    int_4 rc;
   707    while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
   708  // FORTRAN statements.
   709      if (rc == LABEL) {
   710        NEW_RECORD (str);
   711        relbl = find_relabel (curlex);
   712        if (relbl == NO_LABEL) {
   713          ERROR (3228, "no such label", curlex);
   714        }
   715        NEW_RECORD (rep);
   716        _srecordf (rep, "%5d", relbl->renum);
   717        for (int_4 k = 0; k < 5; k++) {
   718          CUR_LIN.text[k] = rep[k];
   719        }
   720        rc = scan (EXPECT_NONE);
   721        if (TOKEN ("continue")) {
   722          tidy_to_upper ();
   723          continue;               // Sic!
   724        }
   725      }
   726      if (rc == DECLAR) {
   727        tidy_to_upper ();
   728        tidy_skip_card ();
   729      } else if (TOKEN ("assign")) {
   730        tidy_to_upper ();
   731        rc = scan (EXPECT_LABEL);
   732        if (rc != LABEL) {
   733          SYNTAX (3229, "label expected");
   734        } else {
   735          LBL *L = find_relabel (curlex);
   736          replace_label (L->renum);
   737        }
   738        rc = scan (EXPECT_NONE);
   739        if (TOKEN ("to")) {
   740          tidy_to_upper ();
   741        }
   742        tidy_skip_card ();
   743      } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
   744        tidy_to_upper ();
   745        if (depth != 0) {
   746          SYNTAX (3230, "end must end a subprogram");
   747        }
   748        tidy_skip_card ();
   749        return;
   750      } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
   751        tidy_to_upper ();
   752        if (depth > 0) {
   753          return;
   754        } else {
   755          SYNTAX (3231, "stray symbol");
   756        }
   757      } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
   758        tidy_to_upper ();
   759        if (depth > 0) {
   760          return;
   761        } else {
   762          SYNTAX (3232, "stray symbol");
   763        }
   764      } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
   765        tidy_to_upper ();
   766        if (depth > 0) {
   767          return;
   768        } else {
   769          SYNTAX (3233, "stray symbol");
   770        }
   771      } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
   772        tidy_to_upper ();
   773        tidy_skip_card ();
   774      } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
   775        tidy_to_upper ();
   776        tidy_conditional (depth, TRUE);
   777      } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
   778        tidy_to_upper ();
   779        tidy_do_loop (dolbl, depth);
   780        tidy_skip_card ();
   781      } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
   782        tidy_to_upper ();
   783        if (dolbl != NO_LABEL) {
   784          ERROR (3234, "misplaced end do", NO_TEXT);
   785        }
   786        if (depth > 0) {
   787          return;
   788        } else {
   789          SYNTAX (3235, "stray symbol");
   790        }
   791      } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
   792        tidy_to_upper ();
   793        tidy_skip_card ();
   794      } else {
   795        tidy_executable ();
   796      }
   797  // Return for DO loop (ending label reached).
   798      if (dolbl != NO_LABEL && relbl != NO_LABEL && dolbl->num == relbl->num) {
   799        if (depth == 0) {
   800          BUG ("nesting");
   801        }
   802        return;
   803      }
   804    }
   805  }
   806  
   807  void write_tidy (char *name)
   808  {
   809  // Object code to file.
   810    FILE *obj;
   811    if ((obj = fopen (name, "w")) == NULL) {
   812      FATAL (3236, "cannot open for writing", name);
   813      exit (EXIT_FAILURE);
   814    };
   815    for (int_4 k = 1; k < nftnlines; k++) {
   816      fprintf (obj, "%s\n", source[k].text);
   817    }
   818    fclose (obj);
   819  }
   820  
   821  void tidy_source (char *modname)
   822  {
   823    tidy_prescan ();
   824    tidy_subprogram ();
   825    tidy_decls ();
   826    tidy_statements (NO_LABEL, 0);
   827  }
Deze website is gearchiveerd door de KB, nationale bibliotheek.

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