//! @file yidy.c
//! @author J. Marcel van der Veer
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful, but 
// WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
// or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
// more details. You should have received a copy of the GNU General Public 
// License along with this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Vintage Fortran tidying tool.

#include <vif.h>

#define ALLOW_ANON (nprocs >= 0)

void tidy_executable (void);
void tidy_statements (LBL *, int_4);

void tidy_to_upper (void)
{
// Make uppercase, backwards.
  if (tidy) {
    char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
    while (*p != '\0') {
      if (isspace (*q)) {
        q--;
      } else {
        *q = toupper (*q);
        q--;
        p++;
      }
    }
  }
}

void tidy_to_lower (void)
{
// Make lowercase, backwards.
  if (tidy) {
    char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
    while (*p != '\0') {
      if (isspace (*q)) {
	q--;
      } else {
	*q = tolower (*q);
	q--;
	p++;
      }
    }
  }
}

void tidy_skip_card (void)
{
  if (prelin == curlin) {
    int_4 rc;
    do {
      rc = scan (EXPECT_NONE);
    }
    while (rc != END_OF_LINE && rc != END_OF_MODULE);
  } else if (CUR_LIN.text == NO_TEXT) {
    return;
  } else if (strlen (CUR_LIN.text) >= 6 && POS(5) != ' ') {
    int_4 rc;
    do {
      rc = scan (EXPECT_NONE);
    }
    while (rc != END_OF_LINE && rc != END_OF_MODULE);
  }
}

LBL *find_relabel (char *lab)
{
  int_4 k, num;
  sscanf (lab, "%d", &num);
  for (k = 0; k < nlabels; k++) {
    LBL *L = &labels[k];
    if (num == L->num) {
      return L;
    }
  }
  FATAL (3201, "no such label", curlex);
}

void replace_label (int_4 label)
{
  NEW_RECORD (repl);
  _srecordf (repl, "%d", label);
  int_4 len_orig = strlen (curlex), len_repl = strlen (repl);
  int_4 delta = len_repl - len_orig;
  char *p = CUR_LIN.text;
  if ((strlen (p) + delta) > RECLN) {
    FATAL (3202, "cannot replace label", NO_TEXT);
  }
  NEW_RECORD (sub);
  RECCPY (sub, p);
  int_4 k = 0;
// Recalibrate current position.
  while (curcol >= 0 && !isdigit (CUR_COL)) {
    curcol--;
  }
  curcol++;
//
  for (; k < curcol - len_orig; k++) {
    p[k] = sub[k];
  }
  for (int_4 n = 0; repl[n] != '\0'; n++, k++) {
    p[k] = repl[n];
  }
  for (int_4 n = curcol; sub[n] != '\0'; n++, k++) {
    p[k] = sub[n];
  }
  for (; sub[k] != '\0'; k++) {
    p[k] = '\0';
  }
  CUR_LIN.len += delta;
  curcol += delta;
}

void tidy_prescan (void)
{
  SAVE_POS (1);
  int_4 rc, go_on = TRUE;
  while (go_on) {
    rc = scan (EXPECT_NONE);
    if (rc == END_OF_MODULE) {
      go_on = FALSE;
    }
    if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      go_on = FALSE;
    } else if (rc != TEXT) {
      tidy_to_lower ();
    }
  }
  RESTORE_POS (1);
}

void tidy_subprogram (void)
{
  SAVE_POS (1);
  int_4 rc = scan (EXPECT_NONE);
  if (rc == WORD) {
    if (TOKEN ("program")) {
      tidy_to_upper ();
      tidy_skip_card ();
      return;
    } else if (TOKEN ("subroutine")) {
      tidy_to_upper ();
      tidy_skip_card ();
      return;
    } else if (TOKEN ("block")) {
      tidy_to_upper ();
      rc = scan (EXPECT_NONE);
      if (TOKEN ("data")) {
        tidy_to_upper ();
      }
      tidy_skip_card ();
      return;
    } else if (TOKEN ("function")) {
      tidy_to_upper ();
      tidy_skip_card ();
      return;
    } else {
      if (ALLOW_ANON) {
        tidy_skip_card ();
      }
    }
  } else if (rc == DECLAR) {
    tidy_to_upper ();
    tidy_subprogram ();
  }
  RESTORE_POS (1);
}

