static char *rcs_version = "pass1-flat.c V$Revision: 1.24 $";
#define  _POSIX_C_SOURCE 200809L
#define _XOPEN_SOURCE 500
#include <string.h>

#include "imptoc.h"

extern char *fullpath(char *filename);

// IMP77 compiler first pass.  The comments are mostly from Andy Davis and John McMullin.
// This was 99% automatically translated from Imp77 to C by my imptoc code, with some
// manual tweaks for a few constructs my translator doesn't handle yet.  I've edited the
// source to make the formatting match the original Imp version, to make comparisons easier.

// The original translation of the Imp source used the GCC extension of
// nested procedures.  I have now edited it (non trivially, took a day!)
// to flatten those and compare the output to the other version, and at
// least when compiling the imp compiler, the icode output matches.

// However the source is not yet 100% portable because it still uses GCC's
// extension to allow arrays of labels, for the translated %switch statements.
// These too can be converted into portable C, but that's for another day.
// It will require a case statement to be generated where each case jumps
// to the same label that the jump table was jumping to! (The i2c code is
// now structured such that doing so should be easier.)

// (TO DO: looks like '%c' continuation might not be working properly.  Check it.)
// (later note: trailing spaces and comments may always have been problematic.)

// I've modified this to support nested %include files.  It was only after making
// the changes that I discovered that  pass1-v918.imp  had already made the same
// extension to the language.  (that revision also added the "%from ... %include" syntax.)

// I added: op('`', tag[x].index) to define the default switch label rather than
// allowing pass1 to output all the *currently* undefined switch labels and then
// messing things up by allowing some of those switch labels to follow later.
// That may work with a Robertson pass2 but this i2c translator is one-pass and
// sequential, so I can't go back and undo wrongly-defined default switch entries :-(

// I modified: op('O') to add the filename as well as the line number to get better
// error reporting and listing files.

// Other than those 3 features this is very much a standard Robertson Pass1.


// ############################################################
// # This program is a Copyright work.                        #
// #                                                          #
// # Over the last 40+ years a long and distinguished list of #
// # institutions, individuals and other entities have made   #
// # contributions to portions of this program and may have a #
// # reasonable claim over rights to certain parts of the     #
// # program.                                                 #
// #                                                          #
// # This version is therefore provided for education and     #
// # demonstration purposes only                              #
// ############################################################

// Apologies to Peter Robertson for the statement above by ABD -
// I'll get with you soon to replace it with a more appropriate
// copyright.  I'm well aware that pass1 is 99% your work with
// only minor tweaks from others (and early inspiration from Hamish)

#include <stdio.h>
#include <stdlib.h>
#include <signal.h>
#include <setjmp.h>
#include <stdarg.h>

// imp to c support:
#include "impsig.h"  // Support equivalents for %on %event n,n,n %start, and %signal %event n,n,n
                     // Once tested this will migrate into imptoc.h
static int trace_depth = 0;

void imp_trace_enter(int line, char *file, char *funcname) {
  for (int i = trace_depth; i > 0; i--) fputc(' ', stderr);
  fprintf(stderr, "\"%s\", %d: > %s\n", file, line, funcname);
  trace_depth += 1;
}

void imp_trace_exit(int line, char *file, const char *funcname) {
  trace_depth -= 1;
  for (int i = trace_depth; i > 0; i--) fputc(' ', stderr);
  fprintf(stderr, "\"%s\", %d: < %s\n", file, line, funcname);
}

// pass1.imp:

static const char *version = "8.4";

// configuration parameters

// #define minusone (0xFFFF)
#define minusone (-1)

// Wee change needed to cross-compile the compiler when going from 16 bit to 32 bit world
// %owninteger minus one = 16_7fff;   // You know, that was wrong too - should have been 16_ffff ...
#define maxint ((((unsigned int)minusone) >> 1) / 10)
#define maxdig ((((unsigned int)minusone) >> 1) - (maxint * 10))
enum { bytesize = 8 };                  // bits per byte
//#define maxtag 800                      // max no. of tags
#define maxtag 8000                      // max no. of tags
enum { maxdict = 10000 };                // max extent of dictionary  (was 6000. changed to 10000 by GTOAL on 20260316)
#define namebits 11                     // size of name table as a power of two
#define maxnames ((1 << namebits) - 1)  // table limit (a mask, eg 255)
static int sparenames = maxnames;
//enum { litmax = 50 };    // max no. of constants/stat.
enum { litmax = 500 };    // max no. of constants/stat.
enum { recsize = 520 };  // size of analysis record
enum { dimlimit = 6 };   // maximum array dimension

// symbols
const int ff = 12;
#define nl 10             // form feed
const int marker = '^';   // marker for faults
const int squote = '"';   // string quote
const int cquote = '\'';  // character quote (= 39 would be safer given current bug in imp2c)

// streams
const int report = 0 /*, source = 1*/;
#define PERM 1
#define SOURCE 2   // GTOAL: source changed from 1 to 2 to support nested include files
const int object = 1, listing = 2;

// types
const int integer = 1;
const int real = 2;
const int stringv = 3;
const int record = 4;

// forms
#define iform ((integer << 4) + 1)
const int var = 91;
const int _const_ = 93;
const int swit = 105;
const int comment = 22;
const int termin = 20;
const int lab = 3;
const int jump = 54;
const int recfm = 4;
const int proc = 7;  // class for proc

// phrase entries
const int escdec = 252;
const int escproc = 253;
const int escarray = 254;
const int escrec = 255;

// %recordformat arfm(%shortinteger class,sub,link,ptype,papp,pformat,x,pos);!imp77:
typedef struct arfm {
  int class, sub, link, ptype, papp, pformat, x, pos;
} arfm;

typedef struct tagfm {
  int app, format;
  int flags, index, text, link;
} tagfm;

// flags
// *===.===.===.===.===.====.====.====.===.======.======*
// ! u ! c ! c ! p ! s ! a  ! o ! pr ! s ! type ! form !
// ! 1 ! 1 ! 1 ! 1 ! 1 ! 1  ! 1 ! 1  ! 1 !  3   !  4   !
// *===^===^===^===^===^====^====^====^===^======^======*
//   u   c   c   p   s   a    o   p    s    t      f
//   s   l   o   a   u   n    w   r    p    y      o
//   e   o   n   r   b   a    n   o    e    p      r
//   d   s   s   a   n   m        t    c    e      m
//       e   t   m   a   e
//       d   s       m
//                   e
//
//

enum { usedbit = 0b1000000000000000 };
enum { closed = 0b0100000000000000 };
enum { constbit = 0b0010000000000000 };
enum { parameters = 0b0001000000000000 };
enum { subname = 0b0000100000000000 };
enum { aname = 0b0000010000000000 };
enum { ownbit = 0b0000001000000000 };
enum { prot = 0b0000000100000000 };
enum { spec = 0b0000000010000000 };

enum { transbit = 0x4000 };
enum { error = 0x8000 };

arfm ar[recsize + 1];  // (1:recsize) - Rebased to 0 rather than 1 for efficiency

// I turned a few of these back into shorts to see if that fixed
// the problem with keywords not being recognised.  It didn't,
// though it did fix the diagnostic printing of Atom1 which
// should be 0x8000 - -32768...

static int class = 0;    // class of atom wanted
static int x = 0;        // usually last tag
static int atom1 = 0;    // atom classproc (major)
static int atom2 = 0;    // atom classproc (minor)
static int subatom = 0;  // extra info about atom
static int type = 0;
static int app = 0;
static int format = 0;  // atom info
static int hashvalue;
static int faulty = 0;     // fault indicator
static int faultrate = 0;  // fault rate count
static int lines = 0;      // current line number
static int textline = 0;   // starting line for string const
static int margin = 0;     // statement start margin
static int errormargin = 0;
static int errorsym = 0;
static int column = 0;
static int stats = 0;    // statements compiled
static int monpos = 0;   // flag for diagnose
static int sym = nl;     // current input symbol
static int symtype = 0;  // type of current symbol
static int quote = 0;    // >0 strings, <0 chars
static int endmark = 0;  // %end flag
static int cont = ' ';
static int csym = ' ';  // listing continuation marker
static int decl = 0;    // current declarator flags
static int dim = 0;     // arrayname dimension
static int specgiven = 0;

static int escapeclass = 0;  // when and where to escape
static int protection = 0;
static int atomflags = 0;
static int otype = 0;    // current 'own' type
static int realsln = 1;  // =4 for %REALSLONG
static int last1 = 0;    // previous atom class
static int gentype = 0;
static int ptype = 0;    // current phrase type
static int papp = 0;     // current phrase parameters
static int pformat = 0;  // current phrase format
static int force = 0;    // force next ptype
static int g = 0;
static int gg = 0;
static int mapgg = 0;  // grammar entries
static int fdef = 0;   // current format definition
static int this = -1;  // current recordformat tag
static int nmin = 0;   // analysis record atom pointer
static int nmax = 0;   // analysis record phrase pointer
static int rbase = 0;  // record format definition base
static int dmax = 1;
static int tmin = maxtag;  // upper bound on tags
static int ss = 0;         // source statement entry
char includefile[1024];
char *sourcefile;

char *current_input_filename[128] = { "<UNUSED>", "<PERM>", "<SOURCE>", "<INCLUDE>" }; // GTOAL: added to support nested includes
static int includelines[128];

static int includelist = 0;  // to do with %list/%endoflist and include files.
static int includelevel = 0;
static int include = 0;   // =0 unused, #0being used                 // This holds the previous line number but did not handle nested include files
static int perm = 1;      // 1 = compiling perm, 0 = program
static int progmode = 0;  // -1 = file, 1 = begin/eop
static int sstype = 0;    // -1:exec stat
                          // 0: declaration
                          // 1: block in
                          // 2: block out
static int specmode = 0;  // >=0: definition
                          // -1: proc spec
                          // -2: recordformat
static int ocount = -1;   // own constants wanted
static int limit = 0;     // lookup limit
static int copy = 0;      // duplicate name flag
static int order = 0;     // out of sequence flag
static int forwarn = 0;   // non-local flag
static int dubious = 0;   // flag for dubious statements
static int dp = 1;
static int pos1 = 0;
static int pos2 = 0;        // error position
static int pos = 0;         // input line index
static int dimension = 0;   // current array dimension
static int local = 0;       // search limit for locals
static int fmbase = 0;      // entry for format decls
static int searchbase = 0;  // entry for record_names
static int formatlist = 0;  // size of current format list
static int recid;
static unsigned char _char_[134] = {  // input line
    10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
    10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
    10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
    10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
    10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10};
static int litpool[litmax + 1];
static int lit = 0;     // current literal (integer)
static int lp = 0;      // literals pointer
static int blockx = 0;  // block tag
static int list = 1;    // <= to enable
// static int list = -1;      // <= to enable
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
static int control = 0;
#endif
static int diag = 0;  // diagnose flags
                      // static int diag = -1;      // diagnose flags ALL ON.
static int hash[maxnames + 1];
tagfm tag[maxtag + 1];
static int dict[maxdict + 1];        // (1:maxdict) - Rebased to 0 rather than 1 for efficiency
unsigned char buff[512 + 1];  // (1:512) - Rebased to 0 rather than 1 for efficiency
static int bp = 0;

/* grammar related constants */
#define maxgrammar 1720        // This would be better coming from tables.h
static int gmin = maxgrammar;  // upper bound on grammar
enum { manifest = 120, figurative = 130 };
// Sometimes I have had to change const ints into #defines because
// C does not consider a const int to be a proper constant in some contexts
// (in particular, in array bound dimension expressions) - it is treated
// more like a variable that happens to be stored in read-only memory.
#define actions 180  // This was 179 in the original pass1.c before I corrected it to match the grammar
#define phrasal 200

static const unsigned char amap[16] = {
    89,  91,  92,  104, 94,  93,  105, 100, 101,
    102, 103, 106, 107, 108, 109, 89
    //   ?     v     n     l    fm const  swit    rp    fp    mp    pp     a    an    na    nan    ?
};

static const unsigned char atoms[16] = {
    89, 1, 1, 10, 9, 1, 10, 7, 7,
    7,  7, 4, 1,  4, 1, 89
    // ?  v   n  l  fm const swit rp fp mp pp  a   an  na nan ?
};

// *** start of generated tables ***
#include "tables.h"
// *** end of generated tables ***

static void flushbuffer(int limit) {
  ENTER();
  int j;
  if (bp >= limit) {
    if (faulty == 0) {
      selectoutput(object);
      for (j = 1; j <= bp; j += 1) {
        printsymbol(buff[j]);
      }
      selectoutput(listing);
    }
    bp = 0;
  }
  nreturn;
}

#define addchar(ch) buff[++bp] = ch

static void op(int code, int param) {
  ENTER();
  addchar(code); addchar(param >> 8); addchar(param);
  nreturn;
}

void op_filename(char *s) {
  ENTER();
  addchar(strlen(s)); for (int i = 0; i < strlen(s); i++) addchar(s[i]);
  nreturn;
}

static void setconst(int m) {
  ENTER();
  buff[bp + 1] = 'N';
  buff[bp + 5] = m;
  m = m >> 8;
  buff[bp + 4] = m;
  m = m >> 8;
  buff[bp + 3] = m;
  m = m >> 8;
  buff[bp + 2] = m;
  bp += 5;
  nreturn;
}

#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
static void octal(int n) {
  ENTER();
  int m;
  m = n >> 3;
  if (m != 0) octal(m);
  addchar((n & 7) + '0');
  nreturn;
}

static void hexadecimal(int n) {
  ENTER();
  int m;
  m = n >> 4;
  if (m != 0) hexadecimal(m);
  if ((n & 15) > 9)
    addchar((n & 15) + 'A');
  else
    addchar((n & 15) + '0');
  nreturn;
}
#endif

static void printident(int p, int mode) {
  ENTER();
  /*void putit (int ch) { ENTER();
         if (mode == 0) {
            printsymbol (ch);
         } else {
            addchar (ch);
         }
      }*/
#define putit(ch)    \
  if (mode == 0)     \
    printsymbol(ch); \
  else               \
    addchar(ch);
  int k, l;
  p = tag[p].text;
  if (p == 0) {
    putit('?');
    nreturn;
  }
  p += 1;  // advance to name string
  k = dict[p];
  l = k & 255;  // length
  while (l > 0) {
    putit(k >> 8);
    l -= 1;
    p += 1;
    k = dict[p];
    if (l == 0) break;
    putit(k & 255);
    l -= 1;
  }
#undef putit
  nreturn;
}

