//! @file statements.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
//!
//! Compile statements.

#include <vif.h>

int_4 patch (int_4 where, char *str)
{
  if (where >= 0 && where < n_c_src) {
    C_SRC *lin = &object[where];
    if (str != NO_TEXT) {
      lin->text = f_stralloc (str);
    } else {
      lin->text = NO_TEXT;
    }
  } else {
    BUG ("patch");
  }
  return where;
}

void patch_args (void)
{
  for (int_4 k = 0; k < nlocals; k++) {
    IDENT *idf = &locals[k];
    if (idf->arg) {
      NEW_RECORD (str);
      if (idf->external) {
        _srecordf (str, "%s (*%s)()", wtype (&idf->mode, NOARG, FUN), edit_f (C_NAME (idf)));
      } else if (IS_SCALAR (idf->mode)) {
        _srecordf (str, "%s%s", wtype (&idf->mode, ARG, NOFUN), C_NAME (idf));
      } else {
        _srecordf (str, "%s _p_ %s", wtype (&idf->mode, NOARG, FUN), C_NAME (idf));
      }
      if (idf->patch1 != 0) {
        patch (idf->patch1, str);
      }
      if (idf->patch2 != 0) {
        patch (idf->patch2, str);
      }
    }
  }
}

//
// EXECUTABLE STATEMENTS
//

void vif_extensions(void)
{
  if (TOKEN ("exit")) {
    code (nprocs, BODY, "break;\n");
  } else if (TOKEN ("break")) {
    code (nprocs, BODY, "break;\n");
  } else if (TOKEN ("cycle")) {
// CYCLE
    code (nprocs, BODY, "continue;\n");
  } else {
    ERROR (3001, "syntax", curlex);
  }
  skip_card (FALSE);
}

void block_if (EXPR *reg, int_4 apatch, int_4 depth)
{
// Block IF.
  int_4 rc;
  skip_card (FALSE);
  NEW_RECORD (str);
  if (reg->mode.type != LOGICAL) {
    EXPECT (3002, "logical expression");
  }
  _srecordf (str, "if (%s) {\n", reg->str);
  patch (apatch, str);
  gen_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 (3003, "logical expression");
    }
    code (nprocs, BODY, "}\n");
    _srecordf (str, "else if (%s) {\n", reh.str);
    code (nprocs, BODY, str);
    gen_statements (NO_LABEL, depth + 1);
  }
  if (TOKEN ("else")) {
    skip_card (FALSE);
    code (nprocs, BODY, "}\n");
    code (nprocs, BODY, "else {\n");
    gen_statements (NO_LABEL, depth + 1);
  }
  if (TOKEN ("endif")) {
    skip_card (FALSE);
  } else {
    EXPECT (3004, "endif");
  }
  code (nprocs, BODY, "}\n");
  (void) rc;
}