static void tidy_decls (void)
{
  int_4 go_on = TRUE;
  while (go_on) {
    SAVE_POS (1);
    int_4 rc = scan (EXPECT_NONE);
    if (rc == DECLAR) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      rc = scan (EXPECT_NONE);
      if (rc == DECLAR) {
        tidy_to_upper ();
      }
      tidy_skip_card ();
    } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (rc == WORD && IS_MACRO_DECLARATION) {
      tidy_skip_card ();
    } else if (strlen (curlex) > 0) {
// Backspace and done.
      RESTORE_POS (1);
      go_on = FALSE;
    }
  }
}

void tidy_vif_extensions(void)
{
  if (TOKEN ("exit")) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("break")) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("cycle")) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else {
    ERROR (3203, "syntax", curlex);
    tidy_skip_card ();
  }
}

void tidy_jump (void)
{
  int_4 rc = scan (EXPECT_LABEL);
  if (rc == LABEL) {
// GOTO label
    LBL *L = find_relabel (curlex);
    replace_label (L->renum);
    tidy_skip_card ();
  } else if (TOKEN ("(")) {
// GOTO (...), expr
    rc = scan (EXPECT_LABEL);
    while (rc == LABEL) {
      LBL *L = find_relabel (curlex);
      replace_label (L->renum);
      rc = scan (EXPECT_NONE);
      if (TOKEN (",")) {
        rc = scan (EXPECT_LABEL);
      }
    };
    CHECKPOINT (3204, ")");
    tidy_skip_card ();
  } else if (rc == WORD) {
// GOTO idf [, (...)]
    IDENT *idf = find_local (curlex, NO_MODE);
    if (idf == NO_IDENT ) {
      return;
    }
    if (idf->mode.type != INTEGER) {
      EXPECT (3205, "integer variable");
    }
    EXPR var; MODE mode;
    var.str[0] = '\0';
    factor_variable (&var, idf, &mode, curlex);
    rc = scan (EXPECT_NONE);
    if (TOKEN (",") || TOKEN ("(")) {
  // Emit indicated labels.
      if (TOKEN (",")) {
        rc = scan (EXPECT_NONE);
      }
      CHECKPOINT (3206, "(");
      rc = scan (EXPECT_LABEL);
      while (rc == LABEL) {
        LBL *L = find_relabel (curlex);
        replace_label (L->renum);
        rc = scan (EXPECT_LABEL);
        if (TOKEN (",")) {
          rc = scan (EXPECT_LABEL);
        }
      }
      CHECKPOINT (3207, ")");
      tidy_skip_card ();
    } else {
    // Default, emit all labels.
      tidy_skip_card ();
    }
  }
}

void tidy_block_if (EXPR *reg, int_4 depth)
{
// Block IF.
  int_4 rc;
  tidy_skip_card ();
  NEW_RECORD (str);
  if (reg->mode.type != LOGICAL) {
    EXPECT (3208, "logical expression");
  }
  tidy_statements (NO_LABEL, depth + 1);
  while (TOKEN ("elseif")) {
    EXPR reh;
    rc = scan ("(");
    rc = scan (EXPECT_NONE);
    macro_depth = 0;
    express (&reh, NOTYPE, NOLEN);
    rc = scan (")");
    rc = scan ("THEN");
    if (reh.mode.type != LOGICAL) {
      EXPECT (3209, "logical expression");
    }
    tidy_statements (NO_LABEL, depth + 1);
  }
  if (TOKEN ("else")) {
    tidy_skip_card ();
    tidy_statements (NO_LABEL, depth + 1);
  }
  if (TOKEN ("endif")) {
    tidy_skip_card ();
  } else {
    EXPECT (3210, "endif");
  }
  (void) rc;
}

