#include "imptoc.h"
// IMP77 compiler first pass. The comments are mostly from Andy Davis and John McMullin.
// This is 99% automatically translated from Imp77 to C 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.
// It has *not* yet been converted into more idiomatic C - until it is confirmed to be
// working exactly as the original, I'll leave it as this literal transliteration. Once it
// is more robust, there are a lot of constructs which can be improved to make the source
// more readable. (For example unless/while/until statements, not to mention all the Imp I/O)
// ############################################################
// # 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>
#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
int main (int argc, char **argv) { ENTER();
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) )
static const int bytesize = 8; // bits per byte
#define maxtag 800 // max no. of tags
static const int maxdict = 6000; // max extent of dictionary
#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;
static const int litmax = 50; // max no. of constants/stat.
static const int recsize = 520; // size of analysis record
static const int 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;
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
//
//
static const int usedbit = 0b1000000000000000;
static const int closed = 0b0100000000000000;
static const int constbit = 0b0010000000000000;
static const int parameters = 0b0001000000000000;
static const int subname = 0b0000100000000000;
static const int aname = 0b0000010000000000;
static const int ownbit = 0b0000001000000000;
static const int prot = 0b0000000100000000;
static const int spec = 0b0000000010000000;
static const int transbit = 0x4000;
static const int 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 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[64];
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_[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
};
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.
int hash[maxnames+1];
tagfm tag[maxtag+1];
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
static const int 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 ***
auto 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;
}
}
auto void addchar (unsigned char ch) { ENTER();
bp += 1;
buff[bp] = ch;
}
auto void op (int code, int param) { ENTER();
buff[bp + 1] = code;
buff[bp + 2] = param >> 8;
buff[bp + 3] = param;
bp += 3;
}
auto 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;
}
#ifdef INCLUDE_UNUSED // Either never written to, or written to but never read from
auto void octal (int n) { ENTER();
int m;
m = n >> 3;
if (m != 0)
octal (m);
addchar ((n & 7) + '0');
}
auto 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');
}
#endif
auto void printident (int p, int mode) { ENTER();
auto void putit (int ch) { ENTER();
if (mode == 0) {
printsymbol (ch);
} else {
addchar (ch);
}
}
int k, 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) { ENTER();
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,
};
int stream;
stream = listing;
for (;;) {
if (sym != nl) newline ();
printsymbol ('*'); write (lines, 4); space ();
if ((n < 0) || (n > 9)) BADSWITCH(n,__LINE__,__FILE__);
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);
}
if ((diag&4096) != 0) signal_event(15, 15, 0);
exit (0);
}
auto void compileblock (int level, int blocktag, int dmin, int tmax, int id) { ENTER();
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
#ifdef INCLUDE_UNUSED // Either never written to, or written to but never read from
int dbase; dbase = dmax; // dictionary base
#endif
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, newapp;
auto void fault (int n) { ENTER();
// -5 : -1 - warnings
// 0 : 22 - errors
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
};
int st;
auto void printss (void) { ENTER();
int s, 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 < 0)) {
goto *fm_minus[-n];
} else if ((0 <= n) && (n <= 22)) {
goto *fm[n];
}
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;
}
}
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) { ENTER();
static const int comma = 140; // psep
auto void setcell (int g, int tt);
auto void class (tagfm * v);
tagfm *v;
int p, link, tp, c, ap, 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) { 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
return;
}
}
}
// 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;
}
auto void class (tagfm * v) { 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;
}
}
auto void deletenames (int quiet) { 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);
// /* 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) { ENTER();
static const int orderbits = 0x3000, orderbit = 0x1000;
static const int escape = 0x1000;
int strp, mark, flags, proterr, k, s, c;
static int key = 0;
int node;
int *z;
arfm *arp;
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
};
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,
};
auto void traceanalysis (void) { ENTER();
// diagnostic trace routine (diagnose&1 # 0)
int a;
auto void show (int a) { ENTER();
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) { ENTER();
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_ (int LINE) { 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) 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; // 1, 0, -1, -2
}
return;
}
s4:
symtype = quote;
if ((last == 0) && (quote == 0)) goto s1;
cont = '+';
}
#define readsym() readsym_(__LINE__)
auto int formatselected (void) { ENTER();
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) { 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;
auto void lookup (int d) { 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;
// 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) { ENTER();
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)) { // is endianness relevant?
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; // ASSIGN COMPLETE STRUCT. Dioes this work in C? Use memmove??
}
}
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 losing 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) { 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 {
return;
}
}
if (s >= limit) return;
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 ();
}
}
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);
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) { ENTER();
// *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; // underline with %
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];
paction_default:
BADSWITCH((gg >> 8) & 15, __LINE__, __FILE__);
}
if ((class < actions) || (class > phrasal)) BADSWITCH(class, __LINE__, __FILE__);
goto *act[class-actions]; // only actions left
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);
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; // 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); // 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) {
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 (); }
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) { ENTER();
static const int then = 4, else_ = 8, loop = 16;
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,
};
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,
};
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
};
static unsigned char cnest[16];
int lmode, clab, dupid;
int resln;
static int lastdef = 0;
static int lb, ub;
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 class;
int lit2, defs, decs, cident;
int pending;
static int pstack[40+1]; // (1:40) - Rebased to 0 rather than 1 for efficiency
static char name[9] = { '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0' };
static int count = 0;
auto void deflab (int l) { ENTER();
op (':', l);
access = 1;
}
auto void getnext (void) { ENTER();
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 (!(*name == '\0')) spaces (8 - strlen (name));
strncpy(name, text (class), 9);
write (x, 2);
space ();
printstring (name);
space ();
count -= 1;
if (count <= 0) {
count = 5;
name[0] = '\0';
newline ();
}
}
}
auto void setsubs (int n) { 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;
}
}
auto void setbp (void) { 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);
ub = lb;
}
setconst (lb); setconst (ub);
if (!(class == 146)) addchar ('b');
}
auto void compileend (int type) { ENTER();
// 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) { 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 (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) { 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);
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) { 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
}
auto void popdef (void) { ENTER();
setconst (pstack[pending]); pending -= 1;
}
auto void poplit (void) { ENTER();
if (pending == 0) lit = 0; else {
lit = pstack[pending]; pending -= 1;
}
}
// conditions & jumps
auto void push (int x) { 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;
}
auto void poplabel (int mode) { ENTER();
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;
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 ();
if ((class > actions) || (class < 0)) BADSWITCH(class, __LINE__, __FILE__);
goto *c[class];
c_default:
BADSWITCH(class, __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_); // 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 */ // 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 (); 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 */
/*
This decode confirms that %diagnose only saves 16 bits to the icode file,
and that the 16 bits are present. Currently pass2 is picking up 0 for the parameter
7 %diagnose 16_FFFFFFFF
LINE 7
DIAG ffff
*/
if (x == 0) { // control
#ifdef INCLUDE_UNUSED // Either never written to, or written to but never read from
control = lit;
#endif
// %control neither used here not passed on to pass2...
fprintf(stderr, "*NOT* setting %%control flag in icode to %08x\n", (unsigned int)lit);
} else {
if (((lit >> 14) & 3) == 1) diag = lit & 0x3FFF;
fprintf(stderr, "setting %%diagnose flag in icode to %08x\n", (unsigned int)lit);
}
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 */
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
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)
// remove this event block for SKIMP or pre-event IMP versions
{
if (on_event(9)) {
abandon (9);
}
openinput (3, includefile);
}
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 ('\''); // 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); // 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];
if (((x >> 2) < 1) || ((x >> 2) > 12)) BADSWITCH(x >> 2, __LINE__, __FILE__);
goto *litop[x >> 2];
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);
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
if (on_event(9)) {
abandon (5);
}
selectoutput(0);
if (argc != 3) {
fprintf(stderr, "pass1: parameters should be source.imp,stdperm.imp source.icd,source.lis\n");
exit(1);
}
// *Temporary* new code for C/Linux:
{// i77p1 $1,$INCDIR/stdperm.imp $SRCNAME.icd,$LISTFILE
char *source = strdup(argv[1]);
char *perm = strchr(source, ',');
char *icode = strdup(argv[2]);
char *list = strchr(icode, ',');
if (perm == NULL) {
fprintf(stderr, "pass1: first parameter should be source.imp,stdperm.imp\n");
exit(1);
}
*perm++ = '\0';
if (!openinput(1, source)) { // source
fprintf(stderr, "pass1: could not open source file \"%s\"\n", source);
exit(1);
}
if (!openinput(2, perm)) { // prims+perms
fprintf(stderr, "pass1: could not open prims+perms file \"%s\"\n", perm);
exit(1);
}
if (list == NULL) {
fprintf(stderr, "pass1: second parameter should be source.icd,source.lis\n");
exit(1);
}
*list++ = '\0';
//openoutput(0, "/dev/stderr"); // console report - shouldn't in and out 0 already be stdin/stdout?
if (!openoutput(1, icode)) { // object
fprintf(stderr, "pass1: could not open object (icode) file \"%s\"\n", icode);
exit(1);
}
if (!openoutput(2, list)) { // listing
fprintf(stderr, "pass1: could not open listing file \"%s\"\n", list);
exit(1);
}
}
selectinput (2);
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 (0); // try to flag to shell that we failed
}