//============================================================================
// IMP77 compiler first pass
// ###########################################################
// 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 #
// ###########################################################
int main (int argc, char **argv)
{
static char *version = "8.4";
// configuration parameters
static int minusone = (-(1));
// Wee change needed to cross-compile the compiler when going from 16 bit to 32 bit world
// %owninteger minus one = 16_7fff;
static int maxint = ((int) (((minusone) >> 1)) / (int) (10));
static int maxdig = (minusone) >> 1 - maxint * 10;
static int bytesize = 8;
// bits per byte
static int maxtag = 800;
// max no. of tags
static int maxdict = 6000;
// max extent of dictionary
static int namebits = 11;
// size of name table as a power of two
static int maxnames = 1 << namebits - 1;
// table limit (a mask, eg 255)
static int sparenames = maxnames;
static int litmax = 50;
// max no. of constants/stat.
static int recsize = 520;
// size of analysis record
static int dimlimit = 6;
// maximum array dimension
// symbols
static int ff = 12;
// form feed
static int marker = '^';
// marker for faults
static int squote = '"';
// string quote
static int cquote = '\\';
// character quote
// streams
static int report = 0, source = 1;
static int object = 1, listing = 2;
// types
static int integer = 1;
static int real = 2;
static int stringv = 3;
static int record = 4;
// forms
static int iform = integer << 4 + 1;
static int var = 91;
static int _const_ = 93;
static int swit = 105;
static int comment = 22;
static int termin = 20;
static int lab = 3;
static int jump = 54;
static int recfm = 4;
static int proc = 7;
// class for proc
// phrase entries
static int escdec = 252;
static int escproc = 253;
static int escarray = 254;
static 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
//
//
static int usedbit = 0b1000000000000000;
static int closed = 0b0100000000000000;
static int constbit = 0b0010000000000000;
static int parameters = 0b0001000000000000;
static int subname = 0b0000100000000000;
static int aname = 0b0000010000000000;
static int ownbit = 0b0000001000000000;
static int prot = 0b0000000100000000;
static int spec = 0b0000000010000000;
static int transbit = 0x4000;
static int error = 0x8000;
arfm ar[recsize - 1 + 1];
static int class = 0;
// class of atom wanted
static int x = 0;
// usually last tag
static int atom1 = 0;
// atom class (major)
static int atom2 = 0;
// atom class (minor)
static int subatom = 0;
// extra info about atom
static int type = 0;
static int app = 0;
static int format = 0;
// atom info
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[63 + 1];
static int includelist = 0;
static int includelevel = 0;
static int include = 0;
// =0 unused, #0being used
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
int recid;
static unsigned char _char_[133 - 0 + 1];
int litpool[litmax - 0 + 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 control = 0;
static int diag = 0;
// diagnose flags
int hash[maxnames - 0 + 1];
tagfm tag[maxtag - 0 + 1];
int dict[maxdict - 1 + 1];
unsigned char buff[512 - 1 + 1];
static int bp = 0;
static int maxgrammar = 1720;
static int gmin = maxgrammar;
// upper bound on grammar
static int manifest = 120, figurative = 130;
static int actions = 180, phrasal = 200;
static unsigned char amap[15 - 0 + 1];
// ? v n l fm const swit rp fp mp pp a an na nan ?
static unsigned char atoms[15 - 0 + 1];
// *** start of generated tables ***
// *** end of generated tables ***
auto void flushbuffer (int limit)
{
int j;
if (bp >= limit) {
if (faulty == 0) {
selectoutput (object);
for (j = 1; j <= bp; j += 1) {
printsymbol (buff[j]);
}
selectoutput (listing);
}
bp = 0;
}
}
auto void addchar (unsigned char ch)
{
bp += 1;
buff[bp] = ch;
}
auto void op (int code, int param)
{
buff[bp + 1] = code;
buff[bp + 2] = param >> 8;
buff[bp + 3] = param;
bp += 3;
}
auto void setconst (int m)
{
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;
}
auto void octal (int n)
{
int m;
m = n >> 3;
if (m != 0)
octal (m);
addchar (n & 7 + '0');
}
auto void hexadecimal (int n)
{
int m;
m = n >> 4;
if (m != 0)
hexadecimal (m);
if (n & 15 > 9)
addchar (n & 15 + 'A');
else
addchar (n & 15 + '0');
}
auto void printident (int p, int mode)
{
auto void putit (int ch)
{
if (mode == 0) {
printsymbol (ch);
} else {
addchar (ch);
}
}
int k;
int l;
p = &tag[p]->text;
if (p == 0) {
putit ('?');
return;
}
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;
}
}
auto void abandon (int n)
{
static void *reason[ /* bounds */ ] = { &&reason_default };
int stream;
stream = listing;
for (;;) {
if (sym != nl)
newline ();
printsymbol ('*');
write (lines, 4);
space ();
goto *reason[n];
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 ();
if (stream == report)
break;
closeoutput ();
stream = report;
selectoutput (report);
}
// %signal 15,15 %if diag&4096 # 0
exit (0);
}
auto void compileblock (int level, int blocktag, int dmin, int tmax, int id)
{
auto int gapp (void);
auto void deletenames (int quiet);
auto void analyse (void);
auto void compile (void);
int open;
open = closed;
// zero if can return from proc
int dbase;
dbase = dmax;
// dictionary base
int tbase;
tbase = tmax;
// tag base
int tstart;
tstart = tmax;
int _label_;
_label_ = 4;
// first internal label
int access;
access = 1;
// non-zero if accessible
int inhibit;
inhibit = 0;
// non-zero inhibits declaratons
int *bflags;
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;
int newapp;
auto void fault (int n)
{
// -5 : -1 - warnings
// 1 : 22 - errors
static void *fm[ /* bounds */ ] = { &&fm_default };
int st;
auto void printss (void)
{
int s;
int p;
if (pos == 0)
return;
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;
}
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 ();
}
if (((-(5)) <= n && n <= 22))
goto *fm[n];
printstring ("fault");
write (n, 2);
goto ps;
fm_ (-(5)): /* (-(5)) */
printstring ("Dubious statement");
dubious = 0;
goto psd;
fm_ (-(4)): /* (-(4)) */
printstring ("Non-local");
pos1 = forwarn;
forwarn = 0;
goto ps;
fm_ (-(3)): /* (-(3)) */
printident (x, 0);
printstring (" unused");
goto nps;
fm_ (-(2)): /* (-(2)) */
printstring ("\"}\"");
goto miss;
fm_ (-(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) {
// %signal 15,15 %if diag&4096 # 0
if (n != 13) {
// order is fairly safe
ocount = (-(1));
gg = 0;
copy = 0;
quote = 0;
searchbase = 0;
escapeclass = 0;
gg = 0;
}
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;
}
}
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 ();
if (ss != 0)
compile ();
if (blockotype != 0) {
// external-ish
if (bflags & spec == 0) {
// definition
if ((progmode <= 0 && level == 1))
progmode = (-(1));
else
fault (7);
}
}
newapp = gapp ();
// generate app grammar
if (specgiven != 0) {
// definition after spec
if (newapp != blockapp)
fault (6);
// different from spec
}
blockapp = newapp;
// use the latest
if (level < 0) {
// not procedure definition
deletenames (0);
return;
}
} else {
open = 0;
// can return from a block?
}
for (;;) {
analyse ();
if (ss != 0) {
compile ();
if (dubious != 0)
fault ((-(5)));
flushbuffer (128);
// flush if bp >= 128
if (sstype > 0) {
// block in or out
if (sstype == 2)
break; // out
compileblock (specmode, blockx, dmin, tmax, id);
if (ss < 0)
break; // endofprogram
}
}
}
if ((list > 0 && level > 0)) {
write (lines, 5);
spaces (level * 3 - 1);
printstring ("End");
newline ();
}
deletenames (0);
return; // generate app grammar (backwards)
auto int gapp (void)
{
static int comma = 140;
// psep
auto void setcell (int g, int tt);
auto void class (tagfm * v);
tagfm *v;
int p;
int link;
int tp;
int c;
int ap;
int t;
if (tmax == local)
return (0); // no app needed
p = gmax1;
link = 0;
t = tmax;
for (;;) {
v = &tag[t] /* Pointer assignment */ ;
t -= 1;
class (v);
// deduce class from tag
if (c < 0) {
// insert %PARAM
c = (-(c));
setcell (196, tp);
tp = (-(1));
}
setcell (c, tp);
if (t == local)
break; // end of parameters
setcell (comma, (-(1)));
// add the separating comma
}
if (gmax > gmin)
abandon (3);
return (link);
auto void setcell (int g, int tt)
{
// 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
return;
}
}
}
// add a new cell
gmax += 1;
gram (gmax) = g;
glink (gmax) = link;
link = gmax;
if (tt >= 0) {
// set type cell
gmax += 1;
gram (gmax) = tt;
glink (gmax) = ap;
}
p = gmax;
}
auto void class (tagfm * v)
{
static int err = 89;
static int rtp = 100;
static int fnp = 101;
static int mapp = 102;
static int predp = 103;
static int classmap[15 - 0 + 1];
int tags;
int type;
int 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;
}
}
auto void deletenames (int quiet)
{
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);
// {spec with no definition & not external}
if ((flags & usedbit == 0 && (level >= 0 && list <= 0))) {
if (quiet == 0)
fault ((-(3)));
// unused
}
dict[tx->text] = tx->link;
}
}
auto void analyse (void)
{
static int orderbits = 0x3000, orderbit = 0x1000;
static int escape = 0x1000;
int strp;
int mark;
int flags;
int proterr;
int k;
int s;
int c;
static int key = 0;
int node;
int *z;
arfm *arp;
static void *act[ /* bounds */ ] = { &&act_default };
auto void traceanalysis (void)
{
// diagnostic trace routine (diagnose&1 # 0)
int a;
auto void show (int a)
{
if ((0 < a && a < 130)) {
space ();
printstring (text (a));
} else
write (a, 3);
}
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 ();
}
auto void getsym (void)
{
readsymbol (sym);
if (sym < 0)
abandon (5);
if (pos != 133)
pos += 1;
_char_[pos] = sym;
if (list <= 0)
printsymbol (sym);
column += 1;
}
auto void readsym (void)
{
static int last = 0;
static unsigned char mapped[127 - 0 + 1];
// ! 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)
return; // 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;
}
return;
}
s4:
symtype = quote;
if ((last == 0 && quote == 0))
goto s1;
cont = '+';
}
auto int formatselected (void)
{
formatlist = &tag[format]->app;
// number of names
if (formatlist < 0) {
// forward ref
atom1 = error + 22;
return (0);
}
if (sym == '_') {
escapeclass = escrec;
searchbase = &tag[format]->format;
}
return (1);
}
auto void codeatom (int target)
{
int dbase;
int da;
int base;
int n;
int mul;
int pendquote;
int j;
int k;
int l;
int pt;
auto void lookup (int d)
{
int newname;
int vid;
int k1;
int k2;
int form;
tagfm *t;
int new;
// twee little function because SKIMP86 can't do string compare properly
// returns 1 if the two names are the same, else zero
auto int dictmatch (int ptr1, int ptr2)
{
int len;
// start with a cheap check of the length and first character
if (dict[ptr1] != dict[ptr2])
return (0);
len = dict[ptr1] & 255;
ptr1 += 1;
ptr2 += 1;
len -= 1;
while (len >= 2) {
if (dict[ptr1] != dict[ptr2])
return (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)
return (0);
}
return (1);
}
// 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)
return;
}
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;
return;
}
// deal with constintegers etc
if ((atomflags & constbit != 0 && atom1 == var)) {
mapgg = _const_;
atom2 = _const_;
if (type == integer)
subatom = (-(subatom));
}
return;
}
// new name wanted
if (tbase != tstart)
goto notin;
// don't fault proc parm-parm
if (d == lab + spec + usedbit) {
t->flags = t->flags | usedbit;
return;
}
if (atomflags & spec != 0) {
// a spec has been given
if (d == lab) {
// define label
t->flags = t->flags - spec;
return;
}
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;
return;
}
// 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;
return;
}
}
if ((last1 == jump && atom1 == swit))
return;
if (copy == 0)
copy = x;
notin:
app = 0;
vid = 0;
atom1 = error + 2;
if (d == 0)
return; // 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;
}
}
if (tmax >= tmin)
abandon (3);
}
top:
pos1 = pos;
subatom = 0;
pendquote = 0;
atomflags = 0;
// app and format must be left for assigning to papp & pformat
if (symtype == (-(2)))
goto name;
// letter
if (symtype < 0)
goto number;
// digit
if (symtype == 0) {
atom1 = termin;
atom2 = 0;
return;
}
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 ();
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 ();
if (j > 0) {
if (l != 0) {
if ((l != sym || symtype < 0))
goto err;
readsym ();
}
l = 1;
}
k += l;
}
}
atom1 = j & 127;
if (atom1 == 0) {
// comma
atom1 = 19;
subatom = 19;
atom2 = 0;
if (sym == nl) {
if (ocount >= 0)
return; // special action needs to be taken with <comma nl> as
// const array lists can be enormous
readsym ();
}
return;
}
atom2 = j >> 7 & 127;
subatom = kdict (k + 1) & 0x3FFF;
// !!!!cont = ' '
return; // 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;
return; // take care with strings and symbol constants.
// make sure the constant is valid here before sucking it in
// (and potentially loosing many lines)
symbols:
atom1 = var;
atom2 = _const_;
type = integer;
mapgg = _const_;
protection = prot;
subatom = lp;
if (lp >= litmax)
abandon (3);
quote = (~(pendquote));
return; // an integer constant is acceptable so get it in and
// get the next atom
chars:
n = 0;
cont = cquote;
for (;;) {
readsym ();
if (sym == cquote) {
if (nextsymbol != cquote)
break;
readsym ();
}
if (n & ((~((((-(1))) >> bytesize)))) != 0) {
// overflow
pos1 = pos;
atom1 = error + 10;
return;
}
if (quote == 0)
goto err;
n = n << bytesize + sym;
quote += 1;
}
quote = 0;
cont = ' ';
if (sym != nl)
readsym ();
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
return; // 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 ();
if (sym == squote) {
// terminator?
if (nextsymbol != squote)
break; // yes ->
readsym ();
// 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 ();
codeatom (target);
if (!((atom1 == 48 && sym == squote)))
return; // fold "???"."+++"
}
auto void get (int limit)
{
int s;
int 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 {
return;
}
}
if (s >= limit)
return;
pt += 1;
glink (pt) = sym;
if (base == 10) {
// check overflow
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 ();
}
}
number:
base = 10;
bxk:
atom1 = var;
atom2 = _const_;
type = integer;
subatom = lp;
mapgg = _const_;
protection = prot;
if (lp >= litmax)
abandon (3);
pt = strp;
mul = 0;
for (;;) {
get (base);
if (!((sym == '_' && (base != 0 && pendquote == 0))))
break; // change of base
pt += 1;
glink (pt) = '_';
readsym ();
base = n;
}
if (pendquote != 0) {
if (sym != cquote)
goto err;
readsym ();
}
if (sym == '.') {
// a real constant
pt += 1;
glink (pt) = '.';
readsym ();
type = real;
n = base;
base = 0;
get (n);
}
if (sym == '@') {
// an exponent
pt += 1;
glink (pt) = '@';
k = pt;
readsym ();
type = integer;
base = 10;
if (sym == '-') {
readsym ();
get (10);
n = (-(n));
} else {
get (10);
}
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;
}
return;
name:
if ((27 <= target && target <= 41)) {
atom1 = 0;
return;
}
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 ();
if (symtype >= 0)
break;
dict[dp] = sym;
n += 1;
readsym ();
if (symtype >= 0)
break;
}
if (sym == cquote) {
pendquote = 100;
if (hashvalue == 'M')
goto symbols;
readsym ();
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);
return;
}
if (last1 == jump) {
// ->label
limit = local;
lookup (lab + spec + usedbit);
return;
}
if ((decl != 0 && target == 90)) {
// identifier
searchbase = fmbase;
limit = local;
lookup (decl);
searchbase = 0;
} else {
limit = 0;
lookup (0);
}
}
auto int parsedmachinecode (void)
{
// *opcode_??????????
if (!(symtype == (-(2)))) {
atom1 = error;
return (0);
} // starts with letter
flushbuffer (128);
// flush if bp >= 128
addchar ('w');
for (;;) {
addchar (sym);
readsym ();
if ((sym == '_' || symtype == 0))
break;
}
// pull in letters and digits
addchar ('_');
if (symtype != 0) {
// not terminator
readsym ();
while (symtype != 0) {
if (symtype < 0) {
// complex
codeatom (0);
if (atom1 & error != 0)
return (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;
return (0);
}
op (' ', &tag[subatom]->index);
} else {
atom1 = error;
return (0);
}
} else {
if (symtype == 2)
sym = sym | 128;
addchar (sym);
readsym ();
}
}
}
addchar (';');
return (1);
}
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 ();
cont = c;
}
if (sym == '!')
goto skip;
// comment
this = (-(1));
codeatom (0);
if (atom1 == comment) {
skip:
quote = 1;
c = cont;
while (sym != nl) {
readsym ();
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)
op ('O', lines);
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);
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);
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;
goto *paction[gg >> 8 & 15];
}
goto *act[class];
// only actions left
a5:
// REVERSELINKS
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);
if (order == 0)
fault (13);
if (forwarn != 0)
fault ((-(4)));
pos1 = 0;
faultrate -= 1;
return;
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;
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);
// expend
compile ();
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);
if (atomflags & aname == 0)
protection = k;
goto more;
act_192: /* 192 */
if (parsedmachinecode () == 0)
goto fail1;
goto more;
act_189: /* 189 */
k = gapp ();
// %GAPP
deletenames (1);
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) {
printstring ("Atom1 =");
write (atom1, 3);
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 ();
// %signal 13,15
}
while ((sym != nl && sym != ';')) {
quote = 0;
readsym ();
}
if (k & error != 0) {
fault (k & 255);
} else {
if (proterr == nmin)
fault (14);
else
fault (0);
}
gg = 0;
ss = 0;
symtype = 0;
}
// of analyse
auto void compile (void)
{
static int then = 4, else_ = 8, loop = 16;
static void *c[ /* bounds */ ] = { &&c_default };
static unsigned char operator[14 - 1 + 1];
static unsigned char cc[7 - 0 + 1];
static unsigned char anyform[15 - 0 + 1];
static int decmap[15 - 0 + 1];
static unsigned char cnest[15 - 0 + 1];
int lmode;
int clab;
int dupid;
int resln;
static int lastdef = 0;
static int lb, ub;
int cp;
int ord;
int next;
int link;
int j;
int k;
int n;
int done;
int class;
int lit2;
int defs;
int decs;
int cident;
int pending;
static int pstack[40 - 1 + 1];
static char *name = "";
static int count = 0;
auto void deflab (int l)
{
op (':', l);
access = 1;
}
auto void getnext (void)
{
arfm *p;
gn:
if (next == 0) {
// end of phrase
if (link == 0) {
class = 0;
return;
} // end of statement
p = &ar[link] /* Pointer assignment */ ;
next = p->link;
link = p->sub;
}
for (;;) {
p = &ar[next] /* Pointer assignment */ ;
x = p->sub;
class = p->class;
if (class < 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 (!(strlen (name) == 0))
spaces (8 - strlen (name));
name = text (class);
write (x, 2);
space ();
printstring (name);
space ();
count -= 1;
if (count <= 0) {
count = 5;
strcpy (name, "");
newline ();
}
}
}
auto void setsubs (int n)
{
// update the app field in n array descriptors
int p;
p = tmax;
while (n > 0) {
// %signal 15,15 %if p < tbase
&tag[p]->app = dimension;
p -= 1;
n -= 1;
}
}
auto void setbp (void)
{
// 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);
ub = lb;
}
setconst (lb);
setconst (ub);
if (!(class == 146))
addchar ('b');
}
auto void compileend (int type)
{
// type = 0:eof, 1:eop, 2:end
if (access != 0) {
open = 0;
if (blockform > proc)
fault (19);
// can reach end
}
while (dict[dmin] >= 0) {
// finishes & repeats
fault (17 + dict[dmin] & 1);
dmin += 1;
}
// {delete names(0)}
addchar (';');
if (type == 1)
addchar (';');
// endofprogram
bflags = bflags | open;
// show if it returns
if ((blocktag != 0 && level != 1))
deflab (0);
// for jump around
if (type != 2) {
// eop, eof
if (level != type)
fault (16);
// end missing
} else {
if (level == 0) {
fault (15);
// spurious end
}
}
endmark = 11;
// ******Mouses specific******
}
auto void def (int p)
{
// dump a descriptor
int t;
int f;
int 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 (class == 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
}
}
auto void defslab (int n)
{
// define a switch label, x defines the switch tag
int p;
int l;
int b;
int w;
int 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);
return;
}
if (pending != 0)
dict[w + 2] = dict[w + 2] | bit;
setconst (n);
op ('_', &tag[x]->index);
} else {
fault (12);
}
access = 1;
}
auto void call (void)
{
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
}
auto void popdef (void)
{
setconst (pstack[pending]);
pending -= 1;
}
auto void poplit (void)
{
if (pending == 0)
lit = 0;
else {
lit = pstack[pending];
pending -= 1;
}
}
// conditions & jumps
auto void push (int x)
{
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;
}
auto void poplabel (int mode)
{
lmode = dict[dmin];
if ((lmode < 0 || lmode & 1 != mode)) {
fault (mode + 8);
} else {
dmin += 1;
_label_ -= 3;
}
}
if (sstype < 0) {
// executable statement
if (level == 0) {
// outermost level
fault (13);
// *order
} else {
if (access == 0) {
access = 1;
fault ((-(1)));
// only a warning
}
}
}
if (diag & 2 != 0) {
if (sym != nl)
newline ();
printstring ("ss =");
write (ss, 1);
newline ();
count = 5;
strcpy (name, "");
}
next = ss;
pending = 0;
lmode = 0;
link = 0;
decs = 0;
defs = 0;
resln = 0;
done = 0;
ord = level;
if (this >= 0)
ord = 1;
// recordformat declarations
c_0: /* 0 */
top:
if (next != link) {
getnext ();
goto *c[class];
}
// 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_);
// entry from then
if (lmode & else_ != 0)
deflab (_label_ - 1);
// entry from else
}
if (decs == 0)
return;
if (atom1 != 0) {
atom1 = error;
return;
} // %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
}
return;
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 ();
if (!((0 < lit && lit <= dimlimit))) {
atom1 = error + 11;
return;
}
}
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 ();
if (!((0 < lit && lit <= 255))) {
// max length wrong
atom1 = error + 10;
return;
}
}
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
return;
c_175: /* 175 */
id += 1;
&tag[x]->index = id;
return; // 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);
goto top;
c_148: /* 148 */
if (next == 0) {
fdef = 0;
goto top;
} // reclb
getnext ();
// skip name
fdef = x;
goto top;
c_127: /* 127 */
addchar ('}');
goto top;
// %POUT
c_126: /* 126 */
addchar ('{');
goto top;
// %PIN
c_174: /* 174 */
setbp ();
// rangerb
c_171: /* 171 */
// FMLB
c_172: /* 172 */
// FMRB
c_173: /* 173 */
addchar ('~');
addchar (class - 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);
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 (class == 138)
op ('f', _label_ - 1);
else
deflab (_label_ - 1);
// 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);
// repeat
if (lmode & 32 != 0)
deflab (_label_ + 1);
goto atop;
c_69: /* 69 */
poplabel (1);
goto top;
// finish
c_163: /* 163 */
// XELSE
c_70: /* 70 */
poplabel (1);
// finish else ...
if (lmode & 3 == 3)
fault (7);
// dangling else
c_68: /* 68 */
lmode = (lmode & else_) | 3;
// ...else...
if (access != 0) {
op ('F', _label_ - 1);
lmode = else_ | 3;
}
deflab (_label_);
if (next != 0)
goto top;
c_120: /* 120 */
// mstart
c_67: /* 67 */
// START
c_71: /* 71 */
// CYCLE
stcy:
if (lmode == 0) {
deflab (_label_ - 1);
lmode = loop;
} // cycle
dmin -= 1;
if (dmin <= dmax)
abandon (3);
dict[dmin] = lmode;
_label_ += 3;
return;
c_64: /* 64 */
if ((dict[dmin] >= 0 || inhibit != 0))
fault (13);
// on event
inhibit = 1;
n = 0;
if (pending == 0)
n = 0xFFFF;
// * = all events
while (pending > 0) {
poplit ();
if (lit & ((~(15))) != 0)
fault (10);
// 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);
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);
// 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);
cp -= 1;
clab = clab - cnest[cp] & 1;
goto top;
c_78: /* 78 */
// FRESULT
c_79: /* 79 */
// MRESULT
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 ();
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);
// {Permit BEGIN after external defs}
}
specmode = level + 1;
blockx = 0;
addchar ('H');
return;
c_77: /* 77 */
perm = 0;
lines = 0;
stats = 0;
// endofperm
closeinput ();
selectinput (source);
list -= 1;
tbase = tmax;
tstart = tmax;
return;
c_76: /* 76 */
if ((include != 0 && x == 0)) {
// end of ...
lines = include;
sstype = 0;
// include
closeinput ();
list = includelist;
includelevel = 0;
include = 0;
selectinput (source);
return;
}
ss = (-(1));
// prog/file
c_75: /* 75 */
compileend (x);
return; // %end
c_85: /* 85 */
if (x == 0)
control = lit;
else { // control
if (lit >> 14 & 3 == 1)
diag = lit & 0x3FFF;
}
op ('z' - x, lit);
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 */
if (include != 0) {
// include "file"
fault (7);
return;
}
getnext ();
// sconst
x -= 0x4000;
j = glink (x);
k = j & 255;
// ABD - another little copy loop because SKIMP can't do the string map
strcpy (includefile, "");
for (;;) {
k -= 1;
if (k < 0)
break;
strcat (includefile, tostring (j >> 8));
x += 1;
j = glink (x);
k -= 1;
if (k < 0)
break;
strcat (includefile, tostring (j & 255));
}
// include file = string(x-16_4000+stbase)
// remove this event block for SKIMP or pre-event IMP versions
auto inline void block_1 (void)
{
auto inline void signal_event (int event, int subevent, int extra)
{
abandon (9);
}
openinput (3, includefile);
}
block_1 ();
include = lines;
lines = 0;
includelist = list;
includelevel = level;
selectinput (3);
goto top;
c_154: /* 154 */
dimension += 1;
// dbsep
if (dimension == dimlimit + 1)
fault (11);
goto top;
c_145: /* 145 */
setbp ();
goto top;
// crb
c_146: /* 146 */
setbp ();
// rcrb
c_142: /* 142 */
// BPLRB
if (dimension == 0)
dimension = 1;
op ('d', dimension);
op (',', defs);
if (class != 146) {
setsubs (defs);
if ((dict[dmin] >= 0 || (inhibit != 0 || level == 0)))
fault (13);
}
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
c_125: /* 125 */
dupid = id;
// %DUP
if (level < 0)
return; // {spec about}
c_90: /* 90 */
def (x);
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);
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 ();
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 ('\\');
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);
// oident
dimension = 1;
setsubs (1);
if (next == 0) {
// no initialisation
if (ocount > 0)
op ('A', ocount);
ocount = (-(1));
} else {
// initialisation given
getnext ();
}
goto top;
c_162: /* 162 */
lit = ocount;
goto ins;
// indef
c_143: /* 143 */
poplit ();
// orb
ins:
if (lit < 0) {
fault (10);
lit = 0;
}
getnext ();
goto inst;
c_139: /* 139 */
// OSEP(X=19)
c_153: /* 153 */
lit = 1;
inst:
if (pending != 0)
popdef ();
// ownt (x=0)
op ('A', lit);
ocount -= lit;
if (ocount >= 0) {
if (x != 0)
goto top;
// more coming
if (ocount == 0) {
ocount = (-(1));
return;
} // all done
}
fault (11);
return;
c_swit: /* swit */
op ('W', &tag[x]->index);
inhibit = 1;
goto atop;
c_134: /* 134 */
def (x);
// 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);
return;
}
if (pending != 0) {
// explicit label
defslab (pstack[1]);
} else {
if (&tag[x]->app != 0) {
fault (4);
return;
}
&tag[x]->app = 1;
n = &tag[x]->format;
for (j = dict[n]; j <= dict[n + 1]; j += 1) {
defslab (j);
flushbuffer (128);
// flush if bp >= 128
}
}
inhibit = 1;
return;
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];
goto *litop[x >> 2];
litop_1: /* 1 */
lit = lit << lit2;
goto setl;
litop_2: /* 2 */
lit = lit >> lit2;
goto setl;
litop_3: /* 3 */
n = 1;
// lit = lit\\lit2
if (lit2 < 0)
fault (10);
while (lit2 > 0) {
lit2 -= 1;
n = n * lit;
}
lit = n;
goto setl;
litop_4: /* 4 */
if (lit2 == 0)
fault (10);
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);
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;
}
}
// of compile block
auto inline void signal_event (int event, int subevent, int extra)
{
abandon (5);
}
selectinput (2);
selectoutput (listing);
&tag[maxtag] = 0;
// %begin defn
&tag[0] = 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 (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 (0); // try to flag to shell that we failed
}