void tidy_arith_if (EXPR *reg)
{
// Arithmetic IF.
  int_4 rc;
  NEW_RECORD (str);
  NEW_RECORD (tmp);
  LBL *L;
// Gather the labels
  L = find_relabel (curlex);
  replace_label (L->renum);
  rc = scan (",");
  rc = scan (EXPECT_NONE);
  if (rc != INT_NUMBER) {
    EXPECT (3211, "label");
    return;
  }
  L = find_relabel (curlex);
  replace_label (L->renum);
  rc = scan (",");
  if (rc == END_OF_LINE) {
  // CRAY FORTRAN two-branch arithmetic statement.
    ;
  } else {
  // ANSI FORTRAN three-branch arithmetic statement.
    rc = scan (EXPECT_NONE);
    if (rc != INT_NUMBER) {
      EXPECT (3212, "label");
      return;
    }
    L = find_relabel (curlex);
    replace_label (L->renum);
  }
  tidy_skip_card ();
}

void tidy_conditional (int_4 depth, logical_4 block_allowed)
{
  int_4 rc = scan ("(");
  EXPR reg;
  rc = scan (EXPECT_NONE);
  macro_depth = 0;
  express (&reg, NOTYPE, NOLEN);
  rc = scan (")");
  rc = scan (EXPECT_NONE);
  if (TOKEN ("then") && block_allowed) {
    tidy_to_upper ();
    tidy_block_if (&reg, depth);
  } else if (rc == INT_NUMBER) {
    tidy_arith_if (&reg);
  } else {
// Logical IF.
    NEW_RECORD (str);
    if (reg.mode.type != LOGICAL) {
      EXPECT (3213, "logical expression");
    }
    _srecordf (str, "if (%s) {\n", reg.str);
    if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_conditional (depth, FALSE);
    } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
      SYNTAX (3214, "invalid statement in logical IF");
    } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      SYNTAX (3215, "invalid statement in logical IF");
    } else {
      tidy_executable ();
    }
  }
}

void tidy_do_loop (LBL * curlbl, int_4 depth)
{
  LBL *L;
  NEW_RECORD (str);
  int_4 rc = scan (EXPECT_LABEL);
  if (rc != LABEL) {
    L = NO_LABEL;
  } else {
    L = find_relabel (curlex);
    replace_label (L->renum);
    if (curlbl != NO_LABEL && L->line > curlbl->line) {
      ERROR (3216, "incorrect loop nesting", NO_TEXT);
      return;
    }
    rc = scan (EXPECT_NONE);
  }
  if (TOKEN ("repeat")) {
    tidy_to_upper ();
    tidy_skip_card ();
    tidy_statements (L, depth + 1);
  } else if (TOKEN ("while")) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else {
    tidy_skip_card ();
    tidy_statements (L, depth + 1);
  }
}

static void tidy_io_specs (char *proc)
{
  int_4 rc, parm = 1;
// We accept that only a unit specification follows.
  if (curret == INT_NUMBER) {
    if (EQUAL (proc, "print")) {
      LBL *L = find_relabel (curlex);
      replace_label (L->renum);
      return;
    }
    if (EQUAL (proc, "accept")) {
      LBL *L = find_relabel (curlex);
      replace_label (L->renum);
      return;
    }
  }
  if (curret == WORD) {
    return;
  }
  if (TOKEN ("(")) {
    rc = scan (EXPECT_NONE); 
  } else {
    EXPECT (3217, "(");
    return;
  }
//
  while (!TOKEN (")") && rc != END_OF_MODULE) {
// ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str |  DISP=str |  END=n | ERR=n])
    if (TOKEN ("unit") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
    } else if (TOKEN ("rec") && lookahead ("=")) {
      EXPR rec;
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (&rec, INTEGER, 4);
    } else if (TOKEN ("file") && lookahead ("=")) {
      EXPR reg;
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      if (express (&reg, CHARACTER, NOLEN)) {
        ;
      }
    } else if (TOKEN ("form") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("formatted")) {
        ;
      } else if (MATCH ("unformatted")) {
        ;
      } else {
        SYNTAX (3218, curlex);
      }
    } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("read")) {
        ;
      } else if (MATCH ("write")) {
        ;
      } else if (MATCH ("readwrite")) {
        ;
      } else if (MATCH ("direct")) {
        ;
      } else {
        SYNTAX (3219, curlex);
      }
    } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