static void abandon(int n) {
  ENTER();
#ifdef USE_GCC_EXTENSIONS
  static const void *reason[10] = {
      &&reason_0, &&reason_1, &&reason_2, &&reason_3, &&reason_4,
      &&reason_5, &&reason_6, &&reason_7, &&reason_8, &&reason_9,
  };
#endif
  int stream;
  stream = listing;
  for (;;) {
    if (sym != nl) newline();
    printsymbol('*');
    write(lines, 4);
    space();
    if ((n < 0) || (n > 9)) BADSWITCH(n, __LINE__, __FILE__);
#ifdef USE_GCC_EXTENSIONS
    goto *reason[n];
#else
    switch (n) {
    case 0: goto reason_0;
    case 1: goto reason_1;
    case 2: goto reason_2;
    case 3: goto reason_3;
    case 4: goto reason_4;
    case 5: goto reason_5;
    case 6: goto reason_6;
    case 7: goto reason_7;
    case 8: goto reason_8;
    case 9: goto reason_9;
    }
#endif
  reason_0: /* 0 */
    printstring("compiler error!");
    goto more;
  reason_1: /* 1 */
    printstring("switch vector too large");
    goto more;
  reason_2: /* 2 */
    printstring("too many names");
    goto more;
  reason_3: /* 3 */
    printstring("program too complex");
    goto more;
  reason_4: /* 4 */
    printstring("feature not implemented");
    goto more;
  reason_5: /* 5 */
    printstring("input ended: ");
    if (quote != 0) {
      if (quote < 0)
        printsymbol(cquote);
      else
        printsymbol(squote);
    } else {
      printstring("%endof");
      if (progmode >= 0)
        printstring("program");
      else
        printstring("file");
    }
    printstring(" missing?");
    goto more;
  reason_6: /* 6 */
    printstring("too many faults!");
    goto more;
  reason_7: /* 7 */
    printstring("string constant too long");
    goto more;
  reason_8: /* 8 */
    printstring("dictionary full");
    goto more;
  reason_9: /* 9 */
    printstring(concat("Included file ", concat(includefile, " does not exist")));

  more:
    newline();
    printstring("***  compilation abandoned ***");
    newline();
                                                              exit(__LINE__/*EXIT_FAILURE*/);
    if (stream == report) break;
    closeoutput();
    stream = report;
    selectoutput(report);
  }
  if ((diag & 4096) != 0) signal_event(15, 15, 0);
  exit(__LINE__/*EXIT_FAILURE*/);
}

static void printss(void) {
  ENTER();
  int s, p;

  if (pos == 0) nreturn;
  space();
  p = 1;
  for (;;) {
    if (p == pos1) printsymbol(marker);
    if (p == pos) break;
    s = _char_[p];
    p += 1;
    if ((s == nl) || ((s == '%') && (p == pos))) break;
    if (s < ' ') {  // beware of tabs
      if (s == ff)
        s = nl;
      else
        s = ' ';
    }
    printsymbol(s);
  }
  if (list <= 0) pos = 0;
  nreturn;
}

static int open;        // open = closed;        // zero if can return from proc
                 //int tbase;      // tbase = tmax;       // tag base
static int tstart;      // tstart = tmax;
static int _label_;     // int _label_;
                 //int access;     // access = 1;         // non-zero if accessible
static int inhibit;     // inhibit = 0;        // non-zero inhibits declaratons
                 //int *bflags;    // bflags = &tag[blocktag].flags /* Pointer assignment */ ;
static int blocktype;   // blocktype = (*bflags >> 4) & 7;
static int blockform;   // blockform = *bflags & 15;
static int blockfm;     // blockfm = tag[blocktag].format;
static int blockotype;  // blockotype = otype;

static void fault(int n, int *tbase) {
  ENTER();
  // -5 : -1 - warnings
  // 0 : 22 - errors

#ifdef USE_GCC_EXTENSIONS
  static const void *fm[23] = {&&fm_0,  &&fm_1,  &&fm_2,  &&fm_3,  &&fm_4,  &&fm_5,  &&fm_6,  &&fm_7,
                               &&fm_8,  &&fm_9,  &&fm_10, &&fm_11, &&fm_12, &&fm_13, &&fm_14, &&fm_15,
                               &&fm_16, &&fm_17, &&fm_18, &&fm_19, &&fm_20, &&fm_21, &&fm_22};
  static const void *fm_minus[6] = {&&fm_default, &&fm_minus_1, &&fm_minus_2, &&fm_minus_3, &&fm_minus_4, &&fm_minus_5};
#endif
  int st;

  if (pos2 > pos1) pos1 = pos2;
  if (sym != nl) newline();
  st = report;
  if (n == -3) st = listing;  // don't report unused on the console
  for (;;) {
    selectoutput(st);
    if (n < 0) {
      printsymbol('?');
      pos1 = 0;
    } else
      printsymbol('*');
    if (st != report) {
      if ((list <= 0) && (pos1 != 0)) {
        spaces(pos1 + margin);
        printstring("      ! ");
      }
    } else {
      if (include != 0) printstring(includefile);
      write(lines, 4);
      printsymbol(csym);
      space();
    }
#ifdef USE_GCC_EXTENSIONS
    if ((-5 <= n) && (n < 0)) {
      goto *fm_minus[-n];
    } else if ((0 <= n) && (n <= 22)) {
      goto *fm[n];
    }
#else
    switch (n) {
    case -5: goto fm_minus_5;
    case -4: goto fm_minus_4;
    case -3: goto fm_minus_3;
    case -2: goto fm_minus_2;
    case -1: goto fm_minus_1;
    case 0: goto fm_0;
    case 1: goto fm_1;
    case 2: goto fm_2;
    case 3: goto fm_3;
    case 4: goto fm_4;
    case 5: goto fm_5;
    case 6: goto fm_6;
    case 7: goto fm_7;
    case 8: goto fm_8;
    case 9: goto fm_9;
    case 10: goto fm_10;
    case 11: goto fm_11;
    case 12: goto fm_12;
    case 13: goto fm_13;
    case 14: goto fm_14;
    case 15: goto fm_15;
    case 16: goto fm_16;
    case 17: goto fm_17;
    case 18: goto fm_18;
    case 19: goto fm_19;
    case 20: goto fm_20;
    case 21: goto fm_21;
    case 22: goto fm_22;
    default: goto fm_default;
    }
#endif
    printstring("fault");
    write(n, 2);
    goto ps;
  fm_default:
    BADSWITCH(n, __LINE__, __FILE__);
  fm_minus_5: /* -5 */
    printstring("Dubious statement");
    dubious = 0;
    goto psd;
  fm_minus_4: /* -4 */
    printstring("Non-local");
    pos1 = forwarn;
    forwarn = 0;
    goto ps;
  fm_minus_3: /* -3 */
    printident(x, 0);
    printstring(" unused");
    goto nps;
  fm_minus_2: /* -2 */
    printstring("\"}\"");
    goto miss;
  fm_minus_1: /* -1 */
    printstring("access");
    goto psd;
  fm_0: /* 0 */
    printstring("form");
    goto ps;
  fm_1: /* 1 */
    printstring("atom");
    goto ps;
  fm_2: /* 2 */
    printstring("not declared");
    goto ps;
  fm_3: /* 3 */
    printstring("too complex");
    goto ps;
  fm_4: /* 4 */
    printstring("duplicate ");
    printident(x, 0);
    goto ps;
  fm_5: /* 5 */
    printstring("type");
    goto ps;
  fm_6: /* 6 */
    printstring("match");
    goto psd;
  fm_7: /* 7 */
    printstring("context");
    goto psd;
  fm_8: /* 8 */
    printstring("%cycle");
    goto miss;
  fm_9: /* 9 */
    printstring("%start");
    goto miss;
  fm_10: /* 10 */
    printstring("size");
    if (pos1 == 0) write(lit, 1);
    goto ps;
  fm_11: /* 11 */
    printstring("bounds");
    if (!(ocount < 0)) write(ocount, 1);
    goto ps;
  fm_12: /* 12 */
    printstring("index");
    goto ps;
  fm_13: /* 13 */
    printstring("order");
    goto psd;
  fm_14: /* 14 */
    printstring("not a location");
    goto ps;
  fm_15: /* 15 */
    printstring("%begin");
    goto miss;
  fm_16: /* 16 */
    printstring("%end");
    goto miss;
  fm_17: /* 17 */
    printstring("%repeat");
    goto miss;
  fm_18: /* 18 */
    printstring("%finish");
    goto miss;
  fm_19: /* 19 */
    printstring("result");
    goto miss;
  fm_20: /* 20 */
    printsymbol('"');
    printident(x, 0);
    printsymbol('"');
    goto miss;
  fm_21: /* 21 */
    printstring("context ");
    printident(this, 0);
    goto ps;
  fm_22: /* 22 */
    printstring("format");
    goto ps;
  miss:
    printstring(" missing");
    goto nps;
  psd:
    pos1 = 0;
  ps:
    printss();
  nps:
    newline();
    if (st == listing) break;
    st = listing;
  }
  if (n >= 0) {
    if ((diag & 4096) != 0) signal_event(15, 15, 0);
    if (n != 13) {  // order is fairly safe
      ocount = -1;
      gg = 0;
      copy = 0;
      quote = 0;
      searchbase = 0;
      escapeclass = 0;
      gg = 0;  // looks redundant but is in original Imp version
    }
    faulty += 1;

    // check that there haven't been too many faults

    faultrate += 3;
    if (faultrate > 30) abandon(6);
    if (faultrate <= 0) faultrate = 3;
  }
  *tbase = tstart;
  if ((list <= 0) && (sym != nl)) {
    errormargin = column;
    errorsym = sym;
    sym = nl;
  }
  nreturn;
}

static int gapp(int *tmax);
static void deletenames(int quiet, int *tmax, int *level, int *tbase);
static void analyse(int *tmax, int *level, int *dmin, int *id, int *blocktag, int *l, int *access, int *tbase, int *bflags);
static void compile(int *tmax, int *level, int *dmin, int *id, int *blocktag, int *l, int *access, int *tbase, int *bflags);

static void compileblock(int level, int blocktag, int dmin, int tmax, int id) {
  ENTER();

  /* int open; */ open = closed;  // zero if can return from proc
#ifdef INCLUDE_UNUSED             // Either never written to, or written to but never read from
  int dbase = dmax;               // dictionary base
#endif
  // Do these need to be pushed to avoid overwriting in a recursive call to compileblock?
  int tbase = tmax;  // tag base
  /* int tstart; */ tstart = tmax;
  /* int _label_; */ _label_ = 4;  // first internal label
  int access = 1;                  // non-zero if accessible
  /* int inhibit; */ inhibit = 0;  // non-zero inhibits declaratons

  int *bflags = &tag[blocktag].flags /* Pointer assignment */;
  /* int blocktype; */ blocktype = (*bflags >> 4) & 7;
  /* int blockform; */ blockform = *bflags & 15;
  /* int blockfm; */ blockfm = tag[blocktag].format;
  /* int blockotype; */ blockotype = otype;
  int *blockapp;
  blockapp = &tag[blocktag].app /* Pointer assignment */;

  int l, newapp;

  dmin -= 1;
  dict[dmin] = -1;
  // end marker for starts & cycles
  if (dmax == dmin) abandon(2);

  if ((list > 0) && (level > 0)) {
    write(lines, 5);
    spaces(level * 3 - 1);
    if (blocktag == 0) {
      printstring("Begin");
    } else {
      printstring("Procedure ");
      printident(blocktag, 0);
    }
    newline();
  }

  // deal with procedure definition (parameters)
  if (blocktag != 0) {  // proc
    analyse(&tmax, &level, &dmin, &id, &blocktag, &l, &access, &tbase, bflags);
    if (ss != 0) compile(&tmax, &level, &dmin, &id, &blocktag, &l, &access, &tbase, bflags);

    if (blockotype != 0) {          // external-ish
      if ((*bflags & spec) == 0) {  // definition
        if ((progmode <= 0) && (level == 1))
          progmode = -1;
        else
          fault(7, &tbase);
      }
    }

    newapp = gapp(&tmax);                         // generate app grammar
    if (specgiven != 0) {                         // definition after spec
      if (newapp != *blockapp) fault(6, &tbase);  // different from spec
    }
    *blockapp = newapp;  // use the latest

    if (level < 0) {  // not procedure definition
      deletenames(0, &tmax, &level, &tbase);
      nreturn;
    }
  } else {
    open = 0;  // can return from a block?
  }

  for (;;) {
    analyse(&tmax, &level, &dmin, &id, &blocktag, &l, &access, &tbase, bflags);
    if (ss != 0) {
      compile(&tmax, &level, &dmin, &id, &blocktag, &l, &access, &tbase, bflags);
      if (dubious != 0) fault(-5, &tbase);
      flushbuffer(128);          // flush if bp >= 128
      if (sstype > 0) {          // block in or out
        if (sstype == 2) break;  // out
        // locals were made global to support exbedding, but must be saved
        // over a recursive call to the procedure since there *were* local...
        // Fortunately there is only one such call.

        int save_tstart = tstart;
        int save__label_ = _label_;
        int save_inhibit = inhibit;
        int save_blockfm = blockfm;
        int save_open = open;
        int save_blocktype = blocktype;
        int save_blockotype = blockotype;
        int save_blockform = blockform;
        compileblock(specmode, blockx, dmin, tmax, id);
        blockform = save_blockform;
        blockotype = save_blockotype;
        blocktype = save_blocktype;
        open = save_open;
        blockfm = save_blockfm;
        inhibit = save_inhibit;
        _label_ = save__label_;
        tstart = save_tstart;

        if (ss < 0) break;  // endofprogram
      }
    }
  }
  if ((list > 0) && (level > 0)) {
    write(lines, 5);
    spaces(level * 3 - 1);
    printstring("End");
    newline();
  }
  deletenames(0, &tmax, &level, &tbase);
  nreturn;

}  // of compile block

// generate app grammar (backwards)
static void setcell(int g, int tt, int *p, int *link, int *ap);
static void classproc(tagfm *v, int *ap, int *tp, int *c);
static int gapp(int *tmax) {
  ENTER();
  enum { comma = 140 };  // psep
  tagfm *v;
  int p, link, tp, c, ap, t;

  if (*tmax == local) preturn(0);  // no app needed

  p = gmax1;
  link = 0;
  t = *tmax;

  for (;;) {
    v = &tag[t] /* Pointer assignment */;
    t -= 1;
    classproc(v, &ap, &tp, &c);  // deduce class from tag
    if (c < 0) {                 // insert %PARAM
      c = -c;
      setcell(196, tp, &p, &link, &ap);
      tp = -1;
    }
    setcell(c, tp, &p, &link, &ap);
    if (t == local) break;               // end of parameters
    setcell(comma, -1, &p, &link, &ap);  // add the separating comma
  }
  if (gmax > gmin) abandon(3);

  preturn(link);
}
static void setcell(int g, int tt, int *p, int *link, int *ap) {
  ENTER();
  // add the cell to the grammar, combining common tails
  while (*p != gmax) {
    *p += 1;
    if ((glink(*p) == *link) && (gram(*p) == g)) {
      if ((tt < 0) || ((gram(*p + 1) == tt) && (glink(*p + 1) == *ap))) {
        *link = *p;
        // already there
        nreturn;
      }
    }
  }

  // add a new cell
  gmax += 1;
  gram(gmax) = g;       // I tried being very explicit about type conversions and
  glink(gmax) = *link;  // sign extending but it made zero difference to the current problem.
  *link = gmax;         // making some of the scalar ints in this file into shorts did
                        // help with the display of Atom1 when it contained 'error' (0x8000)
                        // but that was only cosmetic - no changes to program behaviour.

  if (tt >= 0) {  // set type cell
    gmax += 1;
    gram(gmax) = tt;  // macros are in tables.h
    glink(gmax) = *ap;
  }
  *p = gmax;
  nreturn;
}