void arith_if (EXPR *reg)
{
// Arithmetic IF.
  int_4 rc;
  NEW_RECORD (str);
  NEW_RECORD (tmp);
  NEW_RECORD (l1);
  NEW_RECORD (l2);
  NEW_RECORD (l3);
  LBL *lab1, *lab2, *lab3;
  IDENT *idf;
  int_4 N = 0;
// Gather the labels
  RECCPY (l1, curlex);
  lab1 = find_label (l1);
  if (lab1 == NO_LABEL) {
    ERROR (3005, "no such label", l1);
    return;
  }
  lab1->jumped++;
  rc = scan (",");
  rc = scan (EXPECT_NONE);
  if (rc != INT_NUMBER) {
    EXPECT (3006, "label");
    return;
  }
  RECCPY (l2, curlex);
  lab2 = find_label (l2);
  if (lab2 == NO_LABEL) {
    ERROR (3007, "no such label", l2);
    return;
  }
  lab2->jumped++;
  rc = scan (",");
  if (rc == END_OF_LINE) {
    N = 2;
  } else {
    N = 3;
    rc = scan (EXPECT_NONE);
    if (rc != INT_NUMBER) {
      EXPECT (3008, "label");
      return;
    }
    RECCPY (l3, curlex);
    lab3 = find_label (l3);
    if (lab3 == NO_LABEL) {
      ERROR (3009, "no such label", l3);
      return;
    }
    lab3->jumped++;
  }
  if (N == 3) {
// ANSI FORTRAN three-branch arithmetic statement.
    if (reg->mode.type != INTEGER && reg->mode.type != REAL) {
      EXPECT (3010, "integer or real expression");
    }
    _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    idf = add_local (tmp, reg->mode.type, reg->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    _srecordf (str, "%s = %s;\n", C_NAME (idf), reg->str);
    code (nprocs, BODY, str);
    _srecordf (str, "if (%s < 0) {\n", C_NAME (idf));
    code (nprocs, BODY, str);
    _srecordf (str, "goto _l%d;\n", lab1->num);
    code (nprocs, BODY, str);
    _srecordf (str, "}");
    code (nprocs, BODY, str);
    _srecordf (str, "else if (%s == 0) {\n", C_NAME (idf));
    code (nprocs, BODY, str);
    _srecordf (str, "goto _l%d;\n", lab2->num);
    code (nprocs, BODY, str);
    _srecordf (str, "}");
    code (nprocs, BODY, str);
    _srecordf (str, "else {\n");
    code (nprocs, BODY, str);
    _srecordf (str, "goto _l%d;\n", lab3->num);
    code (nprocs, BODY, str);
    _srecordf (str, "}\n");
    code (nprocs, BODY, str);
  } else {
// CRAY FORTRAN two-branch arithmetic statement.
    if (reg->mode.type != INTEGER && reg->mode.type != REAL && reg->mode.type != LOGICAL) {
      EXPECT (3011, "integer, real or logical expression");
    }
    if (reg->mode.type == INTEGER || reg->mode.type == REAL) {
      if (reg->variant == EXPR_VAR || reg->variant == EXPR_SLICE) {
        _srecordf (str, "if (%s != 0) {\n", reg->str);
      } else {
        _srecordf (str, "if ((%s) != 0) {\n", reg->str);
      }
    } else {
      if (reg->variant == EXPR_VAR || reg->variant == EXPR_SLICE) {
        _srecordf (str, "if (%s == TRUE) {\n", reg->str);
      } else {
        _srecordf (str, "if ((%s) == TRUE) {\n", reg->str);
      }
    }
    code (nprocs, BODY, str);
    _srecordf (str, "goto _l%d;\n", lab1->num);
    code (nprocs, BODY, str);
    _srecordf (str, "}");
    code (nprocs, BODY, str);
    _srecordf (str, "else {\n");
    code (nprocs, BODY, str);
    _srecordf (str, "goto _l%d;\n", lab2->num);
    code (nprocs, BODY, str);
    _srecordf (str, "}\n");
    code (nprocs, BODY, str);
  }
  skip_card (FALSE);
}

void conditional (int_4 depth, logical_4 block_allowed)
{
  int_4 rc = scan ("(");
  int_4 apatch = code (nprocs, BODY, NO_TEXT);
  EXPR reg;
  rc = scan (EXPECT_NONE);
  macro_depth = 0;
  express (&reg, NOTYPE, NOLEN);
  rc = scan (")");
  rc = scan (EXPECT_NONE);
  if (TOKEN ("then") && block_allowed) {
    block_if (&reg, apatch, depth);
  } else if (rc == INT_NUMBER) {
    arith_if (&reg);
  } else {
// Logical IF.
    NEW_RECORD (str);
    if (reg.mode.type != LOGICAL) {
      EXPECT (3012, "logical expression");
    }
    _srecordf (str, "if (%s) {\n", reg.str);
    patch (apatch, str);
    if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
      conditional (depth, FALSE);
    } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
      SYNTAX (3013, "invalid statement in logical IF");
    } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      SYNTAX (3014, "invalid statement in logical IF");
    } else {
      executable ();
    }
    code (nprocs, BODY, "}\n");
  }
}