// Straight from JCL :-)
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (MATCH ("old")) {
        ;
      } else if (MATCH ("new")) {
        ;
      } else if (MATCH ("keep")) {
        ;
      } else if (MATCH ("delete")) {
        ;
      } else if (MATCH ("unknown")) {
        ;
      } else {
        SYNTAX (3220, curlex);
      }
    } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
      EXPR rec;
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (&rec, INTEGER, 4);
    } else if (TOKEN ("fmt") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
      if (TOKEN ("*")) {
        ;
      } else if (rc == INT_NUMBER) {
        ;
      } else if (rc == WORD) {
        EXPR fmt;
        macro_depth = 0;
        express (&fmt, NOTYPE, NOLEN);
        ;
      } else if (rc == TEXT) {
        (void) format_str (curlex);
      } else {
        SYNTAX (3221, curlex);
      }
    } else if (TOKEN ("end") && lookahead ("=")) {
      rc = scan ("=");
      if ((rc = scan (EXPECT_LABEL)) == LABEL) {
        LBL *L = find_relabel (curlex);
        replace_label (L->renum);
      } else {
        EXPECT (3222, "label");
      }
    } else if (TOKEN ("err") && lookahead ("=")) {
      rc = scan ("=");
      if ((rc = scan (EXPECT_LABEL)) == LABEL) {
        LBL *L = find_relabel (curlex);
        replace_label (L->renum);
      } else {
        EXPECT (3223, "label");
      }
    } else if (TOKEN ("iostat") && lookahead ("=")) {
      rc = scan ("=");
      rc = scan (EXPECT_NONE);
    } else {
      if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
        if (parm == 1 && rc == INT_NUMBER) {
          ;
        } else if (parm == 2 && TOKEN ("*")) {
          ;
        } else if (parm == 2 && rc == WORD) {
          EXPR fmt;
          macro_depth = 0;
          express (&fmt, NOTYPE, NOLEN);
        } else if (parm == 2 && rc == TEXT) {
          (void) format_str (curlex);
        } else if (parm == 2 && rc == INT_NUMBER) {
          LBL *L = find_relabel (curlex);
          replace_label (L->renum);
        } else if (parm == 3) {
          ;
        } else {
          SYNTAX (3224, curlex);
        }
      } else {
        if (parm == 1) {
          ;
        } else if (parm == 2 && TOKEN ("*")) {
          ;
        } else if (parm == 2 && rc == WORD) {
          EXPR fmt;
          macro_depth = 0;
          express (&fmt, NOTYPE, NOLEN);
        } else if (parm == 2 && rc == TEXT) {
          (void) format_str (curlex);
        } else if (parm == 2 && rc == INT_NUMBER) {
          LBL *L = find_relabel (curlex);
          replace_label (L->renum);
        } else {
          SYNTAX (3225, curlex);
        }
      }
    }
// Next item.
    parm++;
    rc = scan (EXPECT_NONE); 
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE); 
    } else if (TOKEN (")")) {
      ;
    } else {
      SYNTAX (3226, curlex);
    }
  }
}
static LBL *relbl = NO_LABEL;