static void classproc(tagfm *v, int *ap, int *tp, int *c) {
  ENTER();
#define err 89
#define rtp 100
#define fnp 101
#define mapp 102
#define predp 103
  static const int classmap[16] = {err,  1764,  247,    err, err, err, err, -rtp,
                                   -fnp, -mapp, -predp, err, 214, err, 229, err};
#undef err
#undef rtp
#undef fnp
#undef mapp
#undef predp
  int tags, type, form;

  *ap = 0;
  tags = v->flags;
  type = (tags >> 4) & 7;
  form = tags & 15;
  *tp = (v->format << 3) | type;
  *c = classmap[form];
  if ((type == 0) && (form == 2)) {
    *c = 208;
    *tp = 0;
  }  // %name
  if ((tags & parameters) != 0) *ap = v->app;
  nreturn;
}

static void deletenames(int quiet, int *tmax, int *level, int *tbase) {
  ENTER();
  int flags;
  tagfm *tx;

  while (*tmax > *tbase) {
    x = *tmax;
    *tmax -= 1;
    tx = &tag[x] /* Pointer assignment */;
    flags = tx->flags;
    if (((flags & spec) != 0) && ((flags & ownbit) == 0)) fault(20, tbase);
    // /* spec with no definition & not external */
    if (((flags & usedbit) == 0) && (*level >= 0) && (list <= 0)) {
      if (quiet == 0) fault(-3, tbase);  // unused
    }
    dict[tx->text] = tx->link;
  }
  nreturn;
}

static void show(int a) {
  ENTER();
  if ((0 < a) && (a < 130)) {
    space();
    printstring(text(a));
  } else
    write(a, 3);
  nreturn;
}

static void traceanalysis(void) {
  ENTER();
  // diagnostic trace routine (diagnose&1 # 0)
  int a;

  static int la1 = 0, la2 = 0, lsa = 0, lt = 0;
  if ((monpos != pos) && (sym != nl)) newline();
  monpos = pos;
  write(g, 3);
  space();
  printstring(text(class));
  if ((gg & transbit) != 0) printsymbol('"');
  a = (gg >> 8) & 15;
  if (a != 0) {
    printsymbol('{');
    write(a, 0);
    printsymbol('}');
  }
  if ((atom1 != la1) || (atom2 != la2) || (lsa != subatom) || (lt != type)) {
    printstring(" [");
    la1 = atom1;
    show(la1);
    la2 = atom2;
    show(la2);
    lsa = subatom;
    write(lsa, 3);
    lt = type;
    write(lt, 5);
    printsymbol(']');
  }
  newline();
  nreturn;
}

static void getsym(void) {
  ENTER();
  readsymbol(sym);
  if (sym < 0) abandon(5);
  if (pos != 133) pos += 1;
  _char_[pos] = sym;
  if (list <= 0) printsymbol(sym);
  column += 1;
  nreturn;
}

static void readsym_(int LINE, int *key) {
  ENTER();
  static int last = 0;
  static const unsigned char mapped[128] = {
      0,   0,   0,   0,   0,    0,   0,   0,   0,   0,   10,  0,   3,   0,   0,   0,   0,   0,   0,   0,   0,   0,
      0,   0,   0,   0,   0,    0,   0,   0,   0,   0,   0,   '!', '"', '#', '$', 1,   '&', 39,  '(', ')', '*', '+',
      ',', '-', '.', '/', '0',  '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A',
      'B', 'C', 'D', 'E', 'F',  'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
      'X', 'Y', 'Z', '[', '\\', ']', '^', '_', '`', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
      'N', 'O', 'P', 'Q', 'R',  'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 2,   '|', '}', '~', 0};

  // ! 0 = space
  // ! 1 = %
  // ! 2 = {
  // ! 3 = ff
  // ! other values represent themselves

  if (sym == nl) {
  s1:
    lines += 1;
    if (endmark != 0) printsymbol(endmark);
  s11:
    pos = 0;
    pos1 = 0;
    pos2 = 0;
    margin = 0;
    column = 0;
    last = 0;
    endmark = 0;
    if (list <= 0) {
      if (include != 0) {
        printstring(" &");
        write(lines, -4);
      } else
        write(lines, 5);
      csym = cont;
      printsymbol(csym);
      space();
      if (errormargin != 0) {
        lines -= 1;
        spaces(errormargin);
        errormargin = 0;
        if (errorsym != 0) {
          printsymbol(errorsym);
          pos = 1;
          _char_[1] = errorsym;
          sym = errorsym;
          errorsym = 0;
          goto s5;
        }
      }
    }
  s2:
    symtype = 1;
  }
s3:
  readsymbol(sym);
  if (sym < 0) abandon(5);
  if (pos != 133) pos += 1;
  _char_[pos] = sym;
  if (list <= 0) printsymbol(sym);
  column += 1;
s5:
  if (sym != nl) {
    last = sym;
    if (quote != 0) nreturn;  // dont alter strings
    sym = mapped[sym & 127];
    if (sym <= 3) {
      // special symbol
      if (sym == 0) goto s2;
      // space (or dubious control)
      if (sym == 1) {
        symtype = 2;
        goto s3;
      }  // %
      if (sym == 3) {
        cont = '+';
        goto s11;
      }  // ff
      // must be {...
      for (;;) {
        getsym();
        if (sym == '}') goto s3;
        if (sym == nl) goto s4;
      }
    }
    *key = kdict(sym);
    if (((*key & 3) == 0) && (symtype == 2)) {
      // keyword
      if ((sym == 'C') && (nextsymbol() == nl)) {  // %c...
        getsym();
        cont = '+';
        goto s1;
      }
    } else {
      symtype = (*key & 3) - 2;  // 1, 0, -1, -2
    }
    nreturn;
  }
s4:
  symtype = quote;
  if ((last == 0) && (quote == 0)) goto s1;
  cont = '+';
  nreturn;
}
#define readsym(k) readsym_(__LINE__, k)

static int formatselected(void) {
  ENTER();
  formatlist = tag[format].app;  // number of names
  if (formatlist < 0) {          // forward ref
    atom1 = error + 22;
    preturn(0);
  }
  if (sym == '_') {
    escapeclass = escrec;
    searchbase = tag[format].format;
  }
  preturn(1);
}

// twee little function because SKIMP86 can't do string compare properly
// returns 1 if the two names are the same, else zero
static int dictmatch(int ptr1, int ptr2) {
  ENTER();
  int len;

  // start with a cheap check of the length and first character
  if (dict[ptr1] != dict[ptr2]) {
    preturn(0);
  }
  len = dict[ptr1] & 255;
  ptr1 += 1;
  ptr2 += 1;
  len -= 1;
  while (len >= 2) {
    if (dict[ptr1] != dict[ptr2]) {
      preturn(0);
    }
    ptr1 += 1;
    ptr2 += 1;
    len -= 2;
  }
  // if the string was odd length, we might need one last byte checked
  if (len == 1) {
    if ((dict[ptr1] & 255) != (dict[ptr2] & 255)) {  // is endianness relevant?
      preturn(0);
    }
  }
  preturn(1);
}

static void lookup(int d, int *tmax, int *id, int *level, int *tbase) {
  ENTER();
  int newname, vid, k1;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  int k2;
#endif
  int form;
  tagfm *t;
  int new;

  // first locate the text of the name
  new = dmax + 1;             // points to text of string in dictionary
  k1 = hashvalue & maxnames;  // rather crude hash!
  for (;;) {
    newname = hash[k1];
    if (newname == 0) break;  // not in
    if (dictmatch(newname + 1, new) == 1) goto in;
    k1 = (k1 + 1) & maxnames;
  }

  // not found
  sparenames -= 1;
  if (sparenames <= 0) abandon(2);
  hash[k1] = dmax;  // put it in
  dict[dmax] = -1;
  newname = dmax;
  dmax = dp;
  goto notin;

in:
  if ((this >= 0) && (d != 0)) searchbase = rbase;  // record elem defn
  if (searchbase != 0) {                            // record subname
    new = -1;
    x = searchbase;
    for (;;) {
      if (x < formatlist) goto notin;
      if (tag[x].text == newname) break;
      x -= 1;
    }
  } else {  // hash in for normal names
    x = dict[newname];
    if (x <= limit) goto notin;  // wrong *level
  }

  subatom = x;  // name found, extract info
  t = &tag[x] /* Pointer assignment */;
  atomflags = t->flags;
  format = t->format;
  app = t->app;
  protection = atomflags & prot;
  type = (atomflags >> 4) & 7;
  atom1 = amap[atomflags & 15];

  if ((diag & 8) != 0) {
    printstring("lookup:");
    write(atom1, 3);
    write(type, 1);
    write(app, 3);
    write(format, 5);
    write(atomflags, 3);
    newline();
  }

  if (d == 0) {  // old name wanted
    t->flags = t->flags | usedbit;
    searchbase = 0;

    if (((atomflags & subname) != 0) && (format != 0)) {  // a record
      if (formatselected() == 0) nreturn;
    }

    if ((atomflags & parameters) != 0) {  // proc or array
      if (app == 0) {                     // no parameters needed
        atom2 = atom1;
        atom1 -= 4;
        if ((97 <= atom1) && (atom1 <= 98)) {
          mapgg = atom1;
          atom1 = var;
        }
      } else {
        if (sym == '(') {
          searchbase = 0;      // ignore format for now
          if (atom1 >= 106) {  // arrays
            app = phrase(app + 200);
            escapeclass = escarray;
            atom1 = ((atom1 - 106) >> 1) + 91;  // a,an->v na,nan->n
          } else {
            // procedures
            escapeclass = escproc;
            atom1 -= 4;
          }
          phrase(200) = app;
        }
      }
      pos2 = pos;
      nreturn;
    }

    // deal with constintegers etc
    if (((atomflags & constbit) != 0) && (atom1 == var)) {
      mapgg = _const_;
      atom2 = _const_;
      if (type == integer) subatom = -subatom;
    }
    nreturn;
  }
  // new name wanted
  if (*tbase != tstart) goto notin;  // don't fault proc parm-parm
  if (d == (lab + spec + usedbit)) {
    t->flags = t->flags | usedbit;
    nreturn;
  }
  if ((atomflags & spec) != 0) {  // a spec has been given
    if (d == lab) {               // define label
      t->flags = t->flags - spec;
      nreturn;
    }
    if ((7 <= (decl & 15)) && ((decl & 15) <= 10) && ((decl & spec) == 0)) {
      // procedure definition after spec
      if (((decl ^ atomflags) & 0b1111111) == 0) {  // correct type?
        t->flags = t->flags - spec;
        specgiven = 1;
        nreturn;
      }
      // note that an external procedure must be speced as a
      // non-external procedure.
    }
    if ((decl & 15) == recfm) {  // recordformat
      t->flags = (record << 4) + recfm;
      t->format = fdef;
      nreturn;
    }
  }
  if ((last1 == jump) && (atom1 == swit)) nreturn;
  if (copy == 0) copy = x;
notin:
  app = 0;
  vid = 0;
  atom1 = error + 2;

  if (d == 0) nreturn;  // old name wanted
  type = (d >> 4) & 7;
  form = d & 15;
  atom1 = amap[form];

  if (this < 0) {  // normal scope
    new = newname;
    *tmax += 1;
    x = *tmax;
  } else {  // recordformat scope
    new = -1;
    recid -= 1;
    vid = recid;
    tmin -= 1;
    x = tmin;
    formatlist = tmin;
  }

  if ((11 <= form && form <= 14)) {  // arrays
    if (dim == 0) dim = 1;           // set dim for owns
    app = dim;
  }

  if (((otype > 2) && ((d & spec) == 0)) || (perm != 0) || (*level == includelevel)) d = d | usedbit;

  // external definitions need not be used in the file in which
  // they are defined, so inhibit a useless unused warning.

  t = &tag[x] /* Pointer assignment */;
  if (form == lab) {
    *id += 1;
    vid = *id;
  }
  t->index = vid;
  t->text = newname;
  t->flags = d;
  t->app = app;
  t->format = fdef;
  format = fdef;
  subatom = x;

  if (new >= 0) {  // insert into hash table
    t->link = dict[new];
    dict[new] = x;
    if (gmin == maxgrammar) {  // proc param params
      tmin -= 1;
      subatom = tmin;
      tag[tmin] = *t;  // ASSIGN COMPLETE STRUCT. Dioes this work in C?  Use memmove??
    }
  }
  if (*tmax >= tmin) abandon(3);
  nreturn;
}

static void get(int limit, int *base, int *n, int *pt, int *key) {
  ENTER();
  int s, shift;
  shift = 0;
  if (*base != 10) {
    if (*base == 16) {
      shift = 4;
    } else {
      if (*base == 8) {
        shift = 3;
      } else {
        if (*base == 2) {
          shift = 1;
        }
      }
    }
  }
  *n = 0;
  for (;;) {
    if (symtype == -1) {  // digit
      s = sym - '0';
    } else {
      if (symtype < 0) {  // letter
        s = sym - 'A' + 10;
      } else {
        nreturn;
      }
    }
    if (s >= limit) nreturn;
    *pt += 1;
    glink(*pt) = sym;
    if (*base == 10) {
      if ((*n >= maxint) && (((s > maxdig) || (*n > maxint)))) {
        // too big for an integer,
        // so call it a real
        *base = 0;
        type = real;
        *n = 0;
      }
    }
    if (shift == 0) {
      *n = *n * *base + s;
    } else {
      *n = (*n << shift) + s;
    }
    readsym(key);
  }
  nreturn;
}