void do_loop (LBL * curlbl, int_4 depth)
{
  int_4 rc;
  LBL *newlbl;
  EXPR lhs, from, to, by;
  NEW_RECORD (str);
  lhs.mode.type = NOTYPE;
  lhs.mode.len = 0;
  rc = scan (EXPECT_LABEL);
  if (rc != LABEL) {
    newlbl = NO_LABEL;
  } else {
    newlbl = find_label (curlex);
    if (newlbl == NO_LABEL) {
      ERROR (3015, "no such label", curlex);
      return;
    }
    if (curlbl != NO_LABEL && newlbl->line > curlbl->line) {
      ERROR (3016, "incorrect loop nesting", NO_TEXT);
      return;
    }
    rc = scan (EXPECT_NONE);
  }
  if (TOKEN ("repeat")) {
    skip_card (FALSE);
    code (nprocs, BODY, "do {\n");
    gen_statements (newlbl, depth + 1);
    code (nprocs, BODY, "} while (TRUE);\n");
  } else if (TOKEN ("while")) {
    rc = scan ("(");
    EXPR reg;
    rc = scan (EXPECT_NONE);
    macro_depth = 0;
    express (&reg, NOTYPE, NOLEN);
    rc = scan (")");
    skip_card (FALSE);
    if (reg.mode.type != LOGICAL) {
      EXPECT (3017, "logical expression");
    }
    _srecordf (str, "while (%s) {\n", reg.str);
    code (nprocs, BODY, str);
    gen_statements (newlbl, depth + 1);
    code (nprocs, BODY, "}\n");
  } else {
// DO 1, I = 1, 10, 2
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE);
    }
    if (rc != WORD) {
      EXPECT (3018, "variable");
    } else {
      impl_decl (curlex, NO_MODE);
      macro_depth = 0;
      express (&lhs, NOTYPE, NOLEN);
      if (lhs.variant != EXPR_VAR) {
        EXPECT (3019, "variable");
        return;
      }
    }
    rc = scan ("=");
    rc = scan (EXPECT_NONE);
    macro_depth = 0;
    express (&from, lhs.mode.type, lhs.mode.len);
    rc = scan (",");
    rc = scan (EXPECT_NONE);
    macro_depth = 0;
    express (&to, lhs.mode.type, lhs.mode.len);
    rc = scan (EXPECT_NONE);
    if (TOKEN (",")) {
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (&by, lhs.mode.type, lhs.mode.len);
    } else {
      UNSCAN;
      RECCPY (by.str, "1");
    }
    skip_card (TRUE);
    if (f4_do_loops) {
      _srecordf (str, "%s = %s;\n", lhs.str, from.str);
      code (nprocs, BODY, str);
      code (nprocs, BODY, "do {\n");
      gen_statements (newlbl, depth + 1);
      if (strcmp (by.str, "1") == 0) {
        _srecordf (str, "(%s)++;\n", lhs.str);
        code (nprocs, BODY, str);
        code (nprocs, BODY, "}\n");
        _srecordf (str, "while (%s <= %s);\n", lhs.str, to.str);
        code (nprocs, BODY, str);
      } else if (strcmp (by.str, "-1") == 0) {
        _srecordf (str, "(%s)--;\n", lhs.str);
        code (nprocs, BODY, str);
        code (nprocs, BODY, "}\n");
        _srecordf (str, "while (%s >= %s);\n", lhs.str, to.str);
        code (nprocs, BODY, str);
      } else {
        _srecordf (str, "%s += %s;\n", lhs.str, by.str);
        code (nprocs, BODY, str);
        code (nprocs, BODY, "}\n");
        _srecordf (str, "while (%s > 0 ? %s <= %s : %s >= %s);\n", by.str, lhs.str, to.str, lhs.str, to.str);
        code (nprocs, BODY, str);
      }
    } else {
      if (strcmp (by.str, "1") == 0) {
        _srecordf (str, "for (%s = %s; %s <= %s; (%s)++) {\n", lhs.str, from.str, lhs.str, to.str, lhs.str);
      } else if (strcmp (by.str, "-1") == 0) {
        _srecordf (str, "for (%s = %s; %s >= %s; (%s)--) {\n", lhs.str, from.str, lhs.str, to.str, lhs.str);
      } else {
        _srecordf (str, "for (%s = %s; (%s > 0 ? %s <= %s : %s >= %s); %s += %s) {\n", lhs.str, from.str, by.str, lhs.str, to.str, lhs.str, to.str, lhs.str, by.str);
      }
      code (nprocs, BODY, str);
      gen_statements (newlbl, depth + 1);
      code (nprocs, BODY, "}\n");
    }
  }
}

LBL *lbl = NO_LABEL;