void tidy_executable (void)
{
  int_4 rc = curret;
  if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("continue") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_jump ();
  } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
    ERROR (3227, "obsolete feature", "entry");
    tidy_skip_card ();
  } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
    tidy_to_upper ();
    tidy_skip_card ();
  } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("open");
    tidy_skip_card ();
  } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("close");
    tidy_skip_card ();
  } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("endfile");
    tidy_skip_card ();
  } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("backspace");
    tidy_skip_card ();
  } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("rewind");
    tidy_skip_card ();
  } else if (TOKEN ("decode") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("decode");
    tidy_skip_card ();
  } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("encode");
    tidy_skip_card ();
  } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("read");
    tidy_skip_card ();
  } else if (TOKEN ("accept") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("accept");
    tidy_skip_card ();
  } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("write");
    tidy_skip_card ();
  } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("print");
    tidy_skip_card ();
  } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
    tidy_io_specs ("punch");
    tidy_skip_card ();
  } else if (rc == WORD) {
    SAVE_POS (1);
    rc = scan (EXPECT_NONE);
    if (rc == END_OF_LINE || rc == END_OF_MODULE) {
      RESTORE_POS (1);
      tidy_vif_extensions ();
    } else {
      UNSCAN;
      tidy_skip_card ();
    }
  }
}

void tidy_statements (LBL * dolbl, int_4 depth)
{
  int_4 rc;
  while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
// FORTRAN statements.
    if (rc == LABEL) {
      NEW_RECORD (str);
      relbl = find_relabel (curlex);
      if (relbl == NO_LABEL) {
        ERROR (3228, "no such label", curlex);
      }
      NEW_RECORD (rep);
      _srecordf (rep, "%5d", relbl->renum);
      for (int_4 k = 0; k < 5; k++) {
        CUR_LIN.text[k] = rep[k];
      }
      rc = scan (EXPECT_NONE);
      if (TOKEN ("continue")) {
        tidy_to_upper ();
        continue;               // Sic!
      }
    }
    if (rc == DECLAR) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("assign")) {
      tidy_to_upper ();
      rc = scan (EXPECT_LABEL);
      if (rc != LABEL) {
        SYNTAX (3229, "label expected");
      } else {
        LBL *L = find_relabel (curlex);
        replace_label (L->renum);
      }
      rc = scan (EXPECT_NONE);
      if (TOKEN ("to")) {
        tidy_to_upper ();
      }
      tidy_skip_card ();
    } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      if (depth != 0) {
        SYNTAX (3230, "end must end a subprogram");
      }
      tidy_skip_card ();
      return;
    } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3231, "stray symbol");
      }
    } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3232, "stray symbol");
      }
    } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3233, "stray symbol");
      }
    } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_conditional (depth, TRUE);
    } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_do_loop (dolbl, depth);
      tidy_skip_card ();
    } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      if (dolbl != NO_LABEL) {
        ERROR (3234, "misplaced end do", NO_TEXT);
      }
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3235, "stray symbol");
      }
    } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
      tidy_to_upper ();
      tidy_skip_card ();
    } else {
      tidy_executable ();
    }
// Return for DO loop (ending label reached).
    if (dolbl != NO_LABEL && relbl != NO_LABEL && dolbl->num == relbl->num) {
      if (depth == 0) {
        BUG ("nesting");
      }
      return;
    }
  }
}

void write_tidy (char *name)
{
// Object code to file.
  FILE *obj;
  if ((obj = fopen (name, "w")) == NULL) {
    FATAL (3236, "cannot open for writing", name);
    exit (EXIT_FAILURE);
  };
  for (int_4 k = 1; k < nftnlines; k++) {
    fprintf (obj, "%s\n", source[k].text);
  }
  fclose (obj);
}

void tidy_source (char *modname)
{
  tidy_prescan ();
  tidy_subprogram ();
  tidy_decls ();
  tidy_statements (NO_LABEL, 0);
}