static void codeatom(int target, int *tmax, int *level, int *dmin, int *id, int *key, int *strp, int *tbase) {
  ENTER();
  int dbase;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  int da;
#endif
  int base, n;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  int mul;
#endif
  int pendquote;
  int j, k, l, pt;

top:
  pos1 = pos;
  subatom = 0;
  pendquote = 0;
  atomflags = 0;

  // app and format must be left for assigning to papp & pformat
  if (symtype == -2) goto namelab;  // letter
  if (symtype < 0) goto number;     // digit
  if (symtype == 0) {
    atom1 = termin;
    atom2 = 0;
    nreturn;
  }
  if (symtype != 2) {                 // catch keywords here
    if (quote != 0) goto text;        // completion of text
    if (sym == squote) goto strings;  // start of string
    if (sym == cquote) goto symbols;  // start of symbol
    if ((sym == '.') && ('0' <= nextsymbol()) && (nextsymbol() <= '9')) goto number;
  }

  // locate atom in fixed dict
  k = *key >> 2;
  readsym(key);
  for (;;) {
    j = kdict(k);
    if ((j & 0x4000) != 0) break;
    if (((j & 127) != sym) || (symtype < 0)) {
      if (!(j < 0)) goto err;
      k += 1;
    } else {
      l = (j >> 7) & 127;
      readsym(key);
      if (j > 0) {
        if (l != 0) {
          if ((l != sym) || (symtype < 0)) {
            goto err;
          }
          readsym(key);
        }
        l = 1;
      }
      k += l;
    }
  }
  atom1 = j & 127;
  if (atom1 == 0) {  // comma
    atom1 = 19;
    subatom = 19;
    atom2 = 0;
    if (sym == nl) {
      if (ocount >= 0) nreturn;
      // special action needs to be taken with <comma nl> as
      // const array lists can be enormous
      readsym(key);
    }
    nreturn;
  }
  atom2 = (j >> 7) & 127;
  subatom = kdict(k + 1) & 0x3FFF;
  // !!!!cont = ' '
  nreturn;

  // report an error. adjust the error marker (pos1) to point
  // to the faulty character in an atom, but care needs to be taken
  // to prevent misleading reports in cases like ...?????

err:
  atom1 = error + 1;
  atom2 = 0;
  if (pos - pos1 > 2) pos1 = pos;
  nreturn;

  // take care with strings and symbol constants.
  // make sure the constant is valid here before sucking it in
  // (and potentially losing many lines)

symbols:
  atom1 = var;
  atom2 = _const_;
  type = integer;
  mapgg = _const_;
  protection = prot;
  subatom = lp;
  if (lp >= litmax) abandon(3);
  quote = ~pendquote;
  nreturn;

  // an integer constant is acceptable so get it in and
  // get the next atom
chars:
  n = 0;
  cont = cquote;
  for (;;) {
    readsym(key);
    if (sym == cquote) {
      if (nextsymbol() != cquote) break;
      readsym(key);
    }
    if ((n & (~(-1 >> bytesize))) != 0) {  // overflow
      pos1 = pos;
      atom1 = error + 10;
      nreturn;
    }
    if (quote == 0) goto err;
    n = (n << bytesize) + sym;
    quote += 1;
  }
  quote = 0;
  cont = ' ';
  if (sym != nl) readsym(key);
  litpool[lp] = n;
  lp += 1;
  goto top;

  // sniff the grammar before getting the string
strings:
  atom1 = var;
  atom2 = _const_;
  type = stringv;
  subatom = *strp | 0x4000;
  mapgg = _const_;
  protection = prot;
  quote = subatom;
  textline = lines;  // in case of errors
  nreturn;

  // a string constant is ok here, so pull it in and get
  // the next atom
  // ABD - temp variable to help pack bytes into words
  int flipflop;

text:
  if (quote < 0) goto chars;  // character consts
  l = *strp;                  // point to beginning
  k = 0;                      // length so far
  flipflop = 0;               // space for the length is up the spout

  for (;;) {
    cont = squote;
    quote = 1;
    for (;;) {
      readsym(key);
      if (sym == squote) {                  // terminator?
        if (nextsymbol() != squote) break;  // yes ->
        readsym(key);                       // skip quote
      }
      if (flipflop >= 0) {
        glink(*strp) = ((sym << 8) + flipflop);
        *strp += 1;
        flipflop = -1;
      } else {
        flipflop = sym;
      }
      k += 1;
      if (k > 255) {
        lines = textline;
        abandon(7);
      }  // too many chars
    }
    if (flipflop >= 0) {  // tail-end charlie
      glink(*strp) = flipflop;
      *strp += 1;
    }
    glink(l) = (glink(l) | k);  // plug in length

    quote = 0;
    cont = ' ';
    readsym(key);
    codeatom(target, tmax, level, dmin, id, key, strp, tbase);
    if (!((atom1 == 48) && (sym == squote))) nreturn;  // fold "???"."+++"
  }
number:
  base = 10;
bxk:
  atom1 = var;
  atom2 = _const_;
  type = integer;
  subatom = lp;
  mapgg = _const_;
  protection = prot;
  if (lp >= litmax) abandon(3);
  pt = *strp;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  mul = 0;
#endif
  for (;;) {
    get(base, &base, &n, &pt, key);
    if (!((sym == '_') && (base != 0) && (pendquote == 0))) break;  // change of base
    pt += 1;
    glink(pt) = '_';
    readsym(key);
    base = n;
  }

  if (pendquote != 0) {
    if (sym != cquote) goto err;
    readsym(key);
  }
  if (sym == '.') {  // a real constant
    pt += 1;
    glink(pt) = '.';
    readsym(key);
    type = real;
    n = base;
    base = 0;
    get(n, &base, &n, &pt, key);
  }

  if (sym == '@') {  // an exponent
    pt += 1;
    glink(pt) = '@';
    k = pt;
    readsym(key);
    type = integer;
    base = 10;
    if (sym == '-') {
      readsym(key);
      get(10, &base, &n, &pt, key);
      n = -n;
    } else {
      get(10, &base, &n, &pt, key);
    }
    pt = k + 1;
    glink(pt) = lp;
    litpool[lp] = n;
    lp += 1;
    if (base == 0) atom1 = error + 10;
    type = real;  // exponents force the type
  }

  if (type == real) {
    glink(*strp) = (pt - *strp);  // store the length (difference)
    subatom = *strp | 0x2000;
    *strp = pt + 1;
  } else {
    litpool[lp] = n;
    lp += 1;
  }
  nreturn;

namelab:
  if ((27 <= target) && (target <= 41)) {
    atom1 = 0;
    nreturn;
  }
  hashvalue = 0;

  // ABD changed to remove dependency on direct addressing
  dp = dmax + 1;
  dbase = dp;
  n = 0;
  dict[dp] = 0;
  for (;;) {
    hashvalue += (hashvalue + sym);  // is this good enough?
    dict[dp] = dict[dp] | (sym << 8);
    n += 1;
    dp += 1;
    readsym(key);
    if (symtype >= 0) break;
    dict[dp] = sym;
    n += 1;
    readsym(key);
    if (symtype >= 0) break;
  }
  if (sym == cquote) {
    pendquote = 100;
    if (hashvalue == 'M') goto symbols;
    readsym(key);
    if (hashvalue == 'X') {
      base = 16;
      goto bxk;
    }
    if ((hashvalue == 'K') || (hashvalue == 'O')) {
      base = 8;
      goto bxk;
    }
    if (hashvalue == 'B') {
      base = 2;
      goto bxk;
    }
    goto err;
  }
  dict[dbase] = dict[dbase] | n;
  if ((n & 1) == 0) dp += 1;
  if (dp >= *dmin) abandon(8);

  atom2 = 90;                          // ident
  if ((last1 == 0) && (sym == ':')) {  // label
    limit = local;
    lookup(lab, tmax, id, level, tbase);
    nreturn;
  }
  if (last1 == jump) {  // ->label
    limit = local;
    lookup(lab + spec + usedbit, tmax, id, level, tbase);
    nreturn;
  }
  if ((decl != 0) && (target == 90)) {  // identifier
    searchbase = fmbase;
    limit = local;
    lookup(decl, tmax, id, level, tbase);
    searchbase = 0;
  } else {
    limit = 0;
    lookup(0, tmax, id, level, tbase);
  }
  nreturn;
}

static int parsedmachinecode(int *level, int *dmin, int *id, int *key, int *tmax, int *strp, int *tbase) {
  ENTER();
  // *opcode_??????????
  if (!(symtype == -2)) {
    atom1 = error;
    preturn(0);
  }                  // starts with letter
  flushbuffer(128);  // flush if bp >= 128
  addchar('w');
  for (;;) {
    addchar(sym);
    readsym(key);
    if ((sym == '_') || (symtype == 0)) break;  // pull in letters and digits
  }
  addchar('_');
  if (symtype != 0) {  // not terminator
    readsym(key);
    while (symtype != 0) {
      if (symtype < 0) {  // complex
        codeatom(0, tmax, level, dmin, id, key, strp, tbase);
        if ((atom1 & error) != 0) preturn(0);
        if ((atom2 == _const_) && (type == integer)) {
          if (subatom < 0)
            setconst(tag[-subatom].format);
          else
            setconst(litpool[subatom]);
        } else if ((91 <= atom1) && (atom1 <= 109)) {
          if ((atom1 == 104) && ((tag[subatom].flags & closed) == 0)) {
            this = subatom;
            atom1 = error + 21;
            preturn(0);
          }
          op(' ', tag[subatom].index);
        } else {
          atom1 = error;
          preturn(0);
        }
      } else {
        if (symtype == 2) sym = sym | 128;  // underline with %
        addchar(sym);
        readsym(key);
      }
    }
  }
  addchar(';');
  preturn(1);
}