void executable (void)
{
  int_4 rc = curret;
  if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
// CALL
    cpp_direct (nprocs, prelin, BODY);
    call ();
    code (nprocs, BODY, ";\n");
    skip_card (FALSE);
  } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
    cpp_direct (nprocs, prelin, BODY);
    vif_close ();
    skip_card (FALSE);
  } else if (TOKEN ("decode") && IS_NOT_ASSIGNMENT) {
// DECODE
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("decode", &nest);
    if (nest != 0) {
      ERROR (3020, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
// ENCODE
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("encode", &nest);
    if (nest != 0) {
      ERROR (3021, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
    cpp_direct (nprocs, prelin, BODY);
    vif_endfile ();
    skip_card (FALSE);
  } else if (TOKEN ("continue") && IS_NOT_ASSIGNMENT) {
// CONTINUE
    code (nprocs, BODY, ";\n");
    skip_card (FALSE);
  } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
// GOTO
    cpp_direct (nprocs, prelin, BODY);
    jump ();
  } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
    cpp_direct (nprocs, prelin, BODY);
    vif_open ();
    skip_card (FALSE);
  } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
// PAUSE
    NEW_RECORD (str);
    cpp_direct (nprocs, prelin, BODY);
    rc = scan (EXPECT_NONE);
    if (rc == INT_NUMBER) {
      sscanf (curlex, "%d", &rc);
      _srecordf (str, "printf (\"PAUSE: %d\\n.\");\n", rc);
    } else if (rc == TEXT && strlen (curlex) > 0) {
      curlex[strlen(curlex) - 1] = '\0';
      _srecordf (str, "printf (\"PAUSE: %s\\n.\");\n", &curlex[1]);
    } else {
      _srecordf (str, "printf (\"PAUSE\\n\");\n");
    }
    code (nprocs, BODY, str);
    code (nprocs, BODY, "(void) fgetc (stdin);\n");
    skip_card (FALSE);
  } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
// READ
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("read", &nest);
    if (nest != 0) {
      ERROR (3022, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("accept") && IS_NOT_ASSIGNMENT) {
// ACCEPT
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("accept", &nest);
    if (nest != 0) {
      ERROR (3023, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
// RETURN
    cpp_direct (nprocs, prelin, BODY);
    labels[0].jumped++;
    code (nprocs, BODY, RETURN);
    skip_card (FALSE);
//  ENTRY
  } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
    ERROR (3024, "obsolete feature", "entry");
    skip_card (FALSE);
  } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
// BACKSPACE
    cpp_direct (nprocs, prelin, BODY);
    vif_backspace ();
    skip_card (FALSE);
  } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
// REWIND
    cpp_direct (nprocs, prelin, BODY);
    vif_rewind ();
    skip_card (FALSE);
  } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
// STOP 
    NEW_RECORD (str);
    cpp_direct (nprocs, prelin, BODY);
    rc = scan (EXPECT_NONE);
    if (rc == INT_NUMBER) {
      sscanf (curlex, "%d", &rc);
      _srecordf (str, "exit (%d);\n", rc);
    } else {
      _srecordf (str, "exit (EXIT_SUCCESS);\n");
    }
    code (nprocs, BODY, str);
    skip_card (FALSE);
  } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