static void analyse(int *tmax, int *level, int *dmin, int *id, int *blocktag, int *l, int *access, int *tbase, int *bflags) {
  ENTER();
  enum { orderbits = 0x3000, orderbit = 0x1000 };
  enum { escape = 0x1000 };
  int strp, mark, flags, proterr, k, s, c;
  static int key = 0;
  int node;
  int *z;
  arfm *arp;
#ifdef USE_GCC_EXTENSIONS
  static const void *act[phrasal - actions + 1] = {
      &&act_default,  // act(180) not present
      &&act_181,     &&act_182, &&act_183, &&act_184, &&act_185, &&act_186, &&act_187, &&act_188, &&act_189, &&act_190,
      &&act_191,     &&act_192, &&act_193, &&act_194, &&act_195, &&act_196, &&act_197, &&act_198, &&act_199,
      &&act_default  // act(200) not present
  };
#endif
#ifdef USE_GCC_EXTENSIONS
  static const void *paction[16] = {
      &&paction_0,       &&paction_1,       &&paction_2,       &&paction_3,       &&paction_4,       &&paction_5,
      &&paction_6,       &&paction_7,       &&paction_default, &&paction_default, &&paction_default, &&paction_default,
      &&paction_default, &&paction_default, &&paction_default, &&paction_default,
  };
#endif

  if (gg == 0) cont = ' ';
  last1 = 0;
  mapgg = 0;
  s = 0;
  ss = 0;
  sstype = -1;
  fdef = 0;
  fmbase = 0;
  app = 0;

  // deal with alignment following an error in one statement
  // of several on a line
  margin = column;  // start of statement
  pos = 0;
  strp = gmax + 1;
  lp = 0;
  *tbase = tstart;  // ??????????????
  local = *tbase;

  if (((gg == 0) || (ocount >= 0))) {  // data or not continuation(z)
  again:
    while (symtype == 0) {  // skip redundant terminators
      c = cont;
      cont = ' ';
      if (ocount >= 0) cont = '+';
      readsym(&key);
      cont = c;
    }
    if (sym == '!') goto skip;  // comment
    this = -1;
    codeatom(0, tmax, level, dmin, id, &key, &strp, tbase);
    if (atom1 == comment) {
    skip:
      quote = 1;
      c = cont;
      while (sym != nl) {
        readsym(&key);
        cont = c;
      }  // skip to end of line
      quote = 0;
      symtype = 0;
      goto again;
    }
  }
  decl = 0;
  mark = 0;
  gentype = 0;
  force = 0;
  dim = 0;
  proterr = 0;
  node = 0;
  nmax = 0;
  nmin = recsize + 1;
  order = 1;
  gmin = maxgrammar + 1;
  if (gg != 0) {
    sstype = 0;
    goto more;
  }  // continuation
  ptype = 0;
  specgiven = 0;

  stats += 1;
  if (perm == 0) {   // GTOAL: remove this test to allow perm to generate line numbers as well.  Note knock-on effects in i2c.c and idec.c
    op('O', lines); // extended LINE ('O') opcode compared to original ICODE definition
    op_filename(current_input_filename[instream]);
  }
  if ((atom1 & error) != 0) goto fail1;  // first atom faulty

  if (escapeclass != 0) {  // enter the hard way after
    g = impphrase;
    sstype = -1;
    goto a3;
  }

  g = initial(atom1);  // pick up entry point
  if (g == 0) {        // invalid first atom
    g = initial(0);
    sstype = 0;
    goto a3;  // declarator?
  }
  if (g < 0) {  // phrase imp
    g = g & 255;
    nmax = 1;
    ar[1].class = 0;
    ar[1].link = 0;
    ar[1].sub = impphrase;
  }

  gg = gram(g);
  class = gg & 255;
  sstype = ((gg >> 12) & 3) - 1;
  goto a1;

act_194: /* 194 */
  ptype = type;
  papp = app;
  pformat = format;
  goto more;
act_196: /* 196 */
  k = g + 1;
  goto a610;
act_188: /* 188 */
  k = ar[nmax].sub + 1;
a610:
  papp = glink(k);
  k = gram(k);
  if (k == 0) goto more;  // %name
  ptype = k & 7;
  pformat = k >> 3;
act_183: /* 183 */
  k = type;
  if (((gentype == 0) || (k == real))) gentype = k;
  if (pformat < 0) {  // general type
    app = papp;
    format = pformat;
    if (((ptype == real) && (type == integer))) k = real;
    if (force != 0) {
      k = force;
      force = 0;
    }
  }
  if (!((papp == app) && ((ptype == k) || (ptype == 0)))) goto fail2;
  if ((pformat == format) || (pformat == 0) || (format == 0)) goto more;
  goto fail2;
act_197: /* 197 */
  arp = &ar[nmin] /* Pointer assignment */;
  k = arp->sub;
  if (!(blockform == (k & 15))) goto fail3;
  arp->sub = k >> 4;

  type = blocktype;
  ptype = blocktype;
  pformat = blockfm;
  papp = app;
  if (ptype != record) pformat = -1;
  goto more;
act_195: /* 195 */
  if ((type != 0) && (type != integer) && (type != real)) goto fail2;
  arp = &ar[nmin] /* Pointer assignment */;
  k = arp->sub;
  arp->sub = k >> 2;
  k = k & 3;
  // 1 = check integer
  // 2 = check real
  // 3 = check real + int
  if (k == 0) goto more;  // 0 = no action
  if (k == 1) {
    force = integer;
    if ((type == integer) || (type == 0)) goto more;
    goto fail2;
  }
  if (!((ptype == real) || (ptype == 0))) goto fail2;  // {or added?}
  if (k == 3) force = integer;
  goto more;
act_198: /* 198 */
  // %OTHER
  k = (gg >> 8) & 15;
  if (k == 0) {  // restore atom
    atom1 = last1;
    goto more;
  }
  if (k == 1) {  // test string
    if (!(type == stringv)) goto fail2;
    goto more;
  }
  if (k == 2) {  // {fault record comparisons}
    if (type == record) goto fail2;
    goto more;
  }
  if (k == 3) {  // check OWN variable coming
    codeatom(0, tmax, level, dmin, id, &key, &strp, tbase);
    if ((atomflags & ownbit) == 0) goto a7;
    goto more;
  }
  if (x <= local) forwarn = pos1;  // %for TEST
  goto more;
paction_1: /* 1 */
  if (type == record)
    g = phrase(242);
  else
    pformat = -1;
  goto a3;
paction_2: /* 2 */
  ptype = real;
  pformat = -1;
  goto a3;
paction_3: /* 3 */
  ptype = stringv;
  pformat = -1;
  goto a3;
paction_4: /* 4 */
  ptype = integer;
  pformat = -1;
  goto a3;
paction_5: /* 5 */
  if (ptype == integer) goto a3;
  if (ptype == real) {
    g = phrase(212);
    pformat = -1;
  }
  if (ptype == stringv) g = phrase(213);
  goto a3;
paction_6: /* 6 */
  ptype = gram(ar[nmax].sub + 1) & 7;
  pformat = -1;
  goto a3;
paction_7: /* 7 */
  if (ptype == integer) ptype = real;
  pformat = -1;
  goto a3;
a1:
  last1 = class;
  atom1 = 0;
  s = subatom;
a2:
  if ((gg & transbit) == 0) {  // insert into analysis record
    z = &node /* Pointer assignment */;
    for (;;) {  // insert cell in order
      k = *z;
      if (((gg & orderbits) == 0) || (k == 0)) break;
      gg -= orderbit;
      z = &ar[k].link /* Pointer assignment */;
    }
    if ((mapgg != 0) && ((gg & 255) == var)) gg = mapgg;
    nmin -= 1;
    if (nmin == nmax) goto fail0;
    *z = nmin;
    arp = &ar[nmin] /* Pointer assignment */;
    arp->sub = s;
    arp->class = (gg & 255) | mark;
    arp->link = k;
  }
  mark = 0;
  mapgg = 0;
more:
  g = glink(g);  // chain down the grammar
paction_0:       /* 0 */
a3:
  gg = gram(g);
  class = gg & 255;
  if ((diag & 1) != 0) traceanalysis();
  if (class == 0) goto a5;  // end of phrase
  if (class < actions) {    // not a phrase or an action
    if (class >= figurative) class = atomic(class);
    if (class >= manifest) goto a2;
    if (atom1 == 0) codeatom(class, tmax, level, dmin, id, &key, &strp, tbase);
    if (escapeclass != 0) {  // escape to new grammar
      class = escapeclass;
      escapeclass = 0;
      g += escape;

      // note that following an escape the next item is
      // forced to be transparent!

    esc:
      gg = 0;
      arp = &ar[nmax + 1] /* Pointer assignment */;
      arp->papp = papp;
      arp->x = x;
      goto a4;
    }

    if ((class == atom1) || (class == atom2)) goto a1;

  a7:
    if (gg >= 0) goto fail1;  // no alternative
    g += 1;
    goto a3;
  }

  if (class >= phrasal) {  // a phrase
  a4:
    nmax += 1;
    if (nmax == nmin) goto fail0;
    arp = &ar[nmax] /* Pointer assignment */;
    arp->ptype = ptype;
    arp->pos = pos1;
    arp->pformat = pformat;
    arp->link = gentype;
    arp->class = node;
    arp->sub = g;
    node = 0;
    g = phrase(class);
    if (force != 0) {
      ptype = force;
      force = 0;
    }
    gentype = 0;
#ifdef USE_GCC_EXTENSIONS
    goto *paction[(gg >> 8) & 15];
#else
    switch ((gg >> 8) & 15) {
    case 0: goto paction_0;
    case 1: goto paction_1;
    case 2: goto paction_2;
    case 3: goto paction_3;
    case 4: goto paction_4;
    case 5: goto paction_5;
    case 6: goto paction_6;
    case 7: goto paction_7;
    case 8: goto paction_default;
    case 9: goto paction_default;
    case 10: goto paction_default;
    case 11: goto paction_default;
    case 12: goto paction_default;
    case 13: goto paction_default;
    case 14: goto paction_default;
    case 15: goto paction_default;
    }
#endif
  paction_default:
    BADSWITCH((gg >> 8) & 15, __LINE__, __FILE__);
  }
  if ((class < actions) || (class > phrasal)) BADSWITCH(class, __LINE__, __FILE__);
#ifdef USE_GCC_EXTENSIONS
  goto *act[class - actions];  // only actions left
#else
  switch (class) {
  case 180: goto act_default;  // act(180) not present
  case 181: goto act_181;
  case 182: goto act_182;
  case 183: goto act_183;
  case 184: goto act_184;
  case 185: goto act_185;
  case 186: goto act_186;
  case 187: goto act_187;
  case 188: goto act_188;
  case 189: goto act_189;
  case 190: goto act_190;
  case 191: goto act_191;
  case 192: goto act_192;
  case 193: goto act_193;
  case 194: goto act_194;
  case 195: goto act_195;
  case 196: goto act_196;
  case 197: goto act_197;
  case 198: goto act_198;
  case 199: goto act_199;
  case 120: goto act_default;  // act(200) not present
  default: goto act_default;
  }
#endif

act_default:
  BADSWITCH(class, __LINE__, __FILE__);

a5:
  // REVERSE LINKS
  s = 0;
  while (node != 0) {
    z = &ar[node].link /* Pointer assignment */;
    k = *z;
    *z = s;
    s = node;
    node = k;
  }
  ss = s;
a6:
  if (nmax != 0) {
    k = gentype;  // type of phrase
    arp = &ar[nmax] /* Pointer assignment */;
    nmax -= 1;
    node = arp->class;
    gentype = arp->link;
    ptype = arp->ptype;
    pformat = arp->pformat;
    g = arp->sub;
    if ((g & escape) != 0) {
      g -= escape;
      papp = arp->papp;
      mark = 255;
      subatom = s;
      goto a3;
    }
    if ((gentype == 0) || (k == real)) gentype = k;
    type = gentype;

    k = gg;  // exit-point code
    for (;;) {
      gg = gram(g);
      if (k == 0) goto a2;
      if (gg >= 0) goto fail1;  // no alternative phrase
      k -= orderbit;
      g += 1;  // sideways step
    }
  }

  if (copy != 0) fault(4, tbase);
  if (order == 0) fault(13, tbase);
  if (forwarn != 0) fault(-4, tbase);
  pos1 = 0;
  faultrate -= 1;
  nreturn;

act_193: /* 193 */
  if (!((sym == '=') || (sym == '<'))) {
    gg = 0;
    goto a5;
  }                         // cdummy
act_181:                    /* 181 */
  atom1 = amap[decl & 15];  // dummy
  goto more;

act_182: /* 182 */
  class = escdec;
  g = glink(g) | escape;  // original Imp77 source had this looking like a comment!  Checking with others.
  decl = 0;
  otype = 0;
  goto esc;  // decl

act_199: /* 199 */  // COMPILE
  s = 0;
  while (node != 0) {
    z = &ar[node].link /* Pointer assignment */;
    k = *z;
    *z = s;
    s = node;
    node = k;
  }
  ss = s;

  if (quote != 0) codeatom(28, tmax, level, dmin, id, &key, &strp, tbase);  // expend
  compile(tmax, level, dmin, id, blocktag, l, access, tbase, bflags);
  if ((atom1 & error) == 0) goto more;
  goto fail1;

act_184: /* 184 */
  if (!(type == integer)) goto fail4;
  if (subatom < 0)
    lit = tag[-subatom].format;
  else
    lit = litpool[subatom];
  if (lit != 0) goto fail4;
  goto more;
act_185: /* 185 */  // APPLYPARAMETERS
  s = 0;
  while (node != 0) {
    z = &ar[node].link /* Pointer assignment */;
    k = *z;
    *z = s;
    s = node;
    node = k;
  }
  ss = s;

  atom1 = ar[s].class;
  atom2 = 0;
  if ((atom1 == 97) || (atom1 == 98)) atom1 = var;
  arp = &ar[nmax] /* Pointer assignment */;
  x = arp->x;
  pos1 = arp->pos;
  pos2 = 0;
  app = 0;
  format = tag[x].format;
  flags = tag[x].flags;
  type = (flags >> 4) & 7;
  protection = flags & prot;
  if ((flags & aname) != 0) protection = 0;

  if (((flags & subname) != 0) && (format != 0)) {
    if (formatselected() == 0) goto fail1;
  }

  goto a6;

act_187: /* 187 */
  protection = prot;
  goto more;  // %SETPROT
act_186:      /* 186 */
  if ((protection & prot) == 0) goto more;
  proterr = nmin;
  goto a7;
act_191:           /* 191 */
  k = protection;  // %GUARD
  codeatom(0, tmax, level, dmin, id, &key, &strp, tbase);
  if ((atomflags & aname) == 0) protection = k;
  goto more;

act_192: /* 192 */
  if (parsedmachinecode(level, dmin, id, &key, tmax, &strp, tbase) == 0) goto fail1;
  goto more;

act_189:           /* 189 */
  k = gapp(tmax);  // %GAPP
  deletenames(1, tmax, level, tbase);
  *tmax = *tbase;
  *tbase = gram(gmin);  // restore tmax
  local = *tbase;
  gmin += 1;

  x = ar[ar[nmax].class].sub;
  tag[x].app = k;  // update app
  goto more;

act_190:      /* 190 */
  gmin -= 1;  // %LOCAL
  if (gmin <= gmax) abandon(2);
  gram(gmin) = *tbase;
  *tbase = *tmax;
  local = *tbase;
  goto more;

  // errors

fail4:
  k = error + 10;
  goto failed;  // *size
fail3:
  k = error + 7;
  goto failed;  // *context
fail2:
  k = error + 5;
  pos2 = 0;
  goto failed;  // *type
fail0:
  k = error + 3;
  goto failed;  // *too complex
fail1:
  k = atom1;
  pos2 = 0;
failed:
  if ((diag & 32) != 0) {
    int gtsaved = outstream;
    selectoutput(0);
    printstring("Atom1 =");
    write(atom1, 3);  // A secondary issue is that shorts are not always converting to ints properly.
                      // Atom1 is displaying as 32769 instead of -32768 (0x8000 - error)
    printstring("  Atom2 =");
    write(atom2, 3);
    printstring("  subatom =");
    write(subatom, 3);
    newline();
    printstring("Type =");
    write(type, 1);
    printstring("   Ptype =");
    write(ptype, 1);
    newline();
    printstring("App =");
    write(app, 1);
    printstring("   Papp =");
    write(papp, 1);
    newline();
    printstring("Format =");
    write(format, 1);
    printstring("   Pformat =");
    write(pformat, 1);
    newline();
    selectoutput(gtsaved);
    signal_event(13, 15, 0);
  }

  while (((sym != nl) && (sym != ';'))) {
    quote = 0;
    readsym(&key);
  }
  if ((k & error) != 0) {
    fault(k & 255, tbase);
  } else {
    if (proterr == nmin)
      fault(14, tbase);
    else
      fault(0, tbase);
  }
  gg = 0;
  ss = 0;
  symtype = 0;
}  // of analyse

static void deflab(int l, int *access) {
  ENTER();
  op(':', l);
  *access = 1;
  nreturn;
}

static int pstack[40 + 1];  // (1:40) - Rebased to 0 rather than 1 for efficiency
static int count = 0;
static char name[9] = {'\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0'};

static void getnext(int *next, int *link, int *xclass) {
  ENTER();
  arfm *p;
gn:
  if (*next == 0) {  // end of phrase
    if (*link == 0) {
      *xclass = 0;
      nreturn;
    }  // end of statement
    p = &ar[*link] /* Pointer assignment */;
    *next = p->link;
    *link = p->sub;
  }
  for (;;) {
    p = &ar[*next] /* Pointer assignment */;
    x = p->sub;
    *xclass = p->class;
    if (*xclass < actions) break;  // an atom
    if (x == 0) {                  // null phrase
      *next = p->link;
      goto gn;
    }
    if (p->link != 0) {  // follow a phrase
      p->sub = *link;
      *link = *next;
    }
    *next = x;
  }
  *next = p->link;
  if ((diag & 2) != 0) {
    if (!(name[0] == '\0')) spaces(8 - strlen(name));
    strncpy(name, text(*xclass), 9);
    write(x, 2);
    space();
    printstring(name);
    space();
    count -= 1;
    if (count <= 0) {
      count = 5;
      name[0] = '\0';
      newline();
    }
  }
  nreturn;
}

static void setsubs(int n, int tmax, int *tbase) {
  ENTER();
  // update the app field in n array descriptors
  int p;
  p = tmax;
  while (n > 0) {
    if (p < *tbase) signal_event(15, 15, 0);
    tag[p].app = dimension;
    p -= 1;
    n -= 1;
  }
  nreturn;
}

static int lb, ub;
static void setbp(int *pending, int *next, int link, int *xclass, int *tbase) {
  ENTER();
  // define a constant bound pair from the last stacked constants
  *pending -= 2;
  lb = pstack[*pending + 1];
  ub = pstack[*pending + 2];
  if (ub - lb + 1 < 0) {
    pos1 = 0;
    *next = link;
    fault(11, tbase);
    ub = lb;
  }
  setconst(lb);
  setconst(ub);
  if (*xclass != 146) addchar('b');
  nreturn;
}

static void compileend(int type, int *level, int *dmin, int *blocktag, int *access, int *tbase, int *bflags) {
  ENTER();
  // type = 0:eof, 1:eop, 2:end
  if (*access != 0) {
    open = 0;
    if (blockform > proc) fault(19, tbase);  // can reach end
  }

  while (dict[*dmin] >= 0) {  // finishes & repeats
    fault(17 + (dict[*dmin] & 1), tbase);
    *dmin += 1;
  }
  // /*delete names(0);*/
  addchar(';');
  if (type == 1) addchar(';');  // endofprogram

  *bflags = *bflags | open;  // show if it returns

  // GTOAL: if ((*blocktag != 0) && (*level != 1)) deflab(0, access);  // for jump around
  if (type != 2) {                                           // eop, eof
    if (*level != type) fault(16, tbase);                    // end missing
  } else {
    if (*level == 0) {
      fault(15, tbase);  // spurious end
    }
  }

  endmark = 11;  // ******Mouses specific******
  nreturn;
}

static void def(int p, int *id, int *defs, int *lastdef, int *xclass) {
  ENTER();
  // dump a descriptor
  int t, f, type;
  tagfm *v;
  flushbuffer(1);  // flush if bp > 0
  *defs += 1;
  v = &tag[p] /* Pointer assignment */;
  t = 0;
  if (!(v->index < 0)) {  // no index for subnames
    if (v->index == 0) {
      *id += 1;
      v->index = *id;
    }
    *lastdef = v->index;
    t = *lastdef;
  }
  op('$', t);
  printident(p, 1);  // output the name
  t = v->flags;
  type = t;
  if ((type & (7 << 4)) >= (6 << 4)) type = type & (~(7 << 4));  // routine & pred
  op(',', type & 0b1111111);                                     // type & form
  f = v->format;
  if ((t & 0x70) == (record << 4)) f = tag[f].index;
  if (f < 0) f = v->index;
  op(',', f);  // format
  f = otype + ((t >> 4) & 0b1111000);
  if (*xclass == 125) f = f | 8;  // add spec from %DUP
  dim = v->app;                   // dimension
  if (!((0 < dim) && (dim <= dimlimit))) dim = 0;
  op(',', f + (dim << 8));  // otype & spec & prot
  if ((t & parameters) == 0) *defs = 0;
  f = t & 15;
  if ((v->flags & spec) != 0) {
    if (!((3 <= f) && (f <= 10))) v->flags = v->flags & (~spec);
    ocount = -1;  // external specs have no constants
  }
  dimension = 0;
  if ((otype == 2) && ((f == 2) || (f == 12) || (f == 14))) {
    v->flags = v->flags - 1;  // convert to simple
  }
  nreturn;
}

static void defslab(int n, int pending, int *access, int *tbase) {
  ENTER();
  // define a switch label, x defines the switch tag
  int p, l, b, w, bit;
  p = tag[x].format;  // pointer to table
  l = dict[p];        // lower bound
  if ((l <= n) && (n <= dict[p + 1])) {
    b = n - l;
    w = (b >> 4) + p;
    bit = 1 << (b & 15);
    if ((dict[w + 2] & bit) != 0) {  // already set
      if (pending != 0) fault(4, tbase);
      nreturn;
    }
    if (pending != 0) dict[w + 2] = dict[w + 2] | bit;
    setconst(n);
    op('_', tag[x].index);
  } else {
    fault(12, tbase);
  }
  *access = 1;
  nreturn;
}

static void call(int *access) {
  ENTER();
  tagfm *t;
  t = &tag[x] /* Pointer assignment */;
  op('@', t->index);
  if ((t->flags & closed) != 0) *access = 0;  // never comes back
  if (t->app == 0) addchar('E');              // no parameters
  nreturn;
}

static void popdef(int *pending) {
  ENTER();
  setconst(pstack[*pending]);
  *pending -= 1;
  nreturn;
}

static void poplit(int *pending) {
  ENTER();
  if (*pending == 0)
    lit = 0;
  else {
    lit = pstack[*pending];
    *pending -= 1;
  }
  nreturn;
}

// conditions & jumps
static unsigned char cnest[16];
static void push(int x, int *cp, int *clab) {
  ENTER();
  if ((cnest[*cp] & 2) != x) {
    cnest[*cp] = cnest[*cp] | 1;
    x += 4;
  }
  if ((cnest[*cp] & 1) != 0) *clab += 1;
  cnest[*cp + 1] = x;
  *cp += 1;
  nreturn;
}

static void poplabel(int mode, int *dmin, int *lmode, int *_label_, int *tbase) {
  ENTER();
  *lmode = dict[*dmin];
  if ((*lmode < 0) || ((*lmode & 1) != mode)) {
    fault(mode + 8, tbase);
  } else {
    *dmin += 1;
    *_label_ -= 3;
  }
  nreturn;
}