// WRITE
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("write", &nest);
    if (nest != 0) {
      ERROR (3025, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
// PRINT
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("print", &nest);
    if (nest != 0) {
      ERROR (3026, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
// PUNCH
    int_4 nest = 0;
    cpp_direct (nprocs, prelin, BODY);
    do_io ("punch", &nest);
    if (nest != 0) {
      ERROR (3027, "unbalanced parentheses", NO_TEXT);
    }
    skip_card (FALSE);
  } else if (rc == WORD) {
// Single-word extensions EXIT, CYCLE, BREAK, etcetera.
    SAVE_POS (1);
    rc = scan (EXPECT_NONE);
    if (rc == END_OF_LINE || rc == END_OF_MODULE) {
      RESTORE_POS (1);
      // RECCPY (curlex, prelex);
      vif_extensions ();
    } else {
      UNSCAN;
// Primary - Assignation or call
      EXPR reg;
      MODE mode;
      cpp_direct (nprocs, prelin, BODY);
      (void) impl_decl (curlex, &mode);
      memset (&reg, 0, sizeof (EXPR));
      assign (&reg);
      code (nprocs, BODY, reg.str);
      code (nprocs, BODY, ";\n");
      skip_card (FALSE);
    }
  }
}

void gen_statements (LBL * dolbl, int_4 depth)
{
  int_4 rc;
  while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
    macro_depth = 0;
// Common mistakes.
    if (TOKEN ("program") && IS_NOT_ASSIGNMENT) {
      ERROR (3028, "check for missing END statement", NO_TEXT);
    } else if (TOKEN ("function") && IS_NOT_ASSIGNMENT) {
      ERROR (3029, "check for missing END statement", NO_TEXT);
    } else if (TOKEN ("subroutine") && IS_NOT_ASSIGNMENT) {
      ERROR (3030, "check for missing END statement", NO_TEXT);
    } else if (TOKEN ("block") && IS_NOT_ASSIGNMENT) {
      ERROR (3031, "check for missing END statement", NO_TEXT);
    }
// FORTRAN statements.
    LBL *statlbl = NO_LABEL;
    if (rc == LABEL) {
      NEW_RECORD (str);
      statlbl = lbl = find_label (curlex);
      if (lbl == NO_LABEL) {
        ERROR (3032, "no such label", curlex);
      } else {
        _srecordf (str, "_l%d:;\n", lbl->num);
        lbl->patch = code (nprocs, BODY, str);
      }
      rc = scan (EXPECT_NONE);
      if (TOKEN ("continue")) {
        continue;               // Sic!
      }
    }
    _srecordf (stat_start, "%s:%s:%d", libnam, modnam, CUR_LIN.num);
    if (rc == DECLAR) {
      ERROR (3033, "declaration amidst executable statements", NO_TEXT);
    } else if (TOKEN ("assign")) {
// ASSIGN statement, from before the Chicxulub impact.
// Relic from when computers had no way to organize subroutine calls.
      rc = scan (EXPECT_LABEL);
      if (rc != LABEL) {
        SYNTAX (3034, "label expected");
      } else {
        LBL *slbl = find_label (curlex);
        if (slbl == NO_LABEL) {
          ERROR (3035, "no such label", NO_TEXT);
        }
        rc = scan ("to");
        EXPR reg;
        rc = scan (EXPECT_NONE);
        macro_depth = 0;
        express (&reg, INTEGER, 4);
        NEW_RECORD (str);
        _srecordf (str, "%s = %d;\n", reg.str, slbl->index);
        code (nprocs, BODY, str);
      }
      skip_card (FALSE);
    } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
      skip_card (FALSE);
      end_statements++;
// END is not executable.
      NEW_RECORD (str);
      if (depth != 0) {
        SYNTAX (3036, "end must end a subprogram");
        abend = TRUE;
      }
// Peephole optimisation, END following RETURN which is typical.
      if (n_c_src > 0) {
        C_SRC *lin = &object[n_c_src - 1];
        if (EQUAL (lin->text, RETURN)) {
          lin->text = NO_TEXT;
          labels[0].jumped--;
        }
      }
// Return.
      labels[0].patch = code (nprocs, BODY, "_l0:;\n");
      _srecordf (str, "__calls[%d].calls++;\n", nprocs - 1);
      code (nprocs, BODY, str);
      if (func) {
        _srecordf (str, "return %s;\n", retnam);
      } else {
        _srecordf (str, "return 0;\n");
      }
      cpp_direct (nprocs, prelin, BODY);
      code (nprocs, BODY, str);
      return;
    } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3037, "stray symbol");
      }
    } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3038, "stray symbol");
      }
    } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3039, "stray symbol");
      }
    } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
      NEW_RECORD (str);
      rc = scan ("(");
      EXPR reg;
      rc = scan (EXPECT_NONE);
      macro_depth = 0;
      express (&reg, NOTYPE, NOLEN);
      rc = scan (")");
      if (reg.mode.type != LOGICAL) {
        EXPECT (3040, "logical expression");
      }
      _srecordf (str, "if (%s) {\n", reg.str);
      code (nprocs, BODY, str);
      _srecordf (str, "break;\n");
      code (nprocs, BODY, str);
      _srecordf (str, "}\n");
      code (nprocs, BODY, str);
      skip_card (FALSE);
    } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
      cpp_direct (nprocs, prelin, BODY);
      conditional (depth, TRUE);
    } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
      // DO
      cpp_direct (nprocs, prelin, BODY);
      do_loop (dolbl, depth);
      skip_card (FALSE);
    } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
      if (dolbl != NO_LABEL) {
        ERROR (3041, "misplaced end do", NO_TEXT);
      }
      if (depth > 0) {
        return;
      } else {
        SYNTAX (3042, "stray symbol");
      }
    } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
      cpp_direct (nprocs, prelin, FMT);
      format (statlbl);
      skip_card (FALSE);
    } else {
      executable ();
    }
// Return for DO loop (ending label reached).
    if (dolbl != NO_LABEL && lbl != NO_LABEL && dolbl->num == lbl->num) {
      if (depth == 0) {
        BUG ("nesting");
      }
      return;
    }
  }
}