static void compile(int *tmax, int *level, int *dmin, int *id, int *blocktag, int *l, int *access, int *tbase, int *bflags) {
  ENTER();
  enum { then = 4, else_ = 8, loop = 16 };

#ifdef USE_GCC_EXTENSIONS
  static const void *c[actions + 1] = {
      // was 176, now 180+1 - need to examine this table closely
      &&c_0,       &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default,
      &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default,
      &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default,
      &&c_default, &&c_default, &&c_default, &&c_27,      &&c_28,      &&c_29,      &&c_30,      &&c_31,
      &&c_32,      &&c_33,      &&c_34,      &&c_35,      &&c_36,      &&c_37,      &&c_38,      &&c_39,
      &&c_default, &&c_41,      &&c_42,      &&c_43,      &&c_44,      &&c_45,      &&c_46,      &&c_47,
      &&c_48,      &&c_49,      &&c_50,      &&c_51,      &&c_52,      &&c_53,      &&c_default, &&c_55,
      &&c_56,      &&c_57,      &&c_58,      &&c_59,      &&c_60,      &&c_default, &&c_62,      &&c_63,
      &&c_64,      &&c_65,      &&c_default, &&c_67,      &&c_68,      &&c_69,      &&c_70,      &&c_71,
      &&c_72,      &&c_default, &&c_74,      &&c_75,      &&c_76,      &&c_77,      &&c_78,      &&c_79,
      &&c_80,      &&c_81,      &&c_82,      &&c_83,      &&c_84,      &&c_85,      &&c_86,      &&c_87,
      &&c_88,      &&c_89,      &&c_90,      &&c_91,      &&c_92,      &&c__const_, &&c_default, &&c_default,
      &&c_96,      &&c_97,      &&c_98,      &&c_99,      &&c_100,     &&c_101,     &&c_102,     &&c_103,
      &&c_104,     &&c_swit,    &&c_106,     &&c_107,     &&c_108,     &&c_109,     &&c_default, &&c_default,
      &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default, &&c_default,
      &&c_120,     &&c_121,     &&c_122,     &&c_default, &&c_124,     &&c_125,     &&c_126,     &&c_127,
      &&c_128,     &&c_default, &&c_130,     &&c_131,     &&c_132,     &&c_133,     &&c_134,     &&c_135,
      &&c_136,     &&c_137,     &&c_138,     &&c_139,     &&c_140,     &&c_141,     &&c_142,     &&c_143,
      &&c_144,     &&c_145,     &&c_146,     &&c_147,     &&c_148,     &&c_149,     &&c_default, &&c_151,
      &&c_152,     &&c_153,     &&c_154,     &&c_155,     &&c_156,     &&c_157,     &&c_158,     &&c_159,
      &&c_160,     &&c_161,     &&c_162,     &&c_163,     &&c_164,     &&c_165,     &&c_166,     &&c_167,
      &&c_168,     &&c_default, &&c_170,     &&c_171,     &&c_172,     &&c_173,     &&c_174,     &&c_175,
  };
#endif

#ifdef USE_GCC_EXTENSIONS
  static const void *litop[13] = {
      // (1:12) - Rebased to 0 rather than 1 for efficiency
      &&litop_default, &&litop_1, &&litop_2, &&litop_3,  &&litop_4,  &&litop_5,  &&litop_6,
      &&litop_7,       &&litop_8, &&litop_9, &&litop_10, &&litop_11, &&litop_12,
  };
#endif

  static const unsigned char operator[15] = {
      0,   '[', ']', 'X', '/', '&', '!', '%',
      '+', '-', '*', 'Q', 'x', '.', 'v'};  // (1:14) - Rebased to 0 rather than 1 for efficiency
  static const unsigned char cc[8] = {'#', '=', ')', '<', '(', '>', 'k', 't'};
  static const unsigned char anyform[16] = {1, 0, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1};

  static const int decmap[16] = {1,      2,      0x100B, 0x100D, 0x140C, 0x140E, 3, 4,
                                 0x1007, 0x1008, 0x1009, 0x100A, 6,      0,      0, 0};
  int lmode, clab, dupid;
  int resln;
  static int lastdef = 0;
  int cp, ord;
  int next, link, j, k, n;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  int done;
#endif
  int xclass;
  int lit2, defs, decs, cident;
  int pending;

  if (sstype < 0) {      // executable statement
    if (*level == 0) {   // outermost *level
      fault(13, tbase);  // *order
    } else {
      if (*access == 0) {
        *access = 1;
        fault(-1, tbase);  // only a warning
      }
    }
  }

  if ((diag & 2) != 0) {
    if (sym != nl) newline();
    printstring("ss =");
    write(ss, 1);
    newline();
    count = 5;
    name[0] = '\0';
  }

  next = ss;
  pending = 0;
  lmode = 0;
  link = 0;
  decs = 0;
  defs = 0;
  resln = 0;
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
  done = 0;
#endif
  ord = *level;
  if (this >= 0) ord = 1;  // recordformat declarations
c_0:                       /* 0 */
top:
  if (next != link) {
    getnext(&next, &link, &xclass);
    if ((xclass > actions) || (class < 0)) BADSWITCH(class, __LINE__, __FILE__);
#ifdef USE_GCC_EXTENSIONS
    goto *c[xclass];
#else
      // was 176, now 180+1 - need to examine this table closely
  switch (xclass) {
    case 0: goto c_0;
    case 1: goto c_default;
    case 2: goto c_default;
    case 3: goto c_default;
    case 4: goto c_default;
    case 5: goto c_default;
    case 6: goto c_default;
    case 7: goto c_default;
    case 8: goto c_default;
    case 9: goto c_default;
    case 10: goto c_default;
    case 11: goto c_default;
    case 12: goto c_default;
    case 13: goto c_default;
    case 14: goto c_default;
    case 15: goto c_default;
    case 16: goto c_default;
    case 17: goto c_default;
    case 18: goto c_default;
    case 19: goto c_default;
    case 20: goto c_default;
    case 21: goto c_default;
    case 22: goto c_default;
    case 23: goto c_default;
    case 24: goto c_default;
    case 25: goto c_default;
    case 26: goto c_default;
    case 27: goto c_27;
    case 28: goto c_28;
    case 29: goto c_29;
    case 30: goto c_30;
    case 31: goto c_31;
    case 32: goto c_32;
    case 33: goto c_33;
    case 34: goto c_34;
    case 35: goto c_35;
    case 36: goto c_36;
    case 37: goto c_37;
    case 38: goto c_38;
    case 39: goto c_39;
    case 40: goto c_default;
    case 41: goto c_41;
    case 42: goto c_42;
    case 43: goto c_43;
    case 44: goto c_44;
    case 45: goto c_45;
    case 46: goto c_46;
    case 47: goto c_47;
    case 48: goto c_48;
    case 49: goto c_49;
    case 50: goto c_50;
    case 51: goto c_51;
    case 52: goto c_52;
    case 53: goto c_53;
    case 54: goto c_default;
    case 55: goto c_55;
    case 56: goto c_56;
    case 57: goto c_57;
    case 58: goto c_58;
    case 59: goto c_59;
    case 60: goto c_60;
    case 61: goto c_default;
    case 62: goto c_62;
    case 63: goto c_63;
    case 64: goto c_64;
    case 65: goto c_65;
    case 66: goto c_default;
    case 67: goto c_67;
    case 68: goto c_68;
    case 69: goto c_69;
    case 70: goto c_70;
    case 71: goto c_71;
    case 72: goto c_72;
    case 73: goto c_default;
    case 74: goto c_74;
    case 75: goto c_75;
    case 76: goto c_76;
    case 77: goto c_77;
    case 78: goto c_78;
    case 79: goto c_79;
    case 80: goto c_80;
    case 81: goto c_81;
    case 82: goto c_82;
    case 83: goto c_83;
    case 84: goto c_84;
    case 85: goto c_85;
    case 86: goto c_86;
    case 87: goto c_87;
    case 88: goto c_88;
    case 89: goto c_89;
    case 90: goto c_90;
    case 91: goto c_91;
    case 92: goto c_92;
    case 93: goto c__const_;
    case 94: goto c_default;
    case 95: goto c_default;
    case 96: goto c_96;
    case 97: goto c_97;
    case 98: goto c_98;
    case 99: goto c_99;
    case 100: goto c_100;
    case 101: goto c_101;
    case 102: goto c_102;
    case 103: goto c_103;
    case 104: goto c_104;
    case 105: goto c_swit;
    case 106: goto c_106;
    case 107: goto c_107;
    case 108: goto c_108;
    case 109: goto c_109;
    case 110: goto c_default;
    case 111: goto c_default;
    case 112: goto c_default;
    case 113: goto c_default;
    case 114: goto c_default;
    case 115: goto c_default;
    case 116: goto c_default;
    case 117: goto c_default;
    case 118: goto c_default;
    case 119: goto c_default;
    case 120: goto c_120;
    case 121: goto c_121;
    case 122: goto c_122;
    case 123: goto c_default;
    case 124: goto c_124;
    case 125: goto c_125;
    case 126: goto c_126;
    case 127: goto c_127;
    case 128: goto c_128;
    case 129: goto c_default;
    case 130: goto c_130;
    case 131: goto c_131;
    case 132: goto c_132;
    case 133: goto c_133;
    case 134: goto c_134;
    case 135: goto c_135;
    case 136: goto c_136;
    case 137: goto c_137;
    case 138: goto c_138;
    case 139: goto c_139;
    case 140: goto c_140;
    case 141: goto c_141;
    case 142: goto c_142;
    case 143: goto c_143;
    case 144: goto c_144;
    case 145: goto c_145;
    case 146: goto c_146;
    case 147: goto c_147;
    case 148: goto c_148;
    case 149: goto c_149;
    case 150: goto c_default;
    case 151: goto c_151;
    case 152: goto c_152;
    case 153: goto c_153;
    case 154: goto c_154;
    case 155: goto c_155;
    case 156: goto c_156;
    case 157: goto c_157;
    case 158: goto c_158;
    case 159: goto c_159;
    case 160: goto c_160;
    case 161: goto c_161;
    case 162: goto c_162;
    case 163: goto c_163;
    case 164: goto c_164;
    case 165: goto c_165;
    case 166: goto c_166;
    case 167: goto c_167;
    case 168: goto c_168;
    case 169: goto c_default;
    case 170: goto c_170;
    case 171: goto c_171;
    case 172: goto c_172;
    case 173: goto c_173;
    case 174: goto c_174;
    case 175: goto c_175;
  }
#endif
  c_default:
    BADSWITCH(xclass, __LINE__, __FILE__);
  }

  // all done, tidy up declarations and jumps
  if (((diag & 2) != 0) && (count != 5)) newline();

  if ((lmode & (loop | then | else_)) != 0) {               // pending labels and jumps
    if ((lmode & loop) != 0) op('B', _label_ - 1);          // repeat
    if ((lmode & then) != 0) deflab(_label_, access);       // entry from then
    if ((lmode & else_) != 0) deflab(_label_ - 1, access);  // entry from else
  }

  if (decs == 0) nreturn;
  if (atom1 != 0) {
    atom1 = error;
    nreturn;
  }  // %integerroutine
  order = ord;
  decl = (decl & (~15)) + decmap[decl & 15];  // construct declarator flags
  atom1 = atoms[decl & 15];                   // generate class
  if (otype != 0) {                           // own, const etc.
    if (atom1 != proc) atom1 += 1;
    if (otype == 2) {  // const
      n = decl & 15;
      if ((n & 1) != 0) {
        decl = decl | prot;
        if ((decl & 0b1111111) == iform) decl = decl | constbit;
      }
    } else {
      decl = decl | ownbit;
    }
  }
  if (((sstype == 0) && (atom1 == proc))) sstype = 1;
  if ((decl & spec) != 0) atom1 += 1;  // onto spec variant
  if (atom1 == 5) {
    ocount = 0;
    cont = '+';
  }                               // own array
  if (anyform[decl & 15] == 0) {  // check meaningful
    if (((decl >> 4) & 7) == record) {
      if ((tag[fdef].flags & spec) != 0) this = fdef;
      if (fdef == this) atom1 = error + 21;  // *context for format
    }
    if (fdef == 0) atom1 = error + 10;  // *size
  }
  nreturn;

atop:
  *access = 0;
  goto top;
  // declarators
c_88: /* 88 */                                               // RTYPE
c_28:                                                        /* 28 */
  decl = x & (~7);                                           // stype
  fdef = x & 7;                                              // precision
  if ((x & 0b1110001) == ((real << 4) + 1)) fdef = realsln;  // convert to long
  decs = 1;
  goto top;
c_34: /* 34 */  // OWN
c_35:           /* 35 */
  otype = x;
  ord = 1;
  goto top;  // external
c_152:       /* 152 */
  decl = decl + (x << 1);
  goto top;                        // xname
c_31: /* 31 */                     // PROC
c_32:                              /* 32 */
  specmode = *level + 1;           // fn/map
  if (x == 9) decl = decl | prot;  // function
c_29:                              /* 29 */
  ord = 1;                         // array
  dim = 0;
c_30:         /* 30 */
  decl += x;  // name
  decs = 1;
  goto top;
c_27:       /* 27 */
  lit = 0;  // arrayd
  if (pending != 0) {
    poplit(&pending);
    if (!((0 < lit) && (lit <= dimlimit))) {
      atom1 = error + 11;
      nreturn;
    }
  }
  dim = lit;
  decl += x;
  decs = 1;
  goto top;
c_37:               /* 37 */
  x = x | subname;  // record
c_36:               /* 36 */
  lit = 0;          // string
  if (pending != 0) {
    poplit(&pending);
    if (!((0 < lit) && (lit <= 255))) {  // max length wrong
      atom1 = error + 10;
      nreturn;
    }
  }
  fdef = lit;  // format or length
c_33:          /* 33 */
  decl = x;    // switch
  decs = 1;
  goto top;
c_39:                  /* 39 */
  decl = decl | spec;  // spec
  ocount = -1;         // no initialisation
  specmode = -1;
  goto top;
c_38:             /* 38 */
  decl = 64 + 4;  // recordformat (spec)
  order = 1;
  atom1 = x;
  if (atom1 == 12) decl = decl | spec;  // formatspec
  fdef = *tmax + 1;                     // format tag
  nreturn;
c_175: /* 175 */
  *id += 1;
  tag[x].index = *id;
  nreturn;  // FSID
c_41:       /* 41 */
  decs = 1;
  decl = x | spec | closed;
  goto top;  // label
c_133:       /* 133 */
  recid = 0;
  rbase = tmin - 1;  // fname
  this = x;
  fmbase = fdef;
  formatlist = tmin;
  def(this, id, &defs, &lastdef, &xclass);
  goto top;
c_148: /* 148 */
  if (next == 0) {
    fdef = 0;
    goto top;
  }                                // reclb
  getnext(&next, &link, &xclass);  // skip name
  fdef = x;
  goto top;

c_127: /* 127 */
  addchar('}');
  goto top;  // %POUT
c_126:       /* 126 */
  addchar('{');
  goto top;                                      // %PIN
c_174:                                           /* 174 */
  setbp(&pending, &next, link, &xclass, tbase);  // rangerb
c_171: /* 171 */                                 // FMLB
c_172: /* 172 */                                 // FMRB
c_173:                                           /* 173 */
  addchar('~');
  addchar(xclass - 171 + 'A');
  goto top;        // fmor
c_168:             /* 168 */
  rbase = -rbase;  // orrb
  sstype = 0;
  specmode = 0;

c_147:             /* 147 */
  searchbase = 0;  // recrb
  tag[this].app = tmin;
  tag[this].format = rbase;
  goto top;

c_45: /* 45 */
  if (x == 36) addchar('U');
  goto top;  // sign
c_46:        /* 46 */
  addchar('\\');
  goto top;     // uop
c_47: /* 47 */  // MOD
c_48: /* 48 */  // DOT
c_42: /* 42 */  // OP1
c_43: /* 43 */  // OP2
c_44:           /* 44 */
  addchar(operator[x]);
  goto top;     // op3
c_56: /* 56 */  // AND
c_57:           /* 57 */
  push(x, &cp, &clab);
  goto top;  // or
c_58:        /* 58 */
  cnest[cp] = cnest[cp] ^ 2;
  goto top;               // not
c_138:                    /* 138 */
  x = 128 + 32 + 16 + 4;  // csep: treat like %while
c_59: /* 59 */            // WHILE
c_60:                     /* 60 */
  if (xclass == 138)
    op('f', _label_ - 1);
  else
    deflab(_label_ - 1, access);                // until
c_166: /* 166 */                                // RUNTIL
c_62:                                           /* 62 */
  lmode = (lmode & (else_ | loop)) | (x >> 3);  // cword
  clab = _label_;
  cp = 1;
  cnest[1] = x & 7;
  goto top;
c_72:                                          /* 72 */
  poplabel(0, dmin, &lmode, &_label_, tbase);  // repeat
  if ((lmode & 32) != 0) deflab(_label_ + 1, access);
  goto atop;
c_69: /* 69 */
  poplabel(1, dmin, &lmode, &_label_, tbase);
  goto top;                                    // finish
c_163: /* 163 */                               // XELSE
c_70:                                          /* 70 */
  poplabel(1, dmin, &lmode, &_label_, tbase);  // finish else ...
  if ((lmode & 3) == 3) fault(7, tbase);       // dangling else
c_68:                                          /* 68 */
  lmode = (lmode & else_) | 3;                 // ...else...
  if (*access != 0) {
    op('F', _label_ - 1);
    lmode = else_ | 3;
  }
  deflab(_label_, access);
  if (next != 0) goto top;
c_120: /* 120 */  // mstart
c_67: /* 67 */    // START
c_71: /* 71 */    // CYCLE
stcy:
  if (lmode == 0) {
    deflab(_label_ - 1, access);
    lmode = loop;
  }  // cycle
  *dmin -= 1;
  if (*dmin <= dmax) abandon(3);
  dict[*dmin] = lmode;
  _label_ += 3;
  nreturn;

c_64:                                                            /* 64 */
  if (((dict[*dmin] >= 0) || (inhibit != 0))) fault(13, tbase);  // on event
  inhibit = 1;
  n = 0;
  if (pending == 0) n = 0xFFFF;  // * = all events
  while (pending > 0) {
    poplit(&pending);
    if ((lit & (~15)) != 0) fault(10, tbase);  // too big
    j = 1 << lit;
    if ((n & j) != 0) dubious = 1;
    n = n | j;  // construct bit mask
  }
  op('o', n);
  op(',', _label_);
  lmode = then | 1;
  goto stcy;

c_104:                    /* 104 */
  op('J', tag[x].index);  // l
  inhibit = 1;
  goto atop;
c_149:         /* 149 */
  stats -= 1;  // lab
  *access = 1;
  inhibit = 1;
  op('L', tag[x].index);
  goto top;

c_63: /* 63 */
  j = *dmin;
  *l = _label_ - 3;  // exit, continue
  for (;;) {
    if (dict[j] < 0) {
      fault(7, tbase);
      goto top;
    }
    if ((dict[j] & 1) == 0) break;
    j += 1;
    *l -= 3;
  }
  if (x == 32) *l += 1;  // continue
  op('F', *l);
  dict[j] = dict[j] | x;  // show given
  goto atop;

c_50: /* 50 */
  addchar('C');
  goto cop;         // acomp
c_49:               /* 49 */
  if (next != 0) {  // comparator
    addchar('"');
    push(0, &cp, &clab);  // double sided
  } else {
    addchar('?');
  }
 
cop:
  if ((cnest[cp] & 2) != 0) x = x ^ 1;  // invert the condition
  j = cp;
  *l = clab;
  while ((cnest[j] & 4) == 0) {
    j -= 1;
    *l = *l - (cnest[j] & 1);
  }
  op(cc[x], *l);
  if ((cnest[cp] & 1) != 0) deflab(clab + 1, access);
  cp -= 1;
  clab = clab - (cnest[cp] & 1);
  goto top;

c_78: /* 78 */  // Freturn
c_79: /* 79 */  // Mreturn
c_80:           /* 80 */
  open = 0;     // return, true, false
c_82:           /* 82 */
  *access = 0;  // stop
c_89: /* 89 */  // ADDOP
c_81:           /* 81 */
  addchar(x);
  goto top;  // monitor
c_65:        /* 65 */
  poplit(&pending);
  op('e', lit);
  goto atop;  // signal
c_51:         /* 51 */
  addchar('S');
  goto top;  // eq
c_53:        /* 53 */
  addchar('j');
  goto top;  // jam transfer
c_52:        /* 52 */
  addchar('Z');
  goto top;           // eqeq
c_74:                 /* 74 */
  if (*level == 0) {  // begin
    if (progmode <= 0)
      progmode = 1;
    else
      fault(7, tbase);
    // {Permit BEGIN after external defs}
  }
  specmode = *level + 1;
  blockx = 0;
  addchar('H');
  nreturn;
c_77: /* 77 */
  perm = 0;
  lines = 0;
  stats = 0;  // endofperm
  closeinput();
  selectinput(SOURCE);
  current_input_filename[SOURCE] = strdup(sourcefile); // source file follows perm
  list -= 1;
  *tbase = *tmax;
  tstart = *tmax;
  nreturn;
c_76:                                  /* 76 */
  if (((include != 0) && (x == 0))) {  // end of ...
    
    // GTOAL: pass back change of filename on closing an include file...
    // (unfortunately this currently causes idec to print the %include line again
    //  which I don't really want.  I'll try to find a workaround.)
    
    int laststream = instream-1;

    /* lines = include; */ lines = includelines[laststream];
    sstype = 0;  // include
    closeinput();
    list = includelist; // TO DO: These three lines may need to be conditional on instream <= SOURCE?
    includelevel = 0;
    include = 0;

    selectinput(laststream);
    
    op('O', lines); // extended LINE ('O') opcode compared to original ICODE definition
    op_filename(current_input_filename[instream]);
  
    nreturn;
  }
  ss = -1;  // prog/file
c_75:       /* 75 */
  compileend(x, level, dmin, blocktag, access, tbase, bflags);
  nreturn;             // %end
c_85:                  /* 85 */
  if (x == 0) {        // control
#ifdef INCLUDE_UNUSED  // Either never written to, or written to but never read from
    control = lit;
#endif
  } else {
    if (((lit >> 14) & 3) == 1) diag = lit & 0x3FFF;
  }
  op('z' - x, lit);  // But it *is* passed on to pass2 which is a relief...
  goto top;
c_83: /* 83 */
  list = list + x - 2;
  goto top;  // %LIST/%endoflist
c_84:        /* 84 */
  realsln = x;
  goto top;            // %REALS long/normal
c_86:                  /* 86 */
#ifdef NEVER // GTOAL: removing restriction on nested include files!
  if (include != 0) {  // include "file"
    fault(7, tbase);
    nreturn;
  }
#endif
  getnext(&next, &link, &xclass);  // sconst
  x -= 0x4000;
  j = glink(x);
  k = j & 255;
  // ABD - another little copy loop because SKIMP can't do the string map
  includefile[0] = '\0';
  for (;;) {
    k -= 1;
    if (k < 0) break;
    strcat(includefile, tostring(j >> 8));  // inefficient in C transation...
    x += 1;
    j = glink(x);
    k -= 1;
    if (k < 0) break;
    strcat(includefile, tostring(j & 255));
  }
  // include file = string(x-16_4000+stbase)
  {
    extern int opt_verbose;
    
    if (on_event(9)) {
      // remove this event block for SKIMP or pre-event IMP versions
      fprintf(stderr, "* Cannot %%include \"%s\" - %s\n", includefile, strerror(errno));
      abandon(9);
    }
    // TO DO: include file should be relative to either the source file path
    // or the current directory - probably the former.  Unless it is an absolute filename
    if (*includefile != '/') {
      // Relative
      char tmp[1024], *s;
      strcpy(tmp, sourcefile);
      s = strrchr(sourcefile, '/');
      if (s) {
        sprintf(s+1, "%s", includefile);
        FILE *test = fopen(sourcefile, "r");
        if (!test) {
          char tmp[1024];
          strcpy(tmp, includefile);
          strcpy(includefile, fullpath(tmp));
        } else {
          fclose(test);
          strcpy(includefile, sourcefile);
        }
      }
    }
    if (opt_verbose) fprintf(stderr, "? Reading include file \"%s\"\n", includefile);

    // TO DO: issue an ICODE to set the current input file name.  Push the old filename
    //        first and pop it again at the end of the include file.  I think there
    //        actually is an include file ICODE in a later version of ICODE than this
    //        one outputs, but I don't know for sure if it behaves the same way as
    //        what I need.

    //        It matters because the output with the interleaved C and ICODE and source code
    //        messes up completely when the 'O' (LINE) ICODEs output the source line from
    //        the wrong file.  An awkward workaround would be to either save/restore the
    //        line numbers or to add the number of lines in the included files.  I'ld
    //        need to do some practical experiments to work out what needs to be done.

    //        Another alternative would be to save all the input that's being compiled
    //        to a private buffer, and have i2c print out the source in the buffer whenever
    //        it processed the LINE opcode, emptying the buffer at the same time.  Since
    //        we don't have a clean way of telling the icode interpreter of the change in
    //        input filename anyway, this is no dirtier than passing back the filename
    //        via a global variable either. (The ideal solution of course would be to
    //        add a new ICODE to pass the filename when it changes).

    //        Note that I don't think the original code properly reset the line number to
    //        1 on opening an include file.  So we'll need to add a stack containing the
    //        current line number when an include file is opened, that we'll revert to
    //        when it is closed again.


    openinput(instream+1, includefile); // GTOAL: added for nested include file support
    //openinput(instream+1, fullpath(includefile)); ... path handling now done elsewhere
    // GTOAL: added for nested include file support, then for include path searching

  }

  include = lines;  includelines[instream] = lines; // for restoration on end of include file
  lines = 0;
  includelist = list;   // TO DO: I need to understand the purpose of these two variables...
  includelevel = *level;    // (this appears to be related to block level but not sure why that is relevant to include files?)

  selectinput(instream+1); // GTOAL: added for nested include file support
  current_input_filename[instream] = strdup(includefile);

  goto top;

c_154:             /* 154 */
  dimension += 1;  // dbsep
  if (dimension == (dimlimit + 1)) fault(11, tbase);
  goto top;
c_145: /* 145 */
  setbp(&pending, &next, link, &xclass, tbase);
  goto top;                                      // crb
c_146:                                           /* 146 */
  setbp(&pending, &next, link, &xclass, tbase);  // rcrb
c_142: /* 142 */                                 // BPLRB
  if (dimension == 0) dimension = 1;
  op('d', dimension);
  op(',', defs);
  if (xclass != 146) {
    setsubs(defs, *tmax, tbase);
    if ((dict[*dmin] >= 0) || (inhibit != 0) || (*level == 0)) fault(13, tbase);
  }
  dimension = 0;
  defs = 0;
  goto top;
c_128: /* 128 */
  *id = dupid;
  goto top;  // EDUP
c_130:       /* 130 */
  blockx = x;
//  if ((((decl & spec) == 0) && (*level != 0))) op('F', 0);  // jump round proc   // GTOAL: not wanted in icode to C conversion! (C doesn't like proc decls after jumps)
c_125:                                                      /* 125 */
  dupid = *id;                                              // %DUP
  if (*level < 0) nreturn;                                  // {spec about}
c_90:                                                       /* 90 */
  def(x, id, &defs, &lastdef, &xclass);
  goto top;       // ident
c_131: /* 131 */  // CIDENT
  if ((tag[x].flags & (0b1111111 + constbit)) == (iform + constbit)) {
    tag[x].format = lit;
  } else {
    if (pending != 0) setconst(lit);
    def(x, id, &defs, &lastdef, &xclass);
    op('A', 1);
  }
  cident = x;
  goto top;
c_124:                                               /* 124 */
  if ((tag[cident].flags & prot) != 0) dubious = 1;  // %DUBIOUS
  goto top;
c_97: /* 97 */  // F
c_98: /* 98 */  // M
c_99: /* 99 */  // P
c_96:           /* 96 */
  call(access);
  goto top;       // r
c_165: /* 165 */  // NLAB
c_100: /* 100 */  // RP
c_101: /* 101 */  // FP
c_102: /* 102 */  // MP
c_103: /* 103 */  // PP
c_91: /* 91 */    // V
c_92: /* 92 */    // N
c_106: /* 106 */  // A
c_107: /* 107 */  // AN
c_108: /* 108 */  // NA
c_109: /* 109 */  // NAN
  k = tag[x].index;
  if (k < 0)
    op('n', -k);
  else
    op('@', k);
  goto top;
c_121: /* 121 */
  setconst(0);
  goto top;  // special for zero
c_167:       /* 167 */
  addchar('G');
  goto pstr;              // aconst (alias)
c__const_: /* _const_ */  // CONST
  if (x < 0) {            // constinteger
    setconst(tag[-x].format);
    goto top;
  }
  if ((x & 0x4000) != 0) {  // strings
    addchar('\'');          // addchar (39) would be safer given current bug in imp2c!
  pstr:
    x -= 0x4000;
    j = glink(x);
    k = j & 255;
    addchar(k);
    for (;;) {
      k -= 1;
      if (k < 0) goto top;
      addchar(j >> 8);
      x += 1;
      j = glink(x);
      k -= 1;
      if (k < 0) goto top;
      addchar(j & 255);
    }
  }
  if ((x & 0x2000) != 0) {  // real - ABD also string-like, but NOT packed
    x -= 0x2000;
    k = glink(x);
    op('D', k);
    addchar(',');
    for (;;) {
      if (k == 0) goto top;
      k -= 1;
      x += 1;
      j = glink(x);
      if (j == '@') {
        op('@', litpool[glink(x + 1)]);
        goto top;
      }
      addchar(j);
    }
  }
  setconst(litpool[x]);
  goto top;

c_137: /* 137 */
  addchar('i');
  goto top;  // asep
c_141:       /* 141 */
  addchar('a');
  goto top;  // arb

  // own arrays
c_132: /* 132 */
  ocount = ub - lb + 1;
  def(x, id, &defs, &lastdef, &xclass);  // oident
  dimension = 1;
  setsubs(1, *tmax, tbase);
  if (next == 0) {  // no initialisation
    if (ocount > 0) op('A', ocount);
    ocount = -1;
  } else {  // initialisation given
    getnext(&next, &link, &xclass);
  }
  goto top;
c_162: /* 162 */
  lit = ocount;
  goto ins;          // indef
c_143:               /* 143 */
  poplit(&pending);  // orb
ins:
  if (lit < 0) {
    fault(10, tbase);
    lit = 0;
  }
  getnext(&next, &link, &xclass);
  goto inst;
c_139: /* 139 */  // OSEP(X=19)
c_153:            /* 153 */
  lit = 1;
inst:
  if (pending != 0) popdef(&pending);  // ownt (x=0)
  op('A', lit);
  ocount -= lit;
  if (ocount >= 0) {
    if (x != 0) goto top;  // more coming
    if (ocount == 0) {
      ocount = -1;
      nreturn;
    }  // all done
  }
  fault(11, tbase);
  nreturn;

c_swit: /* swit */
  op('W', tag[x].index);
  inhibit = 1;
  goto atop;
c_134:                                   /* 134 */
  def(x, id, &defs, &lastdef, &xclass);  // swid
  n = ub - lb + 1;
  n = (n + 15) >> 4;  // slots needed (includes zero)
  j = dmax;
  dmax = dmax + n + 2;
  if (dmax >= *dmin) abandon(1);
  tag[x].format = j;
  dict[j] = lb;
  dict[j + 1] = ub;
  for (;;) {
    n -= 1;
    if (n < 0) goto top;
    j += 1;
    dict[j + 1] = 0;
  }
c_151:         /* 151 */
  stats -= 1;  // slab
  if (x < *tbase) {
    fault(7, tbase);
    nreturn;
  }
  if (pending != 0) {  // explicit label
    defslab(pstack[1], pending, access, tbase);
  } else {
    if (tag[x].app != 0) {
      fault(4, tbase);
      nreturn;
    }
    tag[x].app = 1;
    n = tag[x].format;
    // This is where SW(*): outputs all the currently unused
    // switch label indices.  Unfortunately those labels may
    // subsequently occur in the user's code which makes a
    // one-pass handling of switches very awkward.  I am *very*
    // tempted to replace outputting these multiple labels with
    // a new icode I need to create for 'default switch label:'
    // which will let me handle a default (or a missing label
    // when there is no default) in the same more rational way
    // that I did in imptoc.
#ifdef ORIGINAL_ICODE
    for (j = dict[n]; j <= dict[n + 1]; j += 1) {
      defslab(j, pending, access, tbase);
      flushbuffer(128);  // flush if bp >= 128
    }
#else
    op('`', tag[x].index); // EXTENDED ICODE: DEFSWLABEL
    *access = 1;
#endif
  }
  inhibit = 1;
  nreturn;

c_140: /* 140 */
  addchar('p');
  goto top;       // psep
c_144: /* 144 */  // PRB
  addchar('p');
  addchar('E');
  goto top;

  // constant expressions
c_155: /* 155 */  // PCONST
  if (x < 0)
    lit = tag[-x].format;
  else
    lit = litpool[x];
  pending += 1;
  pstack[pending] = lit;
  goto top;
c_156: /* 156 */
  lit = pstack[pending];
  if (lit < 0) lit = -lit;
  pstack[pending] = lit;
  goto top;  // cmod
c_157:       /* 157 */
  lit = -pstack[pending];
  pstack[pending] = lit;
  goto top;  // csign
c_158:       /* 158 */
  lit = ~pstack[pending];
  pstack[pending] = lit;
  goto top;       // cuop
c_159: /* 159 */  // COP1
c_160: /* 160 */  // COP2
c_161:            /* 161 */
  pending -= 1;   // cop3
  lit2 = pstack[pending + 1];
  lit = pstack[pending];
  if (((x >> 2) < 1) || ((x >> 2) > 12)) BADSWITCH(x >> 2, __LINE__, __FILE__);
#ifdef USE_GCC_EXTENSIONS
  goto *litop[x >> 2];
#else
  // (1:12) - Rebased to 0 rather than 1 for efficiency
  switch (x >> 2) {
  case 0: goto litop_default;
  case 1: goto litop_1;
  case 2: goto litop_2;
  case 3: goto litop_3;
  case 4: goto litop_4;
  case 5: goto litop_5;
  case 6: goto litop_6;
  case 7: goto litop_7;
  case 8: goto litop_8;
  case 9: goto litop_9;
  case 10: goto litop_10;
  case 11: goto litop_11;
  case 12: goto litop_12;
  }
#endif
litop_default:
  BADSWITCH(x >> 2, __LINE__, __FILE__);

litop_1: /* 1 */
  lit = lit << lit2;
  goto setl;
litop_2: /* 2 */
  lit = (unsigned int)lit >> (unsigned int)lit2;
  goto setl;
litop_3:  /* 3 */
  n = 1;  // lit = lit\\lit2
  if (lit2 < 0) fault(10, tbase);
  while (lit2 > 0) {
    lit2 -= 1;
    n = n * lit;
  }
  lit = n;
  goto setl;
litop_4: /* 4 */
  if (lit2 == 0)
    fault(10, tbase);
  else
    lit = ((int)(lit) / (int)(lit2));
  goto setl;
litop_5: /* 5 */
  lit = lit & lit2;
  goto setl;
litop_6: /* 6 */
  lit = lit | lit2;
  goto setl;
litop_7: /* 7 */
  lit = lit ^ lit2;
  goto setl;
litop_8: /* 8 */
  lit += lit2;
  goto setl;
litop_9: /* 9 */
  lit -= lit2;
  goto setl;
litop_10: /* 10 */
  lit = lit * lit2;
  goto setl;
litop_11: /* 11 */
  lit += lit2;
  goto setl;
litop_12: /* 12 */
  n = 1;  // lit = lit\\lit2
  if (lit2 < 0) fault(10, tbase);
  while (lit2 > 0) {
    lit2 -= 1;
    n = n * lit;
  }
  lit = n;
  goto setl;
setl:
  pstack[pending] = lit;
  goto top;

c_170: /* 170 */
  // Fault (4) %if IMPCOM_Option # ""
  // IMPCOM_Option = String(x-x'4000'+Stbase); ! Option string
  goto top;

  // string resolution
c_135: /* 135 */
  resln = 2;
  goto top;  // dotl
c_136:       /* 136 */
  resln += 1;
  goto top;  // dotr
c_55:        /* 55 */
  op('r', resln);
  resln = 0;
  goto top;  // resop
c_164:       /* 164 */
  op('r', resln + 4);
  resln = 0;  // cresop
c_122:        /* 122 */
  x = 6;
  goto cop;             // %PRED
c_87:                   /* 87 */
  setconst(pstack[1]);  // mass
  {
    bp += 1;
    buff[bp] = 'P';
  }
  goto top;
  nreturn;
}

// *Temporary* new code for C/Linux:
int pass1(char *source, char *perm, char *icode, char *list) {  // i77p1 $1,$INCDIR/stdperm.imp $SRCNAME.icd,$LISTFILE
  ENTER();

  sourcefile = source;
  selectoutput(0);

  if (perm == NULL) {
    fprintf(stderr, "i2c: first parameter should be source.imp,stdperm.imp\n");
    exit(__LINE__/*EXIT_FAILURE*/);
  }

  if (on_event(9)) {
    fprintf(stderr, "i2c: could not open source file \"%s\" - %s\n", source, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  if (!openinput(SOURCE, source)) {  // source
    fprintf(stderr, "i2c: could not open source file \"%s\" - %s\n", source, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  
  if (on_event(9)) {
    fprintf(stderr, "i2c: could not open prims+perms file \"%s\" - %s\n", perm, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  if (!openinput(PERM, perm)) {  // prims+perms
    fprintf(stderr, "i2c: could not open prims+perms file \"%s\" - %s\n", perm, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  current_input_filename[0] = strdup(perm);
  
  if (list == NULL) {
    fprintf(stderr, "i2c: second parameter should be source.icd,source.lis\n");
    exit(__LINE__/*EXIT_FAILURE*/);
  }

  if (on_event(9)) {
    fprintf(stderr, "i2c: could not create object (icode) file \"%s\" - %s\n", icode, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  if (!openoutput(1, icode)) {  // object
    fprintf(stderr, "i2c: could not create object (icode) file \"%s\" - %s\n", icode, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }

  if (on_event(9)) {
    fprintf(stderr, "i2c: could not create listing file \"%s\" - %s\n", list, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
  if (!openoutput(2, list)) {  // listing
    fprintf(stderr, "i2c: could not create listing file \"%s\" - %s\n", list, strerror(errno));
    exit(__LINE__/*EXIT_FAILURE*/);
  }
 
  if (on_event(9)) {
    fprintf(stderr, "i2c/pass1: unspecified I/O error - possibly a missing %%endoffile ?\n");
    abandon(5);
  }

  selectinput(PERM); // READ PERMS FIRST
  current_input_filename[PERM] = perm;
  
  selectoutput(listing);

  // Initialise entire record to 0:  Note NULL is not necessarily represented by 0.
  // which could be a (miniscule) problem if using this in the Imp to C translator,
  // but in this case, tagfm records contain no pointers so this is extremely safe.

  // btw although assigning 0 to a struct is not supported in this C, assigning
  // one struct to another struct (not pointers but the actual data) *is* supported
  // and indeed is used in this translation.

  // So an alternative to using memset to zero a struct would be to declare a
  // const struct with __zero_## attached to it, and explicitly assign zero to
  // each of the fields in the declaration, then assign that struct when 0 is asked for.

  memset(&tag[maxtag], 0, sizeof(tag[maxtag]));  // %begin defn
  memset(&tag[0], 0, sizeof(tag[0]));

  tag[0].flags = 7;  // %begin tag!
  for (x = 0; x <= maxnames; x += 1) hash[x] = 0;
  printstring("         Edinburgh IMP77 Compiler - Version ");
  // printstring(" Preston IMP2020 Compiler - Version ")
  printstring((char *)version);
  newlines(2);
  op('l', 0);

  compileblock(0, 0, maxdict, 0, 0);
  addchar(nl);     // {for bouncing off}
  flushbuffer(0);  // flush if bp >= 0

  x = listing;
  newline();
  for (;;) {
    if (faulty == 0) {
      write(stats, 5);
      printstring(" Statements compiled");
    } else {
      printstring(" Program contains ");
      write(faulty, 1);
      printstring(" fault");
      if (!(faulty == 1)) printsymbol('s');
    }
    newline();
    if (x == report) break;
    x = report;
    selectoutput(report);
  }
  if (faulty != 0) exit(__LINE__/*EXIT_FAILURE*/);  // try to flag to shell that we failed
  // TODO: any cleaning up needed, eg fclose() or free()
  // might not matter on linux but important on Windows
  selectoutput(1); closeoutput();
  selectoutput(2); closeoutput();
  preturn(0);
}