//============================================================================
// Intel 80386 IMP77 compiler second pass
// Copyright 2002 NB Information Limited. From an original
// version probably Copyright The University of Edinburgh and
// various contributions Copyright many other individuals, but
// most particularly Copyright 1977-1980 Peter Robertson
// Version 2.00 - February 2021
// * Enabled machine code to be embedded (NO floating point implemented)
//
// Version 1.03 - October 2003
// * Properly cleaned up GP TAG list at end of a block
// * Tidied up some constant tables with names (a hangover from the SKIMP version)
// * Corrected ISWORK to only be true for full-size string work blocks
int main (int argc, char **argv)
{
// SIZE CONSTANTS
const int maxvars = 1024;
const int maxstack = 16;
const int maxlabs = 50;
const int maxlevel = 16;
const int maxgp = 120;
// SOME WEE ENVIRONMENTAL THINGS
const char *programip = "Main Program";
// Main program internal name
const char *programep = "__impmain";
// Main program external name
const char *systemprefix = "_imp_";
// prefixed to %system routine idents
// I/O file handles
const int icode = 1;
const int source = 2;
const int report = 0;
const int objout = 1;
const int listout = 2;
// DIAGNOSE BITS
const int passid = 2;
// JDM Identify which IMP pass this is
const int mcodeleveld = (1 << 13);
// JDM peak level D debug diagnostics of Machine Code
const int mcodelevelc = (1 << 12);
// JDM next level C debug diagnostics of Machine Code
const int mcodelevelb = (1 << 11);
// JDM next level B debug diagnostics of Machine Code
const int mcodelevela = (1 << 10);
// JDM base level A debug diagnostics of Machine Code
// CONTROL BITS
const int checkcapacity = 1;
const int checkunass = 2;
const int checkarray = 4;
const int checkbits = checkarray;
// The only one that does anything so far
// REGISTERS - basic register number = actual value + 1
const int ax = 1;
const int cx = 2;
const int dx = 3;
const int bx = 4;
const int sp = 5;
const int bp = 6;
const int si = 7;
const int di = 8;
// Floating point coprocessor stack registers
const int fr0 = 9;
// %constinteger FR1 = 10
// %constinteger FR2 = 11
// %constinteger FR3 = 12
// %constinteger FR4 = 13
// %constinteger FR5 = 14
// %constinteger FR6 = 15
const int fr7 = 16;
// 8 bit registers - actual value + 17
const int al = 17;
const int cl = 18;
const int dl = 19;
const int bl = 20;
const int ah = 21;
const int ch = 22;
const int dh = 23;
const int bh = 24;
// Pseudo Registers
const int any = 25;
// Truly any register
const int anyg = 26;
// A "General Purpose" byte accessible register (AX, BX, CX, DX)
const int anyp = 27;
// A pointing register (BX, SI, DI)
const int anyf = 28;
// Generally means the top of the 8087 stack
// DATA FORMS
// EXTERNAL FORM
const int simple = 1;
const int name = 2;
const int _label_ = 3;
const int recordformat = 4;
const int switch = 6;
const int array = 11;
const int arrayname = 12;
const int namearray = 13;
const int namearrayname = 14;
// INTERNAL
const int constant = 0;
const int vinr = 1;
const int avinr = 2;
const int ainr = 3;
const int vins = 4;
const int avins = 5;
const int ains = 6;
const int vinrec = 7;
const int avinrec = 8;
const int ainrec = 9;
const int pgmlabel = 10;
// DATA TYPES
const int general = 0;
const int integer = 1;
const int real = 2;
const int string = 3;
const int record = 4;
// Private internal derived types
const int byte = 5;
const int lreal = 6;
// SIZE OF EACH OF THOSE TYPES IN BYTES
const unsigned char vsize[lreal - general + 1];
// Define type codes known externally (to pass 3 and user):
const unsigned char genmap[lreal - general + 1];
// GENERIC STORE ALIGNMENT - ASSUME 80386
const int align = 3;
const int wordsize = 4;
// in bytes
// OWN INFO
const int own = 1;
const int con = 2;
const int external = 3;
const int system = 4;
const int dynamic = 5;
const int primrt = 6;
const int permrt = 7;
const int map = (-(2)), fn = (-(1)), routine = 0, true = 1, false = 2;
// PERM ROUTINE INDEXES
const int iexp = 1;
// Integer Exponent
const int fexp = 2;
// floating exponent
const int smove = 3;
// string copy (length checked)
const int sjam = 4;
// string copy (whatever fits)
const int sconc = 5;
// string concatenate (length checked)
const int sjconc = 6;
// concatenate whatever fits
const int sresln = 7;
// string resolution
const int scomp = 8;
// string compare
const int aref = 9;
// array access
const int adef = 10;
// array definition
const int signal = 11;
// %signal
const int stop = 12;
// %stop
const int lastperm = stop;
// and the corresponding linkage names for the perms
const char *permname[lastperm - 1 + 1];
// Compiler Internal Operations (not to be confused with OpCodes)
const int addx = 1;
const int subx = 2;
const int mulx = 3;
const int divx = 4;
const int concx = 5;
const int andx = 6;
const int orx = 7;
const int xorx = 8;
const int lshx = 9;
const int rshx = 10;
const int remx = 11;
const int expx = 12;
const int rexpx = 13;
const int rdivx = 14;
const int notx = 15;
const int negx = 16;
const int absx = 17;
const int unaries = 15;
// opcode indexes...
// simple (no operand) ones first
const int nop = 0;
const int cwd = 1;
const int ret = 2;
const int sahf = 3;
const int leave = 4;
// simple unary math functions
const int dec = 5;
const int inc = 6;
const int neg = 7;
const int not = 8;
// simple unary moves
const int pop = 9;
const int push = 10;
// two operand moves
const int lea = 11;
const int mov = 12;
const int xchg = 13;
// simple two operand math functions
const int adc = 14;
const int add = 15;
const int and = 16;
const int cmp = 17;
const int or = 18;
const int sub = 19;
const int xor = 20;
// slightly more complicated two operand math
const int shl = 21;
const int shr = 22;
const int idiv = 23;
const int imul = 24;
// calls and jumps
const int call = 25;
const int je = 26;
const int jne = 27;
const int jg = 28;
const int jge = 29;
const int jl = 30;
const int jle = 31;
const int ja = 32;
const int jae = 33;
const int jb = 34;
const int jbe = 35;
const int jmp = 36;
// Floating point instructions - note that these map directly onto
// 8087 sequences, unlike the generic MOV, ADD style of the base
// operations for the 8086
const int fild = 37;
const int fldd = 38;
const int fldq = 39;
const int fsti = 40;
const int fstd = 41;
const int fstq = 42;
const int fadd = 43;
const int fsub = 44;
const int fsubr = 45;
const int fmul = 46;
const int fdiv = 47;
const int fdivr = 48;
const int fcmp = 49;
const int fchs = 50;
const int fabs = 51;
// Special floating point things
const int fstsw = 52;
const int fldz = 53;
const int fldpi = 54;
// modifiers to memory base for accessing global memory
const int data = 0x10;
const int cot = 0x20;
const int bss = 0x30;
const int display = 0x40;
const int ext = 0x50;
const int swt = 0x60;
const int code = 0x70;
const int eq = 1, lt = 2, gt = 4, tt = 8, always = 7, ne = 6, le = 3, ge = 5, ff = 9, never = 0;
const unsigned char reverse[ff - never + 1];
const unsigned char negated[ff - never + 1];
const unsigned char testtoop[ff - never + 1];
const unsigned char testtounsignedop[ff - never + 1];
// Standard IMPish data structures
// Variables are declared here
// JDM JDM added idname to remember the IMP variable names
typedef struct varfm
{
char *idname;
unsigned char type, form, level, scope, dim;
int disp, format, size, pbase, extra, extdisp;
} varfm;
varfm var[maxvars - 0 + 1];
varfm *decvar;
varfm begin;
// The compiler is stack based
// JDM JDM added idname to remember the IMP variable name
typedef struct stackfm
{
char *idname;
unsigned char type, form, aform, base, scope, dim;
int disp, format, size, pbase, extra, extdisp, varno;
} stackfm;
stackfm stack[maxstack - 1 + 1];
stackfm null;
stackfm *top;
// Pass 1 uses a lame label redefinition that forces us to map
// label ID's into unique labels for pass 3, using this database
typedef struct labelfm
{
int id, tag;
} labelfm;
labelfm labels[maxlabs - 1 + 1];
int jtag;
// most recent Jump tag translation - needed when planting event blocks
// Status of registers
static int activity[fr7 - 0 + 1];
static int claimed = 0;
// Pointer registers may be pointing to non-local display - we remember
// them for future use
static int displayhint[di - ax + 1];
// Math Co-processor uses a stack - we remember where it should be
// with this pointer
static int fpustack = 0;
// A general purpose workspace resource
typedef struct gptag
{
int info, addr, flags, link;
} gptag;
gptag gptags[maxgp - 0 + 1];
int gpasl;
static int control = checkbits;
// Current compiler flags (set by %control statement)
static int diagnose = 0;
// Current diagnostic flags (set by %diagnose statement)
static int languageflags = 0;
// Special directive flags for languages (other than standard imp)
static int nextcad = 0;
// notional code address (not real - pass3 shuffles stuff)
static int level = 0;
// current contextual level
int sym;
int pending;
// CODE SYMBOL, NEXT SYMBOL
int vlb;
int vub;
// VECTOR LOWER/UPPER BOUND
static int currentline = 0;
// SOURCE LINE NUMBER
static int stp = 0;
// STACK POINTER
int datasize;
// CURRENT DATA ITEM SIZE
static int frame = 0;
// LOCAL STACK FRAME EXTENT
int parms;
// START OF PARAMETER STACK
static int invert = 0;
// CONDITION INVERSION FLAG
static int compareunsign = 0;
// CONDITION WAS NON-STANDARD (GENERALLY FPU COMPARE)
static int uncondjump = 0;
// ADDRESS OF CODE HOLE
static int blocktype = 1;
// -1 = RECORDS, 1 = PROCEDURE, 2 = SPEC
static int inparams = 0;
// NON-ZERO INSIDE PARAMETER LISTS
int otype;
int owntype;
int ownform;
// Information about OWNs currently being declared
int spec;
int potype;
// More about current declaration
int i;
int j;
// used in the initialisation loops only
static int fpresultloc = (-(1));
// Place to store Real and LReal function results
const int maxswitch = 1000;
// Size in WORDS of switch segment table
int swtab[maxswitch - 0 + 1];
static int swtp = 0;
// pointer to next switch segment entry
static char *externalid = "", alias = "", blockname = "";
unsigned char currentstring[255 - 0 + 1];
// current string literal
int xlen;
unsigned char xsymbuff[255 - 0 + 1];
// current external string name
// WORK List - used to optimise use of temporary storage
// There is a head of list for each contextual level
static int worklist[maxlevel - 1 + 1];
double rvalue;
// floating point value for constants and initialisers
static int ownval = 0;
// value to use when initialising OWNs
// -----------------------------------------------------------
// Start with machine independent utility functions and stack
// manipulation and debug
// -----------------------------------------------------------
// >> SHOW <<
auto void show (stackfm * v)
{
// JDM The field widths have been tweaked to align columns
write (v->varno, 4);
printstring (" : Typ=");
write (v->type, 1);
printstring (" Frm=");
write (v->form, 1);
printstring (" Bse=");
write (v->base, 3);
printstring (" Dsp=");
write (v->disp, 5);
printstring (" ExtDsp=");
write (v->extdisp, 4);
printstring (" Siz=");
write (v->size, 3);
printstring (" Xtr=");
write (v->extra, 3);
printstring (" Fmt=");
write (v->format, 2);
printstring (" Dim=");
write (v->dim, 1);
printstring (" Pba=");
write (v->pbase, 4);
if (strlen (v->idname) != 0) {
printstring (concat (" Name='", concat (v->idname, "'")));
}
newline ();
}
// Simple ABORT routine
auto void abort (char *message)
{
int j;
selectoutput (report);
printstring ("Pass 2 abandoned at line ");
write (currentline, 1);
printstring (" : ");
printstring (message);
newline ();
if (stp != 0) {
printstring ("STACK:");
newline ();
for (j = 1; j <= stp; j += 1) {
spaces (11);
show (&stack[j]);
}
}
exit (0);
}
// >> WARN <<
auto void warn (int n)
{
static void *w[ /* bounds */ ] = { &&w_default };
selectoutput (report);
printstring ("*WARNING: line");
write (currentline, 1);
printstring (": ");
goto *w[n];
w_1: /* 1 */
printstring ("division by zero");
goto at;
w_2: /* 2 */
printstring ("Illegal FOR");
goto at;
w_3: /* 3 */
printstring ("Non-local control variable?");
goto at;
w_4: /* 4 */
printstring ("Invalid parameter for READ SYMBOL");
goto at;
w_5: /* 5 */
printstring ("String constant too long");
goto at;
w_6: /* 6 */
printstring ("No. of shifts outwith 0..31");
goto at;
w_7: /* 7 */
printstring ("Illegal constant exponent");
goto at;
w_8: /* 8 */
printstring ("Numerical constant too big");
goto at;
at:
newline ();
selectoutput (objout);
}
// >> MONITOR <<
auto void monitor (stackfm * v, char *text)
{
selectoutput (report);
printstring (text);
printsymbol (':');
spaces (10 - strlen (text));
show (v);
selectoutput (objout);
}
// >> GET GP TAG <<
auto int getgptag (void)
{
int l;
if (gpasl == 0)
abort ("GP Tags");
l = gpasl;
gpasl = &gptags[l]->link;
return (l);
}
// >> RET GP TAG <<
auto int retgptag (int index)
{
int link;
link = &gptags[index]->link;
&gptags[index]->link = gpasl;
gpasl = index;
return (link);
}
// ------------------------------------------------------
// Machine dependent utility routines
// ------------------------------------------------------
// Routines to write the intermediate file
// Record format is:
// <type><length><data>
// For debug purposes, the elements are all written as ascii
// characters, where <type> is a single letter, <length> is a single
// hex digit, length refers to the number of bytes (2 chars) of data.
// Intermediate file types:
const int ifobj = 0;
// A - plain object code
const int ifdata = 1;
// B - dataseg offset code word
const int ifconst = 2;
// C - const seg offset code word
const int ifdisplay = 3;
// D - display seg offset code word
const int ifjump = 4;
// E - unconditional jump to label
const int ifjcond = 5;
// F - cond jump to label JE, JNE, JLE, JL, JGE, JG
const int ifcall = 6;
// G - call a label
const int iflabel = 7;
// H - define a label
const int iffixup = 8;
// I - define location for stack fixup instruction
const int ifsetfix = 9;
// J - stack fixup <location> <amount>
const int ifreqext = 10;
// K - external name spec
const int ifreflabel = 11;
// L - relative address of label (JDM JDM added new IBJ command)
const int ifrefext = 12;
// M - external name relative offset code word (call external)
const int ifbss = 13;
// N - BSS segment offset code word
const int ifcotword = 14;
// O - Constant table word
const int ifdatword = 15;
// P - Data segment word
const int ifswtword = 16;
// Q - switch table entry - actually a label ID
const int ifsource = 17;
// R - name of the source file
const int ifdefextcode = 18;
// S - define a code label that is external
const int ifdefextdata = 19;
// T - define a data label that is external
const int ifswt = 20;
// U - switch table offset code word
const int ifline = 21;
// V - line number info for debugger
const int ifabsext = 22;
// W - external name absolute offset code word (data external)
auto void writenibble (int n)
{
n = n & 0xF;
if ((0 <= n && n <= 9)) {
printsymbol (n + '0');
} else {
printsymbol (n + ('A' - 10));
}
}
// print a number in hexadecimal, to "places" size
auto void writehex (int n, int places)
{
int p;
int shift;
shift = (places - 1) * 4;
while (shift > 0) {
p = n >> shift;
writenibble (p);
shift -= 4;
}
writenibble (n);
}
auto void writeifrecord (int type, int length, unsigned char buffer)
{
int c1;
int c2;
int i;
selectoutput (objout);
printsymbol ('A' + type);
if (length > 255)
abort ("Intermediate file record too long");
writenibble (length >> 4);
writenibble (length & 15);
i = 0;
while (length > 0) {
c1 = buffer (i) >> 4;
c2 = buffer (i) & 15;
writenibble (c1);
writenibble (c2);
i += 1;
length -= 1;
}
newline ();
}
// Simple buffered output of code bytes...
static int objectptr = 0;
const int objbufmax = 20;
static unsigned char objectbytes[objbufmax - 0 + 1];
// And corresponding bytes for the listing (not always the same for fudged opcodes)
static int listptr = 0;
const int lstbufmax = 11;
static unsigned char listbytes[lstbufmax - 0 + 1];
// routine to clean to object buffer
auto void clearobjectbuffer (void)
{
int i;
for (i = 0; i <= objbufmax; i += 1) {
objectbytes[i] = 0;
}
objectptr = 0;
}
// Routine to provide the address and hex opcode listing in the
// diagnostic output
auto void listpreamble (void)
{
int i;
selectoutput (listout);
space ();
writehex (nextcad, 4);
space ();
for (i = 0; i <= 7; i += 1) {
if (i < listptr) {
writehex (listbytes[i], 2);
space ();
} else {
spaces (3);
}
}
spaces (8);
nextcad += listptr;
listptr = 0;
}
// flush the code buffer
auto void flushcode (void)
{
if (objectptr != 0) {
writeifrecord (ifobj, objectptr, objectbytes);
clearobjectbuffer ();
// clear the output pipe
}
}
// puts a normal code byte into the listing and code pipes
auto void putcodebyte (int b)
{
objectbytes[objectptr] = b;
objectptr += 1;
}
// puts a normal code byte into the listing and code pipes
auto void putlistbyte (int b)
{
listbytes[listptr] = b;
listptr += 1;
}
// puts a normal code byte into the listing and code pipes
auto void putbyte (int b)
{
putlistbyte (b);
putcodebyte (b);
}
// A very handy little boolean function, used for instructions
// with variable size immediate operands
auto int issmall (int i)
{
if ((i < 128 && i > (-(128))))
return (1);
return (0);
}
// And aide-memoire of intel 80386 address modes...
// -------------------------
// [EAX]
// [ECX]
// [EDX]
// [EBX]
// [][]
// [disp32]
// [ESI]
// [EDI]
// -------------------------
// [EAX+disp8]
// [ECX+disp8]
// [EDX+disp8]
// [EBX+disp8]
// [][]
// [EBP+disp8]
// [ESI+disp8]
// [EDI+disp8]
// -------------------------
// [EAX+disp32]
// [ECX+disp32]
// [EDX+disp32]
// [EBX+disp32]
// [][]
// [EBP+disp32]
// [ESI+disp32]
// [EDI+disp32]
// -------------------------
// mod r/m format is:
// mod LHREG R/M
// where mod = 11 for rh registers
// plant a modrm reference where the rh operand is a register
// Both parameters are actual register numbers, not internal ID's
auto void modrmreg (int reg1, int reg2)
{
putbyte (0xC0 | (reg1 << 3) | (reg2));
}
// tags corresponding to linker directives...
const int reltag[6 - 0 + 1];
// plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
auto void norelocateoffset (int offset)
{
int i;
for (i = 1; i <= wordsize; i += 1) {
putbyte (offset & 255);
offset = offset >> 8;
}
}
// plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
auto void relocateoffset (int reloc, int offset, int extdisp)
{
int tag;
int i;
if (reloc == 0) {
norelocateoffset (offset);
} else {
flushcode ();
// so that only the offset is going into the queue
tag = reltag[reloc];
if (tag == ifabsext) {
putbyte (offset & 255);
offset = offset >> 8;
putbyte (offset & 255);
offset = offset >> 8;
putbyte (extdisp & 255);
extdisp = extdisp >> 8;
putbyte (extdisp & 255);
extdisp = extdisp >> 8;
writeifrecord (tag, wordsize, objectbytes);
clearobjectbuffer ();
// clear the queue
} else {
for (i = 1; i <= wordsize; i += 1) {
putbyte (offset & 255);
offset = offset >> 8;
}
writeifrecord (tag, wordsize, objectbytes);
clearobjectbuffer ();
// clear the queue
}
}
}
// plant a modrm reference where the rh operand is in memory
// Parameter REG1 is an actual register number, but BASE is an internal ID
auto void modrmmem (int reg1, int base, int disp, int extdisp)
{
int mod;
int reloc;
reloc = base >> 4;
base = base & 15;
if (base == 0) {
// no register, just a displacement
// mod = 000, rm = 101
putbyte ((reg1 << 3) | 5);
relocateoffset (reloc, disp, extdisp);
} else {
if ((disp == 0 && base != bp)) {
mod = 0;
} else {
if (issmall (disp) != 0) {
// fits in one byte
mod = 1;
} else {
mod = 2;
}
}
// unfortunately displacement (even zero) must be output in full if
// the offset is relocatable
if (reloc != 0)
mod = 2;
if ((base > di || base == sp)) {
abort ("Internal address mode error");
}
// Note - base-1 maps internal ID to real register
putbyte ((mod << 6) | (reg1 << 3) | (base - 1));
if (mod == 1) {
putbyte (disp);
} else {
if (mod == 2)
relocateoffset (reloc, disp, extdisp);
}
}
}
const char *regname[di - ax + 1];
const char *reg8name[bh - al + 1];
const char *relocname[6 - 0 + 1];
// Print the corresponding memory access string
// BASE is an internal ID, not an actual register number
auto void printmemref (int base, int disp)
{
int reloc;
reloc = base >> 4;
base = base & 15;
selectoutput (listout);
printsymbol ('[');
if (base != 0) {
printstring (regname[base]);
if (reloc != 0) {
printsymbol ('+');
printstring (relocname[reloc]);
}
if (disp != 0) {
if (disp > 0)
printsymbol ('+');
write (disp, 1);
}
} else {
if (reloc != 0) {
printstring (relocname[reloc]);
printsymbol ('+');
}
writehex (disp, 4);
}
printsymbol (']');
}
// opcodes
const char *opname[jmp - nop + 1];
const unsigned char opvalue[jmp - nop + 1];
// 8 bit equivalent opcodes
const unsigned char op8value[jmp - nop + 1];
// An opcode with no operands (eg RET)
auto void dumpsimple (int opn)
{
putbyte (opvalue[opn]);
listpreamble ();
printstring (opname[opn]);
newline ();
flushcode ();
}
// A special bit of magic, used in record assignment
auto void dumprepmovsb (void)
{
putbyte (0xF3);
// rep
putbyte (0xA4);
// movsb
listpreamble ();
printstring ("REP MOVSB");
newline ();
flushcode ();
}
// Used in record = 0 assignment
auto void dumprepstosb (void)
{
putbyte (0xF3);
// rep
putbyte (0xAA);
// stosb
listpreamble ();
printstring ("REP STOSB");
newline ();
flushcode ();
}
// unary register operation - DEC, INC, NEG, NOT, POP, PUSH, IDIV, IMUL
// REG is an internal ID, not an actual register number
auto void dumpur (int opn, int reg)
{
static void *ops[ /* bounds */ ] = { &&ops_default };
displayhint[reg] = 0;
goto *ops[opn];
ops_dec: /* dec */
putbyte (0x48 + reg - ax);
goto break;
ops_inc: /* inc */
putbyte (0x40 + reg - ax);
goto break;
ops_neg: /* neg */
putbyte (0xF7);
modrmreg (3, reg - ax);
goto break;
ops_not: /* not */
putbyte (0xF7);
modrmreg (2, reg - ax);
goto break;
ops_pop: /* pop */
putbyte (0x58 + reg - ax);
goto break;
ops_push: /* push */
putbyte (0x50 + reg - ax);
goto break;
ops_idiv: /* idiv */
putbyte (0xF7);
modrmreg (7, reg - ax);
goto break;
ops_imul: /* imul */
putbyte (0xF7);
modrmreg (5, reg - ax);
goto break;
break:
listpreamble ();
printstring (opname[opn]);
space ();
printstring (regname[reg]);
newline ();
flushcode ();
}
// Plant code for a unary operation on memory
// BASE is an internal ID, not the actual register number
auto void dumpum (int opn, int base, int disp, int extdisp)
{
static void *ops[ /* bounds */ ] = { &&ops_default };
goto *ops[opn];
ops_dec: /* dec */
putbyte (0xFF);
modrmmem (1, base, disp, extdisp);
goto break;
ops_inc: /* inc */
putbyte (0xFF);
modrmmem (0, base, disp, extdisp);
goto break;
ops_neg: /* neg */
putbyte (0xF7);
modrmmem (3, base, disp, extdisp);
goto break;
ops_not: /* not */
putbyte (0xF7);
modrmmem (2, base, disp, extdisp);
goto break;
ops_pop: /* pop */
putbyte (0x8F);
modrmmem (0, base, disp, extdisp);
goto break;
ops_push: /* push */
putbyte (0xFF);
modrmmem (6, base, disp, extdisp);
goto break;
ops_idiv: /* idiv */
putbyte (0xF7);
modrmmem (7, base, disp, extdisp);
goto break;
ops_imul: /* imul */
putbyte (0xF7);
modrmmem (5, base, disp, extdisp);
goto break;
ops_jmp: /* jmp */
putbyte (0xFF);
modrmmem (4, base, disp, extdisp);
goto break;
ops_call: /* call */
putbyte (0xFF);
modrmmem (2, base, disp, extdisp);
goto break;
break:
listpreamble ();
printstring (opname[opn]);
printstring (" WORD ");
// otherwise it's ambiguous for the reader
printmemref (base, disp);
newline ();
flushcode ();
}
// Plant code for a unary operation on an 8 bit memory location
// Not all of the possible unary ops make sense as 8 bit destinations
// BASE is an internal ID, not the actual register number
auto void dumpum8 (int opn, int base, int disp, int extdisp)
{
int baseop;
int index;
if ((opn == dec || opn == inc)) {
baseop = 0xFE;
if (opn == dec)
index = 1;
else
index = 0;
} else {
if ((opn == not || opn == neg)) {
baseop = 0xF6;
if (opn == not)
index = 2;
else
index = 3;
} else {
abort ("Invalid UM8");
}
}
putbyte (baseop);
modrmmem (index, base, disp, extdisp);
listpreamble ();
printstring (opname[opn]);
printstring (" BYTE ");
// otherwise it's ambiguous for the reader
printmemref (base, disp);
newline ();
flushcode ();
}
// Plant a Memory <- Reg operation
// Both BASE and REG are internal ID's, not actual register numbers
auto void dumpmr (int opn, int base, int disp, int extdisp, int reg)
{
if (opn == shl) {
// special "shift by CL"
putbyte (0xD3);
modrmmem (4, base, disp, extdisp);
} else {
if (opn == shr) {
putbyte (0xD3);
modrmmem (5, base, disp, extdisp);
} else {
// normal stuff
putbyte (opvalue[opn]);
modrmmem (reg - ax, base, disp, extdisp);
}
}
listpreamble ();
printstring (opname[opn]);
space ();
printmemref (base, disp);
printsymbol (',');
printstring (regname[reg]);
newline ();
flushcode ();
}
// Plant an 8 bit Memory <- Reg operation
// Both BASE and REG are internal ID's, not actual register numbers
auto void dumpmr8 (int opn, int base, int disp, int extdisp, int reg)
{
if (opn == shl) {
// special "shift by CL"
putbyte (0xD2);
modrmmem (4, base, disp, extdisp);
} else {
if (opn == shr) {
putbyte (0xD2);
modrmmem (5, base, disp, extdisp);
} else {
// normal stuff
putbyte (op8value[opn]);
modrmmem (reg - al, base, disp, extdisp);
}
}
listpreamble ();
printstring (opname[opn]);
space ();
printmemref (base, disp);
printsymbol (',');
printstring (reg8name[reg]);
newline ();
flushcode ();
}
// Plant a 16 bit Reg <- Memory operation
// Both BASE and REG are internal ID's, not actual register numbers
auto void dumprm (int opn, int reg, int base, int disp, int extdisp)
{
// We optimise the fairly common instruction MOV AX,[disp] with
// the special short-form quirk of the 8086...
if ((reg == ax && (opn == mov && base & 15 == 0))) {
putbyte (0xA1);
relocateoffset (base >> 4, disp, extdisp);
} else {
displayhint[reg] = 0;
putbyte (opvalue[opn] + 2);
modrmmem (reg - ax, base, disp, extdisp);
}
listpreamble ();
printstring (opname[opn]);
space ();
printstring (regname[reg]);
printsymbol (',');
printmemref (base, disp);
newline ();
flushcode ();
}
// Plant an 8 bit Reg <- Memory operation
// Both BASE and REG are internal ID's, not actual register numbers
auto void dumprm8 (int opn, int reg, int base, int disp, int extdisp)
{
putbyte (op8value[opn] + 2);
modrmmem (reg - al, base, disp, extdisp);
listpreamble ();
printstring (opname[opn]);
space ();
printstring (reg8name[reg]);
printsymbol (',');
printmemref (base, disp);
newline ();
flushcode ();
}
// Plant a word Reg <- Reg operation
// Both register parameters are internal ID's
auto void dumprr (int opn, int reg1, int reg2)
{
displayhint[reg1] = 0;
if (opn == shl) {
// special "shift by CL"
putbyte (0xD3);
modrmreg (4, reg1 - ax);
} else {
if (opn == shr) {
putbyte (0xD3);
modrmreg (5, reg1 - ax);
} else {
// normal stuff
putbyte (opvalue[opn]);
modrmreg (reg2 - ax, reg1 - ax);
}
}
listpreamble ();
printstring (opname[opn]);
space ();
printstring (regname[reg1]);
printsymbol (',');
printstring (regname[reg2]);
newline ();
flushcode ();
}
auto void dumprr8 (int opn, int reg1, int reg2)
{
if (opn == shl) {
// special "shift by CL"
putbyte (0xD2);
modrmreg (4, reg1 - al);
} else {
if (opn == shr) {
putbyte (0xD2);
modrmreg (5, reg1 - al);
} else {
putbyte (op8value[opn]);
modrmreg (reg2 - al, reg1 - al);
}
}
listpreamble ();
printstring (opname[opn]);
space ();
printstring (reg8name[reg1]);
printsymbol (',');
printstring (reg8name[reg2]);
newline ();
flushcode ();
}
const unsigned char aximmediatevalue[xor - nop + 1];
// Register immediate operations - can be MOV, Math, or Shift
// The immediate operand may be a relocated offset as part of
// an address calculation
auto void dumprioffset (int opn, int reg, int reloc, int immed, int extdisp)
{
int subop;
static void *ops[ /* bounds */ ] = { &&ops_default };
displayhint[reg] = 0;
reloc = reloc >> 4;
// because we pass around the or-able version
if ((reg == ax && opn <= xor)) {
putbyte (aximmediatevalue[opn]);
relocateoffset (reloc, immed, extdisp);
goto break;
} else {
goto *ops[opn];
}
ops_mov: /* mov */
putbyte (0xB8 + reg - ax);
relocateoffset (reloc, immed, extdisp);
goto break;
ops_add: /* add */
subop = 0;
if ((issmall (immed) != 0 && reloc == 0)) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
}
goto break;
ops_adc: /* adc */
subop = 2;
if ((issmall (immed) != 0 && reloc == 0)) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
}
goto break;
ops_cmp: /* cmp */
subop = 7;
if ((issmall (immed) != 0 && reloc == 0)) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
}
goto break;
ops_sub: /* sub */
subop = 5;
if ((issmall (immed) != 0 && reloc == 0)) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
}
goto break;
ops_and: /* and */
subop = 4;
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
goto break;
ops_or: /* or */
subop = 1;
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
goto break;
ops_xor: /* xor */
subop = 6;
putbyte (0x81);
modrmreg (subop, reg - ax);
relocateoffset (reloc, immed, extdisp);
goto break;
ops_shl: /* shl */
subop = 4;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmreg (subop, reg - ax);
} else {
putbyte (0xC1);
modrmreg (subop, reg - ax);
putbyte (immed);
}
goto break;
ops_shr: /* shr */
subop = 5;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmreg (subop, reg - ax);
} else {
putbyte (0xC1);
modrmreg (subop, reg - ax);
putbyte (immed);
}
goto break;
break:
listpreamble ();
printstring (opname[opn]);
space ();
printstring (regname[reg]);
printsymbol (',');
if (reloc != 0) {
printstring (relocname[reloc]);
printsymbol ('+');
}
write (immed, 1);
newline ();
flushcode ();
}
// Register immediate operations - can be MOV, Math, or Shift
auto void dumpri (int opn, int reg, int immed)
{
int subop;
static void *ops[ /* bounds */ ] = { &&ops_default };
displayhint[reg] = 0;
if ((reg == ax && opn <= xor)) {
putbyte (aximmediatevalue[opn]);
norelocateoffset (immed);
goto break;
} else {
goto *ops[opn];
}
ops_mov: /* mov */
putbyte (0xB8 + reg - ax);
norelocateoffset (immed);
goto break;
ops_add: /* add */
subop = 0;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
}
goto break;
ops_adc: /* adc */
subop = 2;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
}
goto break;
ops_cmp: /* cmp */
subop = 7;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
}
goto break;
ops_sub: /* sub */
subop = 5;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmreg (subop, reg - ax);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
}
goto break;
ops_and: /* and */
subop = 4;
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
goto break;
ops_or: /* or */
subop = 1;
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
goto break;
ops_xor: /* xor */
subop = 6;
putbyte (0x81);
modrmreg (subop, reg - ax);
norelocateoffset (immed);
goto break;
ops_shl: /* shl */
subop = 4;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmreg (subop, reg - ax);
} else {
putbyte (0xC1);
modrmreg (subop, reg - ax);
putbyte (immed);
}
goto break;
ops_shr: /* shr */
subop = 5;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmreg (subop, reg - ax);
} else {
putbyte (0xC1);
modrmreg (subop, reg - ax);
putbyte (immed);
}
goto break;
break:
listpreamble ();
printstring (opname[opn]);
space ();
printstring (regname[reg]);
printsymbol (',');
write (immed, 1);
newline ();
flushcode ();
}
// Memory (word) immediate operations - can be MOV, Math, or Shift
auto void dumpmi (int opn, int base, int disp, int extdisp, int immed)
{
int subop;
static void *ops[ /* bounds */ ] = { &&ops_default };
goto *ops[opn];
ops_mov: /* mov */
putbyte (0xC7);
modrmmem (0, base, disp, extdisp);
norelocateoffset (immed);
goto break;
ops_add: /* add */
subop = 0;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
}
goto break;
ops_adc: /* adc */
subop = 2;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
}
goto break;
ops_cmp: /* cmp */
subop = 7;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
}
goto break;
ops_sub: /* sub */
subop = 5;
if (issmall (immed) != 0) {
putbyte (0x83);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
} else {
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
}
goto break;
ops_and: /* and */
subop = 4;
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
goto break;
ops_or: /* or */
subop = 1;
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
goto break;
ops_xor: /* xor */
subop = 6;
putbyte (0x81);
modrmmem (subop, base, disp, extdisp);
norelocateoffset (immed);
goto break;
ops_shl: /* shl */
subop = 4;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmmem (subop, base, disp, extdisp);
} else {
putbyte (0xC1);
modrmmem (subop, base, disp, extdisp);
putbyte (immed);
}
goto break;
ops_shr: /* shr */
subop = 5;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD1);
modrmmem (subop, base, disp, extdisp);
} else {
putbyte (0xC1);
modrmmem (subop, base, disp, extdisp);
putbyte (immed);
}
goto break;
break:
listpreamble ();
printstring (opname[opn]);
printstring (" WORD ");
// otherwise it's ambiguous for the reader
printmemref (base, disp);
printsymbol (',');
write (immed, 1);
newline ();
flushcode ();
}
// Memory (8 bit) immediate operations - can be MOV, Math, or Shift
auto void dumpmi8 (int opn, int base, int disp, int extdisp, int immed)
{
int subop;
static void *ops[ /* bounds */ ] = { &&ops_default };
goto *ops[opn];
ops_mov: /* mov */
subop = 0;
putbyte (0xC6);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_add: /* add */
subop = 0;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_adc: /* adc */
subop = 2;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_cmp: /* cmp */
subop = 7;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_sub: /* sub */
subop = 5;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_and: /* and */
subop = 4;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_or: /* or */
subop = 1;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_xor: /* xor */
subop = 6;
putbyte (0x80);
modrmmem (subop, base, disp, extdisp);
putbyte (immed & 255);
goto break;
ops_shl: /* shl */
subop = 4;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD0);
modrmmem (subop, base, disp, extdisp);
} else {
putbyte (0xC0);
modrmmem (subop, base, disp, extdisp);
putbyte (immed);
}
goto break;
ops_shr: /* shr */
subop = 5;
if (immed == 1) {
// special shift-by-one instruction
putbyte (0xD0);
modrmmem (subop, base, disp, extdisp);
} else {
putbyte (0xC0);
modrmmem (subop, base, disp, extdisp);
putbyte (immed);
}
goto break;
break:
listpreamble ();
printstring (opname[opn]);
printstring (" BYTE ");
// otherwise it's ambiguous for the reader
printmemref (base, disp);
printsymbol (',');
write (immed, 1);
newline ();
flushcode ();
}
// Finally, a catch-all that recasts operations using generic
// Var Stack structures
// Plant a 16 bit Reg <- Var operation
auto void dumprv (int opn, int reg, stackfm * v)
{
if (v->form == vinr) {
dumprr (opn, reg, v->base);
} else {
if (v->form == vins) {
dumprm (opn, reg, v->base | v->scope, v->disp, v->extdisp);
} else {
if (v->form == constant) {
dumprioffset (opn, reg, v->scope, v->disp, v->extdisp);
} else {
abort ("Address Mode");
}
}
}
}
// Another special dumper - the only "Unary" operation that
// takes an immediate operand is PUSH
auto void dumppushi (int reloc, int immed, int extdisp)
{
reloc = reloc >> 4;
// because we pass around the or-able version
if ((reloc == 0 && issmall (immed) != 0)) {
putbyte (0x6A);
putbyte (immed & 255);
} else {
putbyte (0x68);
relocateoffset (reloc, immed, extdisp);
}
listpreamble ();
printstring ("PUSH");
space ();
if (reloc != 0) {
printstring (relocname[reloc]);
printsymbol ('+');
}
write (immed, 1);
newline ();
flushcode ();
}
auto void dumpvpush (stackfm * v)
{
if (v->form == vinr) {
dumpur (push, v->base);
} else {
if (v->form == vins) {
dumpum (push, v->base | v->scope, v->disp, v->extdisp);
} else {
if (v->form == constant) {
dumppushi (v->scope, v->disp, v->extdisp);
} else {
abort ("Push Mode");
}
}
}
}
// ----------------------------------------------------------
// Floating point instructions - much simpler since there are
// only two forms - RR and RM
const char *flopname[fldpi - fild + 1];
// The prefix opcode
const unsigned char flprefix[fldpi - fild + 1];
// The function selector to put in the field in the second byte
// (or the second byte)
const unsigned char flindex[fldpi - fild + 1];
// Plant a Floating Point Reg <- Memory operation
// BASE is an internal ID, not actual register number
// Destination register is implicitly the stack top
auto void dumpfloprm (int opn, int base, int disp, int extdisp)
{
if (opn <= fldq) {
// a load type
fpustack += 1;
if (fpustack > 8)
abort ("FPU Stack Overflow");
} else {
fpustack -= 1;
if (fpustack < 0)
abort ("FPU Stack Underflow");
}
// putbyte(16_9B); ! we prepend a WAIT to everything
putbyte (flprefix[opn]);
modrmmem (flindex[opn], base, disp, extdisp);
listpreamble ();
printstring (flopname[opn]);
space ();
printmemref (base, disp);
newline ();
flushcode ();
}
// Plant a Floating Point Reg <- Reg operation
// Both register parameters are internal ID's that we
// convert to stack offsets
auto void dumpfloprr (int opn, int reg1, int reg2)
{
int top;
top = fpustack + (fr0 - 1);
if (reg2 != top)
abort ("FPU Stack Address");
if (opn < fchs) {
// two operands - will pop one
fpustack -= 1;
if (opn == fcmp)
fpustack -= 1;
// COMPP pops both registers
if (fpustack < 0)
abort ("FPU Stack Underflow");
}
// putbyte(16_9B); ! we prepend a WAIT to everything
putbyte (flprefix[opn]);
putbyte (flindex[opn] | (top - reg1));
listpreamble ();
printstring (flopname[opn]);
space ();
printstring ("ST(");
write (top - reg1, 1);
printstring ("),ST");
newline ();
flushcode ();
}
// Plant a "special" floating point operation
auto void dumpflopspec (int opn)
{
if (opn >= fldz) {
// load a constant
fpustack += 1;
if (fpustack > 8)
abort ("FPU Stack Overflow");
}
// putbyte(16_9B); ! we prepend a WAIT to everything
putbyte (flprefix[opn]);
putbyte (flindex[opn]);
listpreamble ();
printstring (flopname[opn]);
newline ();
flushcode ();
}
auto void dumpjump (int opn, int labelid)
{
// we put conventional assembler into the pipe for the listing
// (with a zero jump offset) but then re-use the pipe for the
// pseudo-code for the jump
putbyte (opvalue[opn]);
putbyte (0);
if (opn == call)
putbyte (0);
listpreamble ();
printstring (opname[opn]);
space ();
if (opn == call) {
// See if we can show the routine name
printstring (concat ("'", concat (top->idname, "' (INTERNAL ")));
printsymbol ('L');
write (labelid, 1);
printstring (" )");
} else {
printsymbol ('L');
write (labelid, 1);
}
newline ();
clearobjectbuffer ();
// zap the current contents of the pipe
if (opn == jmp) {
putcodebyte (labelid & 255);
putcodebyte (labelid >> 8);
writeifrecord (ifjump, 2, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
} else if (opn == call) {
// JDM replaced use of IF CALL command by IF REFLABEL command
// ! Generated code using IF CALL ibj command
// putcodebyte(labelid & 255)
// putcodebyte(labelid >> 8)
// writeifrecord(IF CALL, 2, objectbytes)
// ClearObjectBuffer; ! zap the current contents of the pipe
// JDM JDM Generated code using IF REFLABEL ibj command
// plant the CALL code
putcodebyte (0xE8);
// call with relative address
writeifrecord (ifobj, 1, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
// plant the relative address of the label
putcodebyte (labelid & 255);
putcodebyte (labelid >> 8);
putcodebyte (0);
// JDM set offset to zero
putcodebyte (0);
writeifrecord (ifreflabel, 4, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
} else {
// not an unconditional JMP or a CALL
// assume it is a conditional JMP (i.e. JE,JNE, etc.)
putcodebyte (opn - je);
putcodebyte (labelid & 255);
putcodebyte (labelid >> 8);
writeifrecord (ifjcond, 3, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
}
// finally, calls may trash registers...
if (opn == call) {
displayhint[bx] = 0;
displayhint[si] = 0;
displayhint[di] = 0;
}
}
// call the n'th external routine we've spec'ed
auto void dumpextcall (int labelid)
{
displayhint[bx] = 0;
displayhint[si] = 0;
displayhint[di] = 0;
putbyte (opvalue[call]);
flushcode ();
// plant the "CALL" instruction
putbyte (labelid & 255);
putbyte (labelid >> 8);
listpreamble ();
// JDM JDM attempt to show external routine name
printstring ("CALL ");
if (labelid <= lastperm) {
// This is an internal "perm" routine
// So, show the name
printstring (concat ("'", concat (permname[labelid], "'")));
} else {
// this is an external routine
printstring (concat ("'", concat (top->idname, "'")));
}
printstring (" (EXTERN ");
write (labelid, 1);
printstring (")");
newline ();
// JDM JDM
writeifrecord (ifrefext, wordsize, objectbytes);
// writeifrecord(IF REFEXT, 2, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
}
auto void dumplabel (int labelid)
{
selectoutput (listout);
space ();
writehex (nextcad, 4);
spaces (22);
printsymbol ('L');
write (labelid, 1);
printstring (" EQU $");
newline ();
clearobjectbuffer ();
// zap the current contents of the pipe
putcodebyte (labelid & 255);
putcodebyte (labelid >> 8);
writeifrecord (iflabel, 2, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
displayhint[bx] = 0;
displayhint[si] = 0;
displayhint[di] = 0;
}
auto void dumpstaticalloc (int which, int level, char **name)
{
int i;
int len;
// we pretend to dump "C8 00 00 lev ENTER 0000,lev" but we actually plant a special pass 2 directive
putbyte (0xC8);
putbyte (0x00);
putbyte (0x00);
putbyte (level);
listpreamble ();
printstring ("ENTER 0000,");
write (level, 1);
newline ();
clearobjectbuffer ();
// zap the current contents of the pipe
putcodebyte (which & 255);
putcodebyte (which >> 8);
putcodebyte (level);
// we also pass the (truncated) name of the routine for pass3 diagnostic use
len = strlen (name);
if (len > 16)
len = 16;
for (i = 1; i <= len; i += 1) {
putcodebyte (name ((i) - 1));
}
writeifrecord (iffixup, len + 3, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
}
// Pass 3 goes back and plants the correct preamble code for
// the static allocation based on this directive, and also fills
// in the event trap block as appropriate
auto void dumpstaticfill (int which, int size, int events, int evep, int evfrom)
{
clearobjectbuffer ();
// zap the current contents of the pipe
putcodebyte (which & 255);
putcodebyte (which >> 8);
putcodebyte (size & 255);
putcodebyte (size >> 8);
putcodebyte (events & 255);
putcodebyte (events >> 8);
putcodebyte (evep & 255);
putcodebyte (evep >> 8);
putcodebyte (evfrom & 255);
putcodebyte (evfrom >> 8);
writeifrecord (ifsetfix, 10, objectbytes);
clearobjectbuffer ();
// zap the current contents of the pipe
}
// dump words for the constant segment or the data segment
// Adjusts CAD so that the diagnostic listing looks sensible
auto void dumpcdword (int word, int which)
{
int tag;
int tmpcad;
int hi;
int lo;
static int cptr = 0;
static int dptr = 0;
static int sptr = 0;
tmpcad = nextcad;
if (which == 2) {
tag = ifswtword;
nextcad = sptr;
sptr += 2;
} else {
if (which == 1) {
tag = ifcotword;
nextcad = cptr;
cptr += 2;
} else {
tag = ifdatword;
nextcad = dptr;
dptr += 2;
}
}
hi = word >> 8;
lo = word & 255;
putbyte (lo);
putbyte (hi);
listpreamble ();
printstring ("db ");
writehex (lo, 2);
printsymbol (',');
writehex (hi, 2);
printstring (" ; ");
if ((lo > 32 && lo < 127))
printsymbol (lo);
else
printsymbol ('.');
if ((hi > 32 && hi < 127))
printsymbol (hi);
else
printsymbol ('.');
newline ();
writeifrecord (tag, 2, objectbytes);
clearobjectbuffer ();
// clear the pipe
nextcad = tmpcad;
// restore the real CAD
}
// tell the object file maker what source line we are on
auto void dumplinenumber (int line)
{
unsigned char buffer[1 - 0 + 1];
buffer[0] = (line & 255);
buffer[1] = (line >> 8);
writeifrecord (ifline, 2, buffer);
}
// utility to copy an IMP string into a simple buffer to
// pass to the IF Record routine
auto void strtoxsym (char **s)
{
int l;
l = strlen (s);
xlen = 0;
while (xlen < l) {
xsymbuff[xlen] = s ((xlen + 1) - 1);
xlen += 1;
}
}
// tell the object maker the source file name
auto void dumpsourcename (char *filename)
{
strtoxsym (filename);
writeifrecord (ifsource, xlen, xsymbuff);
}
// Plant a request to the linker for the external name, and
// return an index number to refer to it with in future
auto int externalref (char *extname)
{
static int nextextref = 1;
strtoxsym (extname);
writeifrecord (ifreqext, xlen, xsymbuff);
nextextref += 1;
return (nextextref - 1);
}
// tell the linker about an external definition
auto void fillexternal (int seg, int offset, char *extname)
{
strtoxsym (extname);
if (seg == code) {
writeifrecord (ifdefextcode, xlen, xsymbuff);
} else {
writeifrecord (ifdefextdata, xlen, xsymbuff);
// er, this doesn't actually work yet!
}
}
// ------------------------------------------------------
// Constant table utility routines
//
// Rather than dump literal constants as they occur, we
// collect them in a table. Whenever the compiler wants
// any kind of literal, we look to see if we already
// have it. Note this automatically solves re-use of
// things like floating point constants, string newline,
// and fixed array dope vectors. When the table starts
// to get fairly full, we flush it. Obviously that means
// in a large program we might not actually get full re-use
// of constants after we've flushed, but the idea is sound.
//
// For the convenience of the caller, several versions of
// pretty much the same thing are provided.
// ------------------------------------------------------
const int cotsize = 2000;
static unsigned char contable[cotsize - 0 + 1];
static int cotp = 0;
static int cotoffset = 0;
// updated on a flush
auto void flushcot (void)
{
int i;
// We output a position hint to the diagnostic stream
// Note that although this is intended to look like
// 8086 assembly directives the real work is done by
// pass 3 - this is only to guide the human reader as
// to what is going on
selectoutput (listout);
printstring (" _TEXT ENDS");
newline ();
printstring (" CONST SEGMENT WORD PUBLIC 'CONST'");
newline ();
i = 0;
while (i < cotp) {
dumpcdword ((contable[i + 1] << 8) | contable[i], 1);
i += 2;
}
// Update the pointers
cotp = 0;
cotoffset += i;
// and send another hint
selectoutput (listout);
printstring (" CONST ENDS");
newline ();
printstring (" _TEXT SEGMENT WORD PUBLIC 'CODE'");
newline ();
}
// return the offset in the const segment of a byte
// with value b
auto int getcotb (unsigned char b)
{
int i;
i = 0;
while (i < cotp) {
if (contable[i] == b)
return (i + cotoffset);
i += 1;
}
// value wasn't there
if (cotp == cotsize)
flushcot ();
contable[cotp] = b;
cotp += 1;
return ((cotp - 1) + cotoffset);
}
// return the offset in the const segment of a word
// with value w
auto int getcotw (int w)
{
int i;
int cw;
i = 0;
while (i < cotp - 3) {
cw = contable[i] | (contable[i + 1] << 8) | (contable[i + 2] << 16) | (contable[i + 3] << 24);
if (cw == w)
return (i + cotoffset);
i += wordsize;
}
// value wasn't there - first make sure there is space
if (cotp > cotsize - wordsize)
flushcot ();
// now round off the COT
cotp = (cotp + align) & ((~(align)));
for (i = 1; i <= wordsize; i += 1) {
contable[cotp] = w & 255;
w = w >> 8;
cotp += 1;
}
return ((cotp - wordsize) + cotoffset);
}
// return the offset in the const segment of double precision real number
auto int getcotdouble (double _double_)
{
int i;
i = 0;
while (i < cotp - 7) {
if ((contable[i] == byteinteger (addr (_double_))
&& (contable[i + 1] == byteinteger (addr (_double_) + 1)
&& (contable[i + 2] == byteinteger (addr (_double_) + 2)
&& (contable[i + 3] == byteinteger (addr (_double_) + 3)
&& (contable[i + 4] == byteinteger (addr (_double_) + 4)
&& (contable[i + 5] == byteinteger (addr (_double_) + 5)
&& (contable[i + 6] == byteinteger (addr (_double_) + 6) && contable[i + 7] == byteinteger (addr (_double_) + 7)))))))))
return (i + cotoffset);
i += 4;
}
// value wasn't there - first make sure there is space
if (cotp > cotsize - 8)
flushcot ();
// now round off the COT
cotp = (cotp + align) & ((~(align)));
for (i = 0; i <= 7; i += 1) {
contable[cotp] = byteinteger (addr (_double_) + i);
cotp += 1;
}
return ((cotp - 8) + cotoffset);
}
// return the offset in the const segment of a quad word
// with value q0:q1:q2:q3 (lo to hi)
auto int getcot4 (int q0, int q1, int q2, int q3)
{
int i;
int cw0;
int cw1;
int cw2;
int cw3;
i = 0;
cw0 = contable[i] | (contable[i + 1] << 8) | (contable[i + 2] << 16) | (contable[i + 3] << 24);
cw1 = contable[i + 4] | (contable[i + 5] << 8) | (contable[i + 6] << 16) | (contable[i + 7] << 24);
cw2 = contable[i + 8] | (contable[i + 9] << 8) | (contable[i + 10] << 16) | (contable[i + 11] << 24);
while (i < cotp - 15) {
cw3 = contable[i + 12] | (contable[i + 13] << 8) | (contable[i + 14] << 16) | (contable[i + 15] << 24);
if ((cw0 == q0 && (cw1 == q1 && (cw2 == q2 && cw3 == q3))))
return (i + cotoffset);
i += wordsize;
cw0 = cw1;
cw1 = cw2;
cw2 = cw3;
}
// value wasn't there - first make sure there is space
if (cotp > cotsize - 16)
flushcot ();
// now round off the COT
cotp = (cotp + align) & ((~(align)));
for (i = 1; i <= wordsize; i += 1) {
contable[cotp] = q0 & 255;
q0 = q0 >> 8;
cotp += 1;
}
for (i = 1; i <= wordsize; i += 1) {
contable[cotp] = q1 & 255;
q1 = q1 >> 8;
cotp += 1;
}
for (i = 1; i <= wordsize; i += 1) {
contable[cotp] = q2 & 255;
q2 = q2 >> 8;
cotp += 1;
}
for (i = 1; i <= wordsize; i += 1) {
contable[cotp] = q3 & 255;
q3 = q3 >> 8;
cotp += 1;
}
return ((cotp - 16) + cotoffset);
}
static int nullstring = (-(1));
// get an index into the constant table for the string literal
// in the array s
auto int getcots (unsigned char b)
{
int i;
int first;
int slen;
int match;
slen = b (0);
// We optimise the Null String "" in comparisons, so we remember
// the location here
if (slen == 0) {
nullstring = getcotb (0);
return (nullstring);
}
first = 0;
// offset to search in contable
while (first + slen < cotp) {
// so long as there are that many bytes left
match = 1;
// Simple check of string lengths
if (slen != contable[first]) {
match = 0;
break;
}
// ok, so lengths match but do the contents
for (i = 1; i <= slen; i += 1) {
if (b (i) != contable[first + i]) {
match = 0;
break;
}
}
if (match == 1)
return (first + cotoffset);
first += 1;
// try the next solution
}
// if we get here, it wasn't already in the constant table
// Ok, so will we overflow the buffer
if ((cotp + slen + 1) >= cotsize)
flushcot ();
// dump the string length
first = cotp;
contable[cotp] = slen;
cotp += 1;
// Now, dump the string contents
for (i = 1; i <= slen; i += 1) {
contable[cotp] = b (i);
cotp += 1;
}
return (first + cotoffset);
}
// ------------------------------------------------------
// Data segment utility routines
//
// Unlike constants, we can't re-use data segment items,
// which makes this much simpler. We still accumulate
// the bytes in a table because (1) we can make life
// more efficient for Pass 3 that way and (2) by collecting
// the bytes together we can produce more convincing debug
// code listings, especially for programs that don't need
// to flush the table in the middle of the code.
// Note that because data segment offsets are used directly
// as variable displacements, our pointer DATATP doesn't
// wrap like the COTP does, and instead we subtract the
// offset before we use it...
// ------------------------------------------------------
const int datatlimit = 1999;
// Size in bytes of data segment table
unsigned char datat[datatlimit - 0 + 1];
static int datatp = 0;
// pointer to next data segment byte
static int datatoffset = 0;
// updated on a flush
// Flush the accumulated data table
auto void flushdata (void)
{
int i;
int limit;
// We output a position hint to the diagnostic stream
selectoutput (listout);
printstring (" ENDS");
newline ();
printstring (" DATA SEGMENT WORD PUBLIC 'DATA'");
newline ();
i = 0;
limit = datatp - datatoffset;
while (i < limit) {
dumpcdword ((datat[i + 1] << 8) | datat[i], 0);
i += 2;
}
datatoffset = datatp;
// and send another hint
selectoutput (listout);
printstring (" DATA ENDS");
newline ();
}
// >> GBYTE <<
// Simple byte in data segment
auto void gbyte (int n)
{
if ((datatp - datatoffset) > datatlimit)
flushdata ();
datat[datatp - datatoffset] = n & 255;
datatp += 1;
}
// >> GPUT <<
// Put a word into data segment
auto void gput (int n)
{
int i;
for (i = 1; i <= wordsize; i += 1) {
gbyte (n);
n = n >> 8;
}
}
// >> GFIX <<
// round off the datasegment pointer for alignment
auto void gfix (int align)
{
while (datatp & align != 0)
gbyte (0);
}
// -----------------------------------------------------
// The last table we collect as we go along is the switch
// table. We don't provide individual routines to fill
// it in, but for tidyness we provide this routine to send
// the contents to pass 3
auto void flushswitch (void)
{
int i;
selectoutput (listout);
printstring (" ENDS");
newline ();
printstring (" _SWTAB SEGMENT WORD PUBLIC '_SWTAB'");
newline ();
i = 0;
while (i < swtp) {
dumpcdword (swtab[i], 2);
i += 1;
}
// and send another hint
selectoutput (listout);
printstring (" _SWTAB ENDS");
newline ();
}
// -------------------------------------------------------------
// Print the source code lines up to the indicated line
// number - these will interleave with the diagnostic assembly
// output
static int echoline = 0;
auto void echosourceline (void)
{
int ch;
static int sourceeof = 0;
echoline += 1;
// update the count even if there's no input
if (sourceeof != 0)
return; // silently ignore lack of source file
selectinput (source);
selectoutput (listout);
for (;;) {
readsymbol (ch);
printsymbol (ch);
if ((ch == 10 || ch < 0))
break;
}
if (ch < 0)
sourceeof = 1;
selectinput (icode);
selectoutput (objout);
}
// -----------------------------------------------------------
// General descriptor and register manipulation routines
// -----------------------------------------------------------
// >> FLOATING <<
auto int floating (stackfm * v)
{
// check descriptor for floating point quantity
if ((v->type == real || v->type == lreal))
return (1);
return (0);
}
// >> ZERO <<
auto int zero (stackfm * v)
{
// CHECK DESCRIPTOR FOR (INTEGER) ZERO
if ((v->disp != 0 || (v->base != 0 || (v->form != constant && v->form != avins))))
return (0);
return (1);
}
// >> CONST <<
auto int _const_ (stackfm * v)
{
// CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
if (!(v->form == constant))
return (0);
if (v->type > byte)
return (0);
return (1);
}
auto int minrecordsize (stackfm * a, stackfm * b)
{
int n;
int m;
n = a->format;
if (n != 0)
n = &var[n]->size & 0x7FFF;
m = b->format;
if (m != 0)
m = &var[m]->size & 0x7FFF;
if ((n == 0 || (m != 0 && m < n)))
n = m;
if (n > 0)
return (n);
abort ("Min Rec Size");
}
// >> MULSHIFT <<
auto int mulshift (int n)
{
int shift;
int ref;
ref = 1;
for (shift = 1; shift <= 14; shift += 1) {
ref = ref << 1;
if (ref >= n) {
if (ref == n)
return (shift);
else
return ((-(1)));
}
}
return ((-(1)));
}
// >> SAME <<
auto int same (stackfm * v, stackfm * w)
{
// Test whether or not V and W describe the same object.
if ((v->disp != w->disp || v->base != w->base))
return (0);
if ((v->type != w->type || v->form != w->form))
return (0);
if ((v->extra != w->extra || v->scope != w->scope))
return (0);
return (1);
}
// grab a slab of working store in the local stack
auto int getwork (int size)
{
int cell;
cell = worklist[level];
while (cell != 0) {
if ((&gptags[cell]->info == size && &gptags[cell]->flags == 0)) {
// suitable candidate?
&gptags[cell]->flags = 1;
// mark it as in use
return (&gptags[cell]->addr);
}
cell = &gptags[cell]->link;
}
// no space available already - make more
cell = getgptag ();
frame = (frame - size) & ((~(align)));
// make them all even boundaries
&gptags[cell]->addr = frame;
&gptags[cell]->info = size;
&gptags[cell]->link = worklist[level];
worklist[level] = cell;
&gptags[cell]->flags = 1;
// in use
return (frame);
}
// Return a slab of working store to the free pool. Note that
// ReturnWork is cautious about what it accepts - it only takes
// in items it has previously given out, so we can call it
// fairly liberally with any old rubbish and it will do the
// right thing
auto void returnwork (int addr)
{
int cell;
cell = worklist[level];
while (cell != 0) {
if (&gptags[cell]->addr == addr) {
if (&gptags[cell]->flags == 0)
abort ("Return Work");
&gptags[cell]->flags = 0;
// mark it as free
return;
}
cell = &gptags[cell]->link;
}
// Here, work area was not found - it probably wasn't a work area!
}
// Check to see if a variable is in a work list assigned block. Used
// in string expression compilation to avoid un-necessary copying, hence
// only marked true for 256 byte chunks
auto int iswork (stackfm * v)
{
int cell;
if ((v->base != bp || (v->disp >= 0 || (v->scope != 0 || v->form != vins))))
return (0);
cell = worklist[level];
while (cell != 0) {
if (&gptags[cell]->addr == v->disp) {
if (&gptags[cell]->flags == 0)
abort ("Is Work");
if (&gptags[cell]->info != 256)
return (0);
return (1);
}
cell = &gptags[cell]->link;
}
return (0);
}
// >> RELEASE <<
auto void release (int reg)
{
// Hazard the value in a register
// abort("Release bad register") %if reg > fr7
if ((reg == 0 || (reg > fr7 || activity[reg] < 0)))
return; // LOCKED
activity[reg] = activity[reg] - 1;
if (activity[reg] < 0)
abort ("Release inactive");
claimed -= 1;
}
// >> CLAIM <<
auto void claim (int reg)
{
// Cherish the value in a register
if (reg > fr7)
abort ("Claim bad register");
if ((reg == 0 || activity[reg] < 0))
return;
activity[reg] = activity[reg] + 1;
claimed += 1;
}
// >> HAZARD <<
// Protect any value in register REG by storing in a temporary.
auto void hazard (int reg)
{
int i;
int n;
int t;
int type;
auto void mod (stackfm * v)
{
static void *sw[ /* bounds */ ] = { &&sw_default };
v->base = bp;
n -= 1;
goto *sw[v->form];
sw_ainrec: /* ainrec */
sw_avinrec: /* avinrec */
sw_vinrec: /* vinrec */
sw_constant: /* constant */
abort ("Mod");
sw_vins: /* vins */
if ((v->disp == 0 && v->scope == 0)) {
v->disp = t;
v->form = ains;
} else {
// change (X in S) to (X in REC)
v->form = v->form + 3;
v->extra = t;
}
goto out1;
sw_ains: /* ains */
sw_avins: /* avins */
v->form = v->form + 3;
v->extra = t;
goto out1;
// change (X in S) to (X in REC)
sw_vinr: /* vinr */
v->form = vins;
v->disp = t;
v->type = type;
goto out1;
out1:
}
n = activity[reg];
if (n <= 0)
return; // NOT IN USE OR CLAIMED
claimed -= n;
activity[reg] = 0;
if (reg >= fr0) {
// Note that the FPU can only save the top of the stack.
// If we need to save something lower down, we need to pop
// the things above me first...
if (reg - fr0 >= fpustack)
hazard (reg + 1);
// and recurse as required
type = lreal;
t = getwork (8);
dumpfloprm (fstq, bp, t, 0);
} else {
type = integer;
t = getwork (wordsize);
dumpmr (mov, bp, t, 0, reg);
}
for (i = 1; i <= stp; i += 1) {
if (&stack[i]->base == reg)
mod (&stack[i]);
}
if (n != 0)
abort ("Usage Outstanding");
// USE STILL OUTSTANDING
}
// >> HAZARD ALL <<
auto void hazardall (void)
{
int j;
if (claimed != 0) {
// at least one register claimed
for (j = ax; j <= fr7; j += 1)
hazard (j);
}
}
// >> GP REG <<
// Get a general (integer) register
// Note that registers AX, CX, DX, BX are, in order
// numbers 1, 2, 3 and 4 (which is convenient)
auto int gpreg (void)
{
int r;
// look for an empty one
for (r = ax; r <= bx; r += 1) {
if (activity[r] == 0)
return (r);
}
// look for an unlocked one
for (r = ax; r <= bx; r += 1) {
if (activity[r] > 0) {
hazard (r);
return (r);
}
}
abort ("Get Reg");
}
// >> PT REG <<
auto int ptreg (void)
{
// Get a register we can use as a pointer. We deliberately rotate
// around the candidates to make re-use more likely
const unsigned char ptpref[2 - 0 + 1];
// SI, DI, BX
static int next = 0;
int r;
int j;
// look for an empty one
for (j = 1; j <= 3; j += 1) {
r = ptpref[next];
next += 1;
if (next == 3)
next = 0;
if (activity[r] == 0)
return (r);
}
// look for an unlocked one
for (j = 1; j <= 3; j += 1) {
r = ptpref[j];
if (activity[r] > 0) {
hazard (r);
return (r);
}
}
abort ("Get PT Reg");
}
// >> GET DISPLAY <<
// return the register to use to access display level <n>
auto int getdisplay (int l)
{
int r;
int lev;
lev = l & 15;
// get rid of any relocation info
if (lev == 0)
return (l); // global
if (lev == level)
return (bp); // local
// We now try the 3 pointer register - they are not contiguously
// numbered, which is why this is unrolled!
if (displayhint[bx] == lev)
return (bx);
if (displayhint[si] == lev)
return (si);
if (displayhint[di] == lev)
return (di);
r = ptreg ();
dumprm (mov, r, bp, (-((lev * wordsize))), 0);
// displays are first words in frame
displayhint[r] = lev;
return (r);
}
// >> SET DOPE VECTOR <<
// Plants a dope vector for a 1-D constant bound array (usually
// OWN or CONST arrays) in the CONST segment, returns the offset
// Note that it also modifies the vlb and vub variables - after
// the call, VLB contains the byte offset for the first member
// and VUB contains the size to allocate for the array in bytes.
auto int setdopevector (void)
{
int t;
int dv;
t = vub - vlb + 1;
dv = getcot4 (1, vlb, vub, datasize);
vub = t * datasize;
vlb = vlb * datasize;
return (dv);
}
// >> PERM <<
// calls a PERM and adjusts the stack by SPACE words afterwards
auto void perm (int n, int space)
{
// PERM routines are written in MS C, and they preserve SI and DI,
// but trash the general purpose registers
hazard (ax);
hazard (cx);
hazard (dx);
hazard (bx);
// JDM perm routines now implemented as IMP routines
// so be more careful and hazard the SI,DI registers as well
hazard (si);
hazard (di);
dumpextcall (n);
if (space != 0)
dumpri (add, sp, space * wordsize);
}
// >> ASSEMBLE <<
// AMODE:
// -3: initial call
// -2: alternate record format
// -1: record format
// 0: begin block
// 1: procedure
// 2: %spec
auto void assemble (int amode, int labs, int names)
{
static void *c[ /* bounds */ ] = { &&c_default };
varfm *v;
// General purpose pointer
varfm *procvar;
// Var of the current procedure we're compiling
varfm *ap;
// Actual parameter ptr, used to copy parms to parm area
varfm *fp;
// formal parameter ptr, used to copy parms to parm area
stackfm *lhs;
// General stack pointer
stackfm *rhs;
// General stack pointers
int maxframe;
// Used for alternate records to find the largest alternate
int firstname;
// First descriptor at this level
int staticalloc;
// Tag used by pass 3 to fix up this level's stack allocation
int skipproc;
int lastskip;
// Used to jump around routines
int events;
int evep;
int evfrom;
// Event info (mask, entry point, block start)
int firstlabel;
// First label at this level
int oldframe;
// Previous level's static allocation
int j;
int t;
int dv;
auto void compiletostring (stackfm * v);
auto void loadreg (stackfm * v, int reg);
// JDM change name from load()
auto void storereg (stackfm * v, int reg);
// JDM new code
auto void assign (int assop);
auto void arrayref (int mode);
auto void operation (int n);
auto void compare (stackfm * l, stackfm * r);
auto void testzero (stackfm * v);
auto int newtag (void);
// Actual code for Assemble is down around label NEXT
// The following functions "parse" the parameters attached to an iCode instruction
// It is intended that these functions are the only places where the iCode stream is read
// >> READ TAG, and COMMA, INTEGER, REAL <<
auto int readtag (void)
{
int s1;
int s2;
s1 = pending;
readsymbol (s2);
readsymbol (pending);
return (s1 << 8 | s2);
}
auto int readtagcomma (void)
{
int t;
t = readtag ();
readsymbol (pending);
return (t);
}
auto int readinteger (void)
{
int s1;
int s2;
int s3;
int s4;
s1 = pending;
readsymbol (s2);
readsymbol (s3);
readsymbol (s4);
readsymbol (pending);
return ((s1 << 24) | (s2 << 16) | (s3 << 8) | s4);
}
auto int readbyte (void)
{
int s1;
s1 = pending;
readsymbol (pending);
return (s1);
}
// >> READ REAL <<
// Read a floating point literal. Pass 1 treats these as strings
// and leaves it up to us to make a floating point number out of it
// We therefore expect [COUNT]NNN.NNN@NN
auto double readreal (void)
{
int n;
double p;
double r;
n = readtagcomma ();
// char count, skip comma
r = 0;
// Start with the bit ahead of the decimal point
for (;;) {
sym = pending;
readsymbol (pending);
if (sym == '.')
break;
n -= 1;
if (sym == '@')
goto power;
r = r * 10 + (sym - '0');
if (n == 0)
goto sign;
}
p = 1;
for (;;) {
n -= 1;
if (n == 0)
goto sign;
sym = pending;
readsymbol (pending);
if (sym == '@')
goto power;
p = ((float) (p) / (float) (10));
r = r + (sym - '0') * p;
}
power:
n = readtag ();
// Tag is unsigned 16-bit integer (0..65535)
// but is read into a 32-bit signed integer
// and so 0 < n < 65535
// BUT - tag is to be regarded as a 16-bit signed integer
// So 0 < n < 32768 is to be regarded as a positive integer
// and 32767 < n < 65536 is a negative integer
// n => correct n
// 65536 => 0
// 65535 => -1 (65536 - n)
// 65534 => -2 (65536 - n)
// ..
// 32768 => -32768 (65536 - n)
// Now to tweak the floating point value. This method is
// somewhat clunky so that we can be portable to a system that
// doesn't do exponents
// This version of the pass2 code generator targets the 8087
// and later versions as the numeric processor for floating
// point arithmetic
// e.g. double real (== %longreal)
// Double real uses an 11-bit exponent so we should ensure
// that the tag represents an exponent in the range
// -1023 <= exp <= 1023
// -1024 is omitted to ensure no overflow for reciprocals
// The exponent however, has a bias of 1023 so the actual
// 8087 exponent is in the range 0 <= exp <= 2046
// Currently don't bother to check that the exponent is in
// the range -1023 < exp < 1023
if (n != 0) {
// ok, non-zero exponent
if ((0 < n && n < 32768)) {
// positive exponent
while (n > 0) {
r = r * 10;
n -= 1;
}
} else {
// a negative exponent
// So, convert to negative value
n -= 65536;
// Now, attempt to update the float value
while (n < 0) {
r = ((float) (r) / (float) (10));
n += 1;
}
}
}
sign:
// sign of whole value
if (pending == 'U') {
readsymbol (pending);
r = (-(r));
}
return (r);
}
auto char *readstring (void)
{
int j;
int sym;
int limit;
char s[255 + 1];
limit = sizeof (s) - 1;
strcpy (s, "");
for (j = pending; j <= 1; j += (-(1))) {
readsymbol (sym);
if (strlen (s) < limit)
strcat (s, tostring (sym));
}
readsymbol (pending);
return (s);
}
auto char *getascii (int terminator)
{
char a[255 + 1];
int sym;
strcpy (a, "");
for (;;) {
sym = pending;
readsymbol (pending);
if (sym == terminator)
break;
if (strlen (a) != 255) {
strcat (a, tostring (sym));
}
}
return (a);
}
// End of parsing routines
// >> DEFINE VAR <<
auto void definevar (int decl, char *internalid, int tf, int size, int scope)
{
int type;
int form;
int format;
int s;
int new;
int round;
int dimension;
int dv;
// dope vector offset
static int primno = 0;
new = 0;
round = align;
// Get the var index
if (decl == 0) {
// RECORD FORMAT ELEMENT NAME
parms -= 1;
if (parms <= names)
abort ("Def Var Parms");
decvar = &var[parms] /* Pointer assignment */ ;
decvar = 0;
} else {
if (decl >= parms)
abort (concat ("Def Var Names (decl=", concat (itos (decl, 0), concat (" parms=", concat (itos (parms, 0), ")")))));
decvar = &var[decl] /* Pointer assignment */ ;
if (decl > names) {
names = decl;
new = 1;
decvar = 0;
}
}
// Now parse the type and form word
type = tf >> 4;
form = tf & 15;
// Map external type numbers into internal equivalents,
// and adjust for short/byte/long things
if ((type == integer && size != 1)) {
// INTEGER
if (size == 2) {
type = byte;
round = 0;
}
size = vsize[type];
} else if (type == real) {
// REAL
if (size == 4)
type = lreal;
// LONG REAL
size = vsize[type];
} else if (type == record) {
// record
format = size;
decvar->format = format;
if (format <= names)
size = &var[format]->size;
} else if (type == string) {
// string
round = 0;
decvar->size = size;
size += 1;
} else {
size = vsize[type];
}
// JDM JDM remember the variable name
// Needed should an embedded code fragment refer to an IMP variable
&var[decl]->idname = internalid;
if (type != string)
decvar->size = size;
decvar->type = type;
decvar->form = form;
// Now analyse the Scope word
spec = (scope >> 3) & 1;
dimension = (scope >> 8) & 255;
otype = scope & 7;
if (otype != 0) {
// Set external linkage name if appropriate
if (otype >= external) {
if (strlen (alias) != 0) {
externalid = alias;
} else if (otype == system) {
externalid = concat (systemprefix, internalid);
} else {
externalid = concat ("_", internalid);
}
if (otype <= dynamic)
otype = external;
// external, system, dynamic
}
}
strcpy (alias, ""); // JDM: Ensure the external displacement is zero
decvar->extdisp = 0;
if ((switch <form && form < array)) {
// PROCEDURE
blocktype = 1 + spec;
// 1 for normal proc, 2 for spec
if ((otype != 0 && spec != 0)) {
// external spec
if (otype == primrt) {
primno += 1;
decvar->level = 128;
decvar->disp = primno;
return;
}
decvar->disp = externalref (externalid);
decvar->extdisp = decvar->disp;
// JDM: Remember the base external displacement
decvar->level = 0;
decvar->scope = ext;
return;
}
if (inparams == 0) {
// NOT A PARAMETER
potype = otype;
if (new != 0) {
// NEW NAME
decvar->disp = newtag ();
// Procedure ID
}
if (spec == 0)
blockname = internalid;
return;
}
otype = 0;
size = wordsize;
datasize = wordsize;
// procedure parameter
}
else {
// This is not a procedure declaration
datasize = size;
if (form != simple) {
round = align;
if (type == general) {
// General %name
decvar->extra = inparams;
// FOR LABELS
size = wordsize * 2;
} else if ((form == array || form == namearray)) {
// We will fill in dimensions and allocate space when
// we are told the bounds later
size = 0;
if (form == namearray)
datasize = wordsize;
} else if ((form == arrayname || form == namearrayname)) {
decvar->dim = dimension;
size = wordsize * 2;
round = align;
// array header
} else {
size = wordsize;
// integer (etc) %name
}
}
}
// Now deal with OWN (or const/extern/etc) data items
if (otype != 0) {
// OWN DATA
if (otype == con) {
// CONST INTEGER ETC.
if ((type == string && form == simple))
datasize = 0;
// use actual size for plain strings
if ((form == name || (form == arrayname || form == namearrayname))) {
otype = 0;
// Treat as special later
}
} else {
// OWN, not CONST
gfix (round);
// so make it even if needed
}
// set globals used by our data collection utilities
owntype = type;
ownform = form;
if (form == 2) {
owntype = integer;
datasize = wordsize;
} // %name's are really integers
if (spec == 0) {
if ((form == array || form == namearray)) {
gfix (align);
dv = setdopevector ();
// N.B. changes vlb, vub
// We treat OWN and CONST arrays identically - both are in data segment
gfix (align);
decvar->disp = datatp - vlb;
decvar->level = 0;
decvar->scope = data;
decvar->pbase = dv;
// save the dope vector pointer here
decvar->dim = 1;
// own arrays are always 1-D
}
if (otype == external)
fillexternal (data, decvar->disp, externalid);
} else {
decvar->level = 0;
decvar->scope = ext;
decvar->disp = externalref (externalid);
// JDM: We have a reference to external data so note the external ref id
// inside the _extdisp field
// _extdisp will NEVER be modified unlike _disp
// Eventually it will be used when generating ABSEXT ibj records
// The difference between _disp and _extdisp represents the offset
// from the location specified by _disp
// offset == _extdisp - _disp
decvar->extdisp = decvar->disp;
}
} else if (form == _label_) {
// %label
decvar->disp = newtag ();
} else if (form == switch) {
size = vub - vlb;
if (swtp + size > maxswitch)
abort ("Switch Table Full");
decvar->scope = swt;
decvar->disp = swtp - vlb;
decvar->extra = setdopevector ();
for (s = swtp; s <= swtp + size; s += 1) {
swtab[s] = 0;
// should really deal with undefined switch entries
}
swtp = swtp + size + 1;
}
else
if (form == recordformat) {
if (inparams != 0) {
if (decvar->size > frame)
frame = decvar->size;
} else {
blocktype = (-(1));
spec = (-(1));
}
} else {
// Here we've got an ordinary local variable, parameter or record entry
decvar->level = level;
if (inparams == 0) {
// local variable
frame = (frame - size) & ((~(round)));
decvar->disp = frame;
} else if (blocktype > 0) {
// procedure parameters
frame = (frame + size + align) & ((~(align)));
// parameters are always word aligned
decvar->disp = frame;
// offset will be adjusted at '}'
} else {
// records
frame = (frame + round) & ((~(round)));
decvar->disp = frame;
frame += size;
decvar->level = 0;
// no base register
}
}
}
// Define Var
// ---------------------------------------------------------------------
// Stack manipulation routines
// ---------------------------------------------------------------------
// >> POP STACK <<
// Pop the top of the stack
auto void popstack (void)
{
if (stp == 0)
abort ("Pop");
if (diagnose & 1 != 0)
monitor (top, "Pop");
stp -= 1;
if (stp != 0)
top = &stack[stp] /* Pointer assignment */ ;
else
top = (&null) /* Pointer assignment */ ;
}
// >> POP REL <<
// Pop the top of the stack, and release its' register
auto void poprel (void)
{
release (top->base);
popstack ();
}
const unsigned char fmap[15 - 0 + 1];
// >> STACK VAR <<
// Push a descriptor on the stack corresponding to Var "var no"
// We map the variable form to a stack form, and assign a register
// for the base if it is non local. Finally, we absorb the scope
// into the base register.
auto void stackvar (int varno)
{
varfm *w;
if (!((0 <= varno && varno <= maxvars)))
abort ("Stack Var Idx");
w = &var[varno] /* Pointer assignment */ ;
stp += 1;
if (stp > maxstack)
abort ("Push V Stack Overflow");
top = &stack[stp] /* Pointer assignment */ ;
top = 0;
// Translate "level" into "base register" - if it is non local
// we flag it by adding 16 to the desired level, which later will
// force us to pick up a pointer register
if (w->level != 0) {
if (w->level == level)
top->base = bp;
else
top->base = w->level + 16;
} else {
top->base = 0;
}
// AFORM contains the real original declared form, while
// FORM contains the on-the-stack subset of possible forms
top->idname = w->idname;
// JDM remember variable name
top->aform = w->form;
top->form = fmap[w->form];
top->dim = w->dim;
top->type = w->type;
top->disp = w->disp;
top->extdisp = w->disp;
top->scope = w->scope;
top->format = w->format;
top->size = w->size;
top->extra = w->extra;
top->pbase = w->pbase;
top->varno = varno;
if (diagnose & 1 != 0)
monitor (top, "Var stack");
}
// >> PUSH COPY <<
// Push a duplicate of a stack record onto the stack
auto void pushcopy (stackfm * v)
{
stp += 1;
if (stp > maxstack)
abort ("Stack Copy");
top = &stack[stp] /* Pointer assignment */ ;
top = v;
if (diagnose & 1 != 0)
monitor (top, "Stack Copy");
}
// >> PUSH CONST <<
// Push a constant on the stack
auto void pushconst (int n)
{
stp += 1;
if (stp > maxstack)
abort ("Stack Const");
top = &stack[stp] /* Pointer assignment */ ;
top = 0;
top->disp = n;
top->extdisp = 0;
top->type = integer;
top->form = constant;
if (diagnose & 1 != 0)
monitor (top, "push const");
}
// ---------------------------------------------------------------------
// STRING PROCESSING
// ---------------------------------------------------------------------
// >> INPUT STRING VALUE<<
// Read a string literal from the iCode stream
auto void inputstringvalue (char *s)
{
int i;
currentstring[0] = strlen (s);
for (i = 1; i <= strlen (s); i += 1) {
currentstring[i] = s ((i) - 1);
}
// if this is about to be used as a literal, put it straight into
// the CONST segment and stack it, otherwise leave it in curr string to see
// what comes next and stack a dummy zero
if ((pending != 'A' && pending != '$')) {
otype = con;
// anonymous %const
pushconst (getcots (currentstring));
top->type = string;
top->base = 0;
top->scope = cot;
top->form = vins;
top->format = currentstring[0] + 1;
} else {
pushconst (0);
// explicit string initialisation coming next
}
}
auto void getaliasvalue (char *s)
{
alias = s;
}
auto void inputrealvalue (double r)
{
if (r == 0) {
pushconst (0);
} else {
if (pending != 'A') {
otype = con;
// anonymous %const
pushconst (0);
top->type = lreal;
top->scope = cot;
top->disp = getcotdouble (r);
// N.B. ** %fn + side-effect **
top->extdisp = 0;
top->form = vins;
}
}
rvalue = r;
}
// -------------------------------------------------------
// LABEL PROCESSING
//
// Labels fixups are handled by pass 3 - we just plant
// numerical labels for code locations, and then jump to or call
// those labels. Pass 3 turns them into real locations.
// Unfortunately Pass 3 needs unique label numbers whereas
// Pass 1 produces lame local label numbers that can
// be reused once they've been defined. We therefore
// maintain an indirect database to map Pass 1 label numbers
// into unique tags
// >> NEW TAG <<
// Get the next consecutive Pass 3 label ID
auto int newtag (void)
{
static int freetag = 999;
freetag += 1;
return (freetag);
}
// >> NEW LABEL <<
// Get the next available label database index
auto int newlabel (void)
{
labs += 1;
if (labs > maxlabs)
abort ("Labels");
return (labs);
}
// >> FIND LABEL<<
// return the index in our label table of the Pass 1 label
auto int findlabel (int _label_)
{
int lp;
lp = labs;
while (lp != firstlabel) {
if (&labels[lp]->id == _label_)
return (lp);
lp -= 1;
}
return (0);
}
// >> DEFINE LABEL <<
// This label is "here"
auto void definelabel (int _label_)
{
int lp;
labelfm *l;
lp = findlabel (_label_);
if (lp == 0) {
// Not yet been used
lp = newlabel ();
l = &labels[lp] /* Pointer assignment */ ;
l->id = _label_;
l->tag = newtag ();
} else {
l = &labels[lp] /* Pointer assignment */ ;
if ((l->tag & 0x8000 != 0 && _label_ > 0))
l->tag = newtag ();
}
dumplabel (l->tag);
l->tag = l->tag | 0x8000;
uncondjump = 0;
// You can get here
}
// define label
// >> JUMP TO <<
// A wrapper for conditional jumps to labels that we're going
// to map into tags
auto void jumpto (int _label_, int op, int flag)
{
labelfm *l;
int lp;
lp = findlabel (_label_);
if (lp == 0) {
lp = newlabel ();
l = &labels[lp] /* Pointer assignment */ ;
l->id = _label_;
l->tag = newtag ();
} else {
l = &labels[lp] /* Pointer assignment */ ;
if ((flag != 0 && l->tag & 0x8000 != 0))
l->tag = newtag ();
}
// As a side effect, we also set the global J Tag, which is used
// in planting Event block information (a bit hacky, but a PSR feature)
jtag = l->tag & 0x7FFF;
dumpjump (op, jtag);
if (op == jmp)
uncondjump = nextcad;
}
// jump to
auto void jumpforward (int val, int test)
{
int opr;
// FF,TT tests need a value to compare
// TT == TRUE (#0)
// FF == FALSE (=0)
if ((test == ff || test == tt))
dumpri (cmp, ax, 0);
// Get the required operator for the test
// We may need to amend the choice of operator
// depending on the invert/compare unsign "flags"
opr = testtoop[test];
if (val == 0) {
if (lastskip != nextcad) {
skipproc = newtag ();
dumpjump (opr, skipproc);
}
} else {
// Check if we need to reverse the test
// So, re-choose the operator
if (invert != 0)
test = reverse[test];
invert = 0;
// convert the operators to unsigned versions if needed
if (compareunsign != 0)
opr = testtounsignedop[test];
else
opr = testtoop[test];
compareunsign = 0;
jumpto (val, opr, 1);
}
}
// Jump Forward
auto void jumpbackward (int val)
{
jumpto (val, jmp, 0);
}
// -------------------------------------------------------
// Stack variable transformations
// -------------------------------------------------------
// >> REDUCE <<
// Convert a variable which is addressed in a Rec into a simple variable
// by loading the indirect value into a register and changing the form
auto void reduce (stackfm * v)
{
int type;
int form;
int disp;
int scope;
int extdisp;
form = v->form - 3;
// X in REC => X in S
type = v->type;
disp = v->disp;
extdisp = v->extdisp;
// Here's a trick - we've got two displacements, DISP and EXTRA, but only
// one SCOPE hint. Which does it belong to? If the REC form came from
// a HAZARD then the scope belongs to the DISP, but for all other cases
// the scope belongs to the EXTRA. If we got here through HAZARD then
// the BASE will be BP - for all other cases it will be either a different
// register, or zero.
if (v->base == bp) {
scope = v->scope;
v->scope = 0;
} else {
scope = 0;
}
v->disp = v->extra;
v->type = integer;
v->form = vins;
loadreg (v, anyp);
v->type = type;
v->form = form;
v->disp = disp;
v->extdisp = extdisp;
v->scope = scope;
}
// >> AMAP <<
// convert V into a descriptor for the address of V
auto void amap (stackfm * v)
{
int f;
const int addrmap[15 - 0 + 1];
// ABD - should be code here to deal with ADDR(pgm label)
f = addrmap[v->form];
if (f < 0) {
monitor (v, "AMAP target");
abort ("AMAP");
}
// Try to simplify some forms...
if ((v->disp == 0 && v->scope == 0)) {
if (f == avins) {
if (v->base == 0)
f = constant;
else
f = vinr;
} else if ((f == vinrec || f == avinrec)) {
// eliminate redundant LOAD
if (f == vinrec)
f = ains;
else
f = vins;
v->disp = v->extra;
}
}
v->type = integer;
v->form = f;
}
// >> VMAP <<
// The inverse of AMAP: i.e. vmap(amap(x)) => x
auto void vmap (stackfm * v)
{
int f;
int t;
const int varmap[8 - 0 + 1];
if ((v->form == ains || v->form == ainrec)) {
t = v->type;
amap (v);
loadreg (v, anyp);
v->type = t;
v->form = vins;
}
f = varmap[v->form];
v->form = f;
if (f < 0)
abort ("VMap");
}
// v map
// >> ADDRESS <<
// convert V into a form in which it is directly addressable
// that means either V in R, V in S or Constant
auto void address (stackfm * v)
{
int type;
int form;
if (diagnose & 2 != 0)
monitor (v, "ADDRESS");
form = v->form;
type = v->type;
if (form >= vinrec) {
reduce (v);
form = v->form;
}
// Now pick up a base register if we needed one...
if (v->base > 16) {
v->base = getdisplay (v->base - 16);
claim (v->base);
}
if ((form == vinr || form == constant))
return;
if (form == avins) {
if (v->base == 0) {
v->form = constant;
} else {
if ((v->disp == 0 && v->scope == 0)) {
v->form = vinr;
} else {
loadreg (v, any);
}
}
return;
}
if (form == vins)
return;
if (form == ains) {
v->form = vins;
v->type = integer;
loadreg (v, anyp);
v->type = type;
v->form = vins;
v->disp = 0;
}
}
// address
// >> LOAD REG <<
// Load variable V into register R
// Along the way any register the variable owned is released, and
// the new register is claimed.
auto void loadreg (stackfm * v, int r)
{
static void *f[ /* bounds */ ] = { &&f_default };
int ptr;
int op;
if (diagnose & 2 != 0)
monitor (v, "LOAD");
if (r == anyf) {
// Equivalents for real numbers...
// because there's very little clever we can do, we first simplify somewhat...
address (v);
// Now it's either Constant, V in R or V in S - we now turn them
// all into V in S - the only thing we can load
// Start with one we have no instructions for, and promote it to
// something we know how to handle...
if (v->type == byte)
loadreg (v, any);
if (v->form == vinr) {
if (v->base >= fr0)
return; // This must be an integer in a CPU register - we need to store it
// before we can use it
v->disp = getwork (wordsize);
dumpmr (mov, bp, v->disp, v->extdisp, v->base);
release (v->base);
v->base = bp;
v->scope = 0;
v->form = vins;
// Now it looks like an integer V in S
}
if (v->form == constant) {
// This is an integer constant
if (v->disp == 0) {
// We have a special instruction for zero
r = fr0 + fpustack;
dumpflopspec (fldz);
v->base = r;
claim (r);
v->disp = 0;
v->form = vinr;
v->type = real;
return;
}
// Otherwise, we need it in store
v->disp = getcotw (v->disp);
v->form = vins;
v->base = 0;
v->scope = cot;
}
// Now everything that's left is a V in S
if (v->type == integer) {
op = fild;
} else {
if (v->type == real) {
op = fldd;
} else {
op = fldq;
}
}
// register is going to be the top of stack
r = fr0 + fpustack;
dumpfloprm (op, v->base | v->scope, v->disp, v->extdisp);
release (v->base);
v->base = r;
claim (r);
v->disp = 0;
v->form = vinr;
v->type = real;
return;
}
// If the request is one of the variations on "any" then we need
// to first allocate a target register. First, we make a local
// adjustment because we can't load bytes into "any" register,
// only into the GP registers...
if (v->type == byte) {
if (r == any)
r = anyg;
// What's more, there is only one register that is both a pointer
// and a legal byte destination
if (r == anyp)
r = bx;
}
// We also map the virtual display into a real register if we
// need to. Also, it is possible that an in-store form may
// be derived from a non-pointer register, so we fix that too.
if (v->base > 16) {
v->base = getdisplay (v->base - 16);
claim (v->base);
}
// Now go ahead and allocate a register
if (r == any) {
// If we've got a base,
// it's not in use by anyone else,
// and isn't a display register,
// then use it
if ((v->base != 0 && (activity[v->base] == 1 && displayhint[v->base] == 0))) {
r = v->base;
} else {
r = gpreg ();
}
} else {
if (r == anyg) {
if ((0 < v->base && (v->base <= bx && activity[v->base] == 1))) {
r = v->base;
} else {
r = gpreg ();
}
} else {
if (r == anyp) {
if ((activity[v->base] == 1 && (v->base == bx || (v->base == si || v->base == di)))) {
r = v->base;
} else {
r = ptreg ();
}
} else {
if (v->base == r) {
if (activity[r] > 1) {
// protect other uses
release (r);
v->base = 0;
// Hide my ownership for the moment
hazard (r);
// Zap everybody else
claim (r);
v->base = r;
// Get it back
}
} else {
hazard (r);
}
}
}
}
goto *f[v->form];
f_vinrec: /* vinrec */
reduce (v);
goto *f[v->form];
f_avinrec: /* avinrec */
reduce (v);
goto *f[v->form];
f_ainrec: /* ainrec */
reduce (v);
goto *f[v->form];
f_avinr: /* avinr */
abort ("Unexpected Stack Form");
f_ainr: /* ainr */
abort ("Unexpected Stack Form");
f_constant: /* constant */
if ((v->disp == 0 && v->scope == 0)) {
dumprr (xor, r, r);
} else {
dumprioffset (mov, r, v->scope, v->disp, v->extdisp);
}
v->base = r;
v->disp = 0;
v->scope = 0;
v->form = vinr;
claim (r);
return;
f_vinr: /* vinr */
if (v->base == r)
return;
dumprr (mov, r, v->base);
release (v->base);
v->base = r;
v->disp = 0;
v->scope = 0;
v->form = vinr;
claim (r);
return;
f_ains: /* ains */
// is the register a pointer?
if ((r == bx || (r == si || r == di))) {
ptr = r;
} else {
ptr = ptreg ();
}
dumprm (mov, ptr, v->base | v->scope, v->disp, v->extdisp);
release (v->base);
claim (ptr);
v->base = ptr;
v->disp = 0;
v->scope = 0;
if (v->type == integer) {
dumprm (mov, r, v->base | v->scope, v->disp, v->extdisp);
} else {
if (v->type == byte) {
// watch out for register re-use here...
if (r != v->base)
dumprr (xor, r, r);
// clear it, but only if it isn't needed
dumprm8 (mov, r + 16, v->base | v->scope, v->disp, v->extdisp);
if (r == v->base)
dumpri (and, r, 255);
// otherwise a more expensive clear later
v->type = integer;
} else {
// reals
abort ("Load Real");
}
}
release (v->base);
v->base = r;
v->disp = 0;
v->scope = 0;
v->form = vinr;
claim (r);
return;
f_vins: /* vins */
if (v->type == integer) {
dumprm (mov, r, v->base | v->scope, v->disp, v->extdisp);
} else {
if (v->type == byte) {
// watch out for register re-use here...
if (r != v->base)
dumprr (xor, r, r);
// clear it, but only if it isn't needed
dumprm8 (mov, r + 16, v->base | v->scope, v->disp, v->extdisp);
if (r == v->base)
dumpri (and, r, 255);
// otherwise a more expensive clear later
v->type = integer;
} else {
// reals
abort ("Load Real");
}
}
release (v->base);
v->base = r;
v->disp = 0;
v->scope = 0;
v->form = vinr;
claim (r);
return;
f_avins: /* avins */
if (v->base != 0) {
dumprm (lea, r, v->base | v->scope, v->disp, v->extdisp);
release (v->base);
v->type = integer;
} else {
// else
if ((v->disp == 0 && v->scope == 0)) {
dumprr (xor, r, r);
} else {
dumprioffset (mov, r, v->scope, v->disp, v->extdisp);
}
}
v->base = r;
v->disp = 0;
v->scope = 0;
v->form = vinr;
claim (r);
return;
}
// LOAD REG
// JDM JDM Adapted from Store routine in Assign
// Store the register item reg in location given by LHS stackfm.
// This only deals with the integer registers.
// Store Reg does NOT cater for floating point registers.
// The destination can be one of:
// 1) Integer
// 2) Byte
// 3) Name/Pointer
auto void storereg (stackfm * lhs, int reg)
{
if (lhs->base == sp) {
// it's a push
if ((lhs->type == integer || lhs->type == byte)) {
dumpur (push, reg);
}
} else if (lhs->type == integer) {
dumpmr (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, reg);
} else if (lhs->type == byte) {
dumpmr8 (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, reg + 16);
} else if (lhs->type == record) {
dumpmr (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, reg);
}
}
// STORE REG
// >> OPERATION <<
// perform the operation OP on the top two elements of the stack.
// (single element for unary operators)
auto void operation (int op)
{
stackfm *lhs;
stackfm *rhs;
int assignpending;
int work;
int value;
int s;
static void *oper[ /* bounds */ ] = { &&oper_default };
const int opmap[17 - 1 + 1];
const int flopmap[17 - 1 + 1];
const int indec[1 - (-(1)) + 1];
// decrement, and increment opcodes
auto void swap (void)
{
stackfm temp;
(&temp) = lhs;
lhs = rhs;
rhs = (&temp);
}
assignpending = 0;
rhs = top /* Pointer assignment */ ;
if (op < unaries) {
lhs = &stack[stp - 1] /* Pointer assignment */ ;
if ((lhs->type == real || (lhs->type == lreal || op >= rexpx)))
goto reals;
}
if ((rhs->type == real || rhs->type == lreal))
goto reals;
if ((rhs->form == constant && (op >= unaries || lhs->form == constant)))
goto *fold[op];
// now look for optimisations for x = x <op> whatever
if ((pending == 'S' || pending == 'j')) {
// the next task is an assignment
if (op >= unaries) {
if (same (top, &stack[stp - 1]) != 0)
assignpending = 1;
} else {
if (same (lhs, &stack[stp - 2]) != 0)
assignpending = 1;
}
}
goto *oper[op];
oper_notx: /* notx */
oper_negx: /* negx */
// we optimise for e.g. fred = -fred as one instruction
if (assignpending != 0) {
readsymbol (pending);
address (rhs);
if (rhs->type == byte) {
dumpum8 (opmap[op], rhs->base | rhs->scope, rhs->disp, rhs->extdisp);
} else {
dumpum (opmap[op], rhs->base | rhs->scope, rhs->disp, rhs->extdisp);
}
poprel ();
poprel ();
return;
}
loadreg (rhs, any);
dumpur (opmap[op], rhs->base);
return; // 8086 has no "abs" instructions, so we do a test and jump
oper_absx: /* absx */
loadreg (rhs, any);
dumpri (cmp, rhs->base, 0);
work = newtag ();
dumpjump (jge, work);
dumpur (neg, rhs->base);
dumplabel (work);
return;
oper_addx: /* addx */
if (lhs->form == constant)
swap ();
// and fall through to minus
oper_subx: /* subx */
// First look for fred = fred + <whatever>
// We can only safely do this for bytes if we're jamming or ignoring overflow
if ((assignpending != 0 && (lhs->type == integer || ((control & checkcapacity) == 0 || pending == 'j')))) {
readsymbol (pending);
// we will do the assignment ourselves
address (lhs);
// make LHS accessible
if (rhs->form == constant) {
value = rhs->disp;
if (value != 0) {
if (op == subx)
value = (-(value));
// look for increment or decrement instructions
if ((value < 2 && value > (-(2)))) {
if (lhs->type == byte) {
dumpum8 (indec[value], lhs->base | lhs->scope, lhs->disp, lhs->extdisp);
} else {
dumpum (indec[value], lhs->base | lhs->scope, lhs->disp, lhs->extdisp);
}
} else {
if (lhs->type == byte) {
dumpmi8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
} else {
dumpmi (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
}
}
}
} else {
// RHS not a constant
loadreg (rhs, any);
if (lhs->type == byte) {
dumpmr8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base + 16);
} else {
dumpmr (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base);
}
}
poprel ();
poprel ();
poprel ();
return;
}
// So, there is no assign pending
if (rhs->form == constant) {
value = rhs->disp;
if (op == subx)
value = (-(value));
// If it is already an address, do the math on the address offset
if ((lhs->form == avins || lhs->form == avinrec)) {
lhs->disp = lhs->disp + value;
} else {
loadreg (lhs, any);
// We don't particulary try for it, but if we ended up with a pointer
// register, we might as well convert this to use the address form...
if (lhs->base == bx) {
// BX is the only GP reg that's also a pointer
lhs->form = avins;
lhs->disp = value;
} else {
// otherwise, don't bother deferring the operation
// look for increment or decrement instructions
if ((value < 2 && value > (-(2)))) {
if (value != 0)
dumpur (indec[value], lhs->base);
} else {
dumpri (opmap[op], lhs->base, rhs->disp);
}
}
}
} else {
// not a constant
if ((op == addx && rhs->form == vinr))
swap ();
// commutative, so flip it
loadreg (lhs, any);
if (rhs->type == byte) {
loadreg (rhs, any);
} else {
address (rhs);
}
dumprv (opmap[op], lhs->base, rhs);
}
poprel ();
// the RHS
return;
oper_andx: /* andx */
oper_orx: /* orx */
oper_xorx: /* xorx */
// Logical ops are a subset of ADD - similar behaviour, but no inc/dec/addr short forms
if (lhs->form == constant)
swap ();
// First look for fred = fred <op> <whatever>
if (assignpending != 0) {
readsymbol (pending);
// we will do the assignment ourselves
address (lhs);
// make LHS accessible
if (rhs->form == constant) {
value = rhs->disp;
if (lhs->type == byte) {
if (rhs->disp & ((~(255))) != 0)
warn (8);
dumpmi8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
} else {
dumpmi (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
}
} else {
// RHS not a constant
loadreg (rhs, any);
if (lhs->type == byte) {
dumpmr8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base + 16);
} else {
dumpmr (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base);
}
}
poprel ();
// RHS
poprel ();
// LHS
poprel ();
// Assignment destination
return;
}
// So, there is no assign pending
if (rhs->form == constant) {
value = rhs->disp;
loadreg (lhs, any);
dumpri (opmap[op], lhs->base, value);
} else {
// not a constant
if (rhs->form == vinr)
swap ();
// all these are commutative, so flip it to make it easier
loadreg (lhs, any);
if ((rhs->type == byte && op == andx)) {
// AND needs all the bits to make sense
loadreg (rhs, any);
// NB Load changes type to Integer
} else {
address (rhs);
}
if (rhs->type == byte) {
// must be V in S - everything else would be Integer
dumprm8 (opmap[op], lhs->base + 16, rhs->scope | rhs->base, rhs->disp, rhs->extdisp);
} else {
dumprv (opmap[op], lhs->base, rhs);
}
}
poprel ();
// the RHS
return;
oper_mulx: /* mulx */
if ((lhs->form == constant || rhs->base == ax))
swap ();
if (rhs->form == constant) {
value = rhs->disp;
if (value == 0) {
// mul by zero is zero
release (lhs->base);
lhs = rhs;
popstack ();
return;
}
if (value == 1) {
// mul by 1 is the identity
popstack ();
return;
}
s = mulshift (value);
// find a shift factor
if (s > 0) {
rhs->disp = s;
op = lshx;
goto shiftit;
}
// 8086 multiply instruction doesn't have an immediate operand form
// so we use an entry in the constant table...
rhs->base = 0;
rhs->scope = cot;
rhs->disp = getcotw (value);
rhs->form = vins;
// and fall through to the not-a-constant path
}
domul:
loadreg (lhs, ax);
address (rhs);
hazard (dx);
if (rhs->form == vinr) {
dumpur (imul, rhs->base);
} else {
dumpum (imul, rhs->base | rhs->scope, rhs->disp, rhs->extdisp);
}
poprel ();
return;
oper_divx: /* divx */
oper_remx: /* remx */
loadreg (lhs, ax);
address (rhs);
hazard (dx);
dumpsimple (cwd);
// Plain 8086 Divide instruction also has no immediate operand form, so
// we move constants to the COT
if (rhs->form == constant) {
if (rhs->disp == 0)
warn (1);
rhs->base = 0;
rhs->scope = cot;
rhs->disp = getcotw (rhs->disp);
rhs->form = vins;
}
if (rhs->form == vinr) {
dumpur (idiv, rhs->base);
} else {
dumpum (idiv, rhs->base | rhs->scope, rhs->disp, rhs->extdisp);
}
poprel ();
if (op == divx) {
lhs->base = ax;
} else {
lhs->base = dx;
release (ax);
claim (dx);
}
return;
oper_lshx: /* lshx */
oper_rshx: /* rshx */
shiftit:
if ((assignpending != 0 && (op == rshx || (lhs->type == integer || (control & checkcapacity == 0 || pending == 'j'))))) {
readsymbol (pending);
// we will do the assignment ourselves
address (lhs);
// make LHS accessible
if (rhs->form == constant) {
if (!((0 <= rhs->disp && rhs->disp <= 31)))
warn (6);
if (rhs->disp != 0) {
// shift by zero is a no-op
if (lhs->type == byte) {
dumpmi8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
} else {
dumpmi (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
}
}
} else {
// RHS not a constant
// Since the shift instruction only uses the bottom 5 bits of the
// value in CX, the value is "byte safe". Rather than do a full
// "loadreg(rhs,CX)" we therefore fiddle about and do it the hard way
// to save redundant coding
if (rhs->type == byte) {
hazard (cx);
address (rhs);
dumprm8 (mov, cl, rhs->scope | rhs->base, rhs->disp, rhs->extdisp);
} else {
loadreg (rhs, cx);
}
if (lhs->type == byte) {
dumpmr8 (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, cl);
} else {
dumpmr (opmap[op], lhs->base | lhs->scope, lhs->disp, lhs->extdisp, cx);
}
}
poprel ();
// RHS
poprel ();
// LHS
poprel ();
// Assignment destination
return;
}
// deal with constant shifts first...
if (rhs->form == constant) {
value = rhs->disp;
if (!((0 <= value && value <= 31)))
warn (6);
if (value != 0) {
loadreg (lhs, any);
dumpri (opmap[op], lhs->base, value);
}
} else {
// RHS variable
// Since the shift instruction only uses the bottom 4 bits of the
// value in CX, the value is "byte safe". Rather than do a full
// "loadreg(rhs,CX)" we therefore fiddle about and do it the hard way
// to save redundant coding
if (rhs->type == byte) {
hazard (cx);
address (rhs);
dumprm8 (mov, cl, rhs->scope | rhs->base, rhs->disp, rhs->extdisp);
release (rhs->base);
rhs->base = cx;
claim (cx);
} else {
loadreg (rhs, cx);
}
loadreg (lhs, any);
dumprr (opmap[op], lhs->base, cx);
}
poprel ();
return;
oper_expx: /* expx */
if (rhs->form == constant) {
if (rhs->disp == 0) {
poprel ();
poprel ();
pushconst (1);
return;
}
if (rhs->disp == 1) {
poprel ();
return;
}
if (rhs->disp == 2) {
rhs = lhs;
claim (rhs->base);
goto domul;
}
}
loadreg (rhs, any);
dumpur (push, rhs->base);
poprel ();
loadreg (lhs, any);
dumpur (push, lhs->base);
release (lhs->base);
perm (iexp, 2);
lhs->base = ax;
claim (ax);
lhs->form = vinr;
return;
oper_rexpx: /* rexpx */
oper_rdivx: /* rdivx */
abort ("Oper unexpected op");
// -----------------------------------------------
// Fold constant expressions at compile time
fold_negx: /* negx */
value = (-(rhs->disp));
goto setunary;
fold_notx: /* notx */
value = (~(rhs->disp));
goto setunary;
fold_absx: /* absx */
value = rhs->disp;
if (value < 0)
value = (-(value));
goto setvalue;
fold_addx: /* addx */
value = lhs->disp + rhs->disp;
goto setvalue;
fold_subx: /* subx */
value = lhs->disp - rhs->disp;
goto setvalue;
fold_orx: /* orx */
value = lhs->disp | rhs->disp;
goto setvalue;
fold_andx: /* andx */
value = lhs->disp & rhs->disp;
goto setvalue;
fold_xorx: /* xorx */
value = lhs->disp ^ rhs->disp;
goto setvalue;
fold_lshx: /* lshx */
value = lhs->disp << rhs->disp;
goto setvalue;
fold_mulx: /* mulx */
value = lhs->disp * rhs->disp;
goto setvalue;
fold_rshx: /* rshx */
value = lhs->disp >> rhs->disp;
goto setvalue;
fold_expx: /* expx */
if (rhs->disp < 0)
abort ("Fold -ve Exp");
value = 1;
for (op = 1; op <= rhs->disp; op += 1) {
value = value * lhs->disp;
}
goto setvalue;
fold_remx: /* remx */
fold_divx: /* divx */
value = rhs->disp;
if (value == 0) {
warn (1);
value = 1;
}
value = ((int) (lhs->disp) / (int) (value));
if (op == divx)
goto setvalue;
value = lhs->disp - (rhs->disp * value);
goto setvalue;
fold_rexpx: /* rexpx */
abort ("Fold REXPx - Not implemented");
fold_rdivx: /* rdivx */
abort ("Fold RDIVx - Not implemented");
setvalue:
popstack ();
setunary:
top->disp = value;
return;
fold_concx: /* concx */
abort ("Fold CONCx - Not implemented");
// --------------------------------------------------------------------
// String operations - the only one is concatenate...
oper_concx: /* concx */
if (assignpending != 0) {
// It's S = S.T
amap (lhs);
loadreg (lhs, any);
dumpur (push, lhs->base);
amap (rhs);
loadreg (rhs, any);
dumpur (push, rhs->base);
poprel ();
poprel ();
dumppushi (0, lhs->size, 0);
if (pending == 'S')
perm (sconc, 3);
else
perm (sjconc, 3);
// and finally, skip the pending assignment, and drop the LHS
readsymbol (pending);
poprel ();
return;
}
// here we've got T.U - if T is already in a WORK location
// we've got a simple append. If it is a user variable, we've
// got to both copy it to a temp area and do the append
if (iswork (lhs) == 0) {
// Not a work area
work = getwork (256);
pushconst (work);
top->form = avins;
top->base = bp;
loadreg (top, any);
dumpur (push, top->base);
poprel ();
amap (lhs);
loadreg (lhs, any);
dumpur (push, lhs->base);
release (lhs->base);
dumppushi (0, 255, 0);
perm (smove, 3);
// Now we need to redefine the LHS as our temporary area
lhs = 0;
// gratuitous clear-it-all-out
lhs->type = string;
lhs->form = vins;
lhs->base = bp;
lhs->disp = work;
lhs->size = 255;
}
// Here we are doing an in-situ concatenation
// We want to leave the result as a normal variable, so we
// suck up a copy for the AMAP fiddling
pushcopy (lhs);
amap (top);
loadreg (top, any);
dumpur (push, top->base);
poprel ();
amap (rhs);
loadreg (rhs, any);
dumpur (push, rhs->base);
poprel ();
dumppushi (0, lhs->size, 0);
perm (sconc, 3);
return;
reals:
if (op < unaries)
loadreg (lhs, anyf);
if (op != rexpx)
loadreg (rhs, anyf);
goto *roper[op];
roper_negx: /* negx */
roper_absx: /* absx */
dumpfloprr (flopmap[op], rhs->base, rhs->base);
return;
roper_addx: /* addx */
roper_mulx: /* mulx */
// Commutative, so we don't care
if (lhs->base > rhs->base)
swap ();
dumpfloprr (flopmap[op], lhs->base, rhs->base);
poprel ();
return;
roper_subx: /* subx */
roper_divx: /* divx */
roper_rdivx: /* rdivx */
// We can't swap these, so we use the reverse form of
// the opcode (which in our internal form is always one
// more than the basic opcode index)
op = flopmap[op];
if (lhs->base > rhs->base) {
swap ();
op += 1;
}
dumpfloprr (op, lhs->base, rhs->base);
poprel ();
return;
roper_rexpx: /* rexpx */
// This is implemented as a PERM routine
loadreg (rhs, any);
dumpur (push, rhs->base);
poprel ();
// The usual slightly clunky floating point "push"
work = ptreg ();
dumpri (sub, sp, 8);
dumprr (mov, work, sp);
dumpfloprm (fstq, work, 0, 0);
release (lhs->base);
perm (fexp, 1 + (((int) (8) / (int) (wordsize))));
// Since rexp is actually a standard C routine, the result will
// be on the FPU stack
lhs->base = fr0;
claim (fr0);
fpustack = 1;
lhs->form = vinr;
lhs->type = lreal;
return;
roper_notx: /* notx */
abort ("NOTx: Unsupported Real Operation");
roper_andx: /* andx */
abort ("ANDx: Unsupported Real Operation");
roper_orx: /* orx */
abort ("ORx: Unsupported Real Operation");
roper_xorx: /* xorx */
abort ("XORx: Unsupported Real Operation");
roper_remx: /* remx */
abort ("REMx: Unsupported Real Operation");
roper_lshx: /* lshx */
abort ("LSHx: Unsupported Real Operation");
roper_rshx: /* rshx */
abort ("RSHx: Unsupported Real Operation");
roper_expx: /* expx */
abort ("EXPx: Unsupported Real Operation");
}
// Operation
// >> ASSIGN <<
// ASSOP = -1: parameter assignment
// 0: == assignment
// 1: = assignment
// 2: <- assignment
auto void assign (int assop)
{
stackfm *lh;
stackfm *rh;
stackfm (&temp);
int n;
int p;
int form;
int r;
// Store the item in RHS to LHS. Encapsulates the dificulties
// of variable length items and pushing things on the stack to
// keep the rest of "Assign" looking tidy
auto void store (stackfm * lhs, stackfm * rhs)
{
int pt;
int s;
int op;
if (lhs->base == sp) {
// it's a push
if ((lhs->type == integer || lhs->type == byte)) {
if (rhs->type == byte) {
loadreg (rhs, any);
} else {
address (rhs);
}
dumpvpush (rhs);
} else {
// must be a real
if (lhs->type == real) {
s = 4;
op = fstd;
} else {
s = 8;
op = fstq;
}
loadreg (rhs, anyf);
pt = ptreg ();
dumpri (sub, sp, s);
dumprr (mov, pt, sp);
dumpfloprm (op, pt, 0, 0);
}
return;
}
if (lhs->type == integer) {
if ((rhs->form == constant && rhs->scope == 0)) {
dumpmi (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
} else {
loadreg (rhs, any);
dumpmr (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base);
}
} else {
if (lhs->type == byte) {
if ((rhs->form == constant && rhs->scope == 0)) {
dumpmi8 (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->disp);
} else {
if (rhs->type == byte) {
// try to avoid pointless promoting to an int
// We will reproduce a "Load" but without the word extension
address (rhs);
pt = gpreg ();
dumprm8 (mov, pt + 16, rhs->base | rhs->scope, rhs->disp, rhs->extdisp);
release (rhs->base);
rhs->base = pt;
rhs->form = vinr;
rhs->type = integer;
claim (pt);
} else {
loadreg (rhs, any);
// ABD - should add a capacity check here
}
dumpmr8 (mov, lhs->base | lhs->scope, lhs->disp, lhs->extdisp, rhs->base + 16);
}
} else {
loadreg (rhs, anyf);
if (lhs->type == real) {
op = fstd;
} else {
// long real
op = fstq;
}
dumpfloprm (op, lhs->base | lhs->scope, lhs->disp, lhs->extdisp);
}
}
}
if (stp < 2)
abort ("Assign Stack");
rh = top /* Pointer assignment */ ;
lh = &stack[stp - 1] /* Pointer assignment */ ;
form = lh->form;
// to avoid the ravages of amap, load etc
if (diagnose & 4 != 0) {
monitor (lh, "ASS LH");
monitor (rh, "ASS RH");
}
if (same (lh, rh) != 0) {
poprel ();
poprel ();
return;
}
if (assop < 0) {
// Parameter
if (lh->base >= 128) {
// Special - prim routine
(&temp) = lh;
lh = rh;
rh = (&temp);
return;
}
// Extract the next formal parameter and make it our target
lh->pbase = lh->pbase - 1;
stackvar (lh->pbase);
// Now make our destination look reasonable
lh = top /* Pointer assignment */ ;
lh->base = sp;
// target is the stack
if (lh->form != vins)
assop = 0;
// %name parameter is '=='
// We need special treatment for procedure parameters
if ((7 <= lh->aform && lh->aform <= 10)) {
// this is a procedure
assop = 1;
// we will treat it as a value assignment
rh->type = integer;
// of an integer
lh->type = integer;
lh->form = vins;
if (rh->base != 0) {
// RH is already a parameter
rh->form = vins;
} else {
if (rh->scope == ext) {
// it is an external procedure
rh->form = avins;
// pick up the addres
} else {
// it is a local procedure
// HACK: local procedures are Tags until Pass3 fixes them up. The
// only way we have of converting tags to addresses is with the switch
// table - so we'll plant a fake switch entry for the label of the
// local routine, and then load that value!
if (swtp >= maxswitch)
abort ("Proc - Switch Table Full");
swtab[swtp] = rh->disp;
rh->disp = swtp * wordsize;
swtp += 1;
rh->scope = swt;
rh->form = vins;
}
}
}
}
if ((array <= rh->aform && rh->aform <= namearrayname)) {
// Arrayname
// An array name is two words - a pointer to the data and a
// pointer to the dope vector. If the RHS is already one of these
// then we just want to copy the two words. If it is a static
// array, we need to map the data to make a pointer, and its' dope
// vector will be in the constant table, so we fetch that.
amap (lh);
address (lh);
amap (rh);
// This works because arrays are stacked as V in S, arraynames are A in S
address (rh);
// We do the dope vector first - that makes it easier when we're parameter passing
if ((rh->aform == array || rh->aform == namearray)) {
// simple static - DV in COT
// We will rustle up a dummy record for the DV address
(&temp) = 0;
(&temp)->form = avins;
(&temp)->type = integer;
(&temp)->disp = rh->pbase;
(&temp)->scope = cot;
} else {
// already an array name
(&temp) = rh;
claim ((&temp)->base);
(&temp)->disp = (&temp)->disp + wordsize;
}
lh->disp = lh->disp + wordsize;
store (lh, (&temp));
release ((&temp)->base);
lh->disp = lh->disp - wordsize;
store (lh, rh);
poprel ();
poprel ();
return;
}
if (lh->type == general) {
// general %name parameter
if (!(assop == 0))
abort ("Assign GenName");
// Only '==' is allowed
// A general name pointer is two words - the pointer itself
// and a second word to convey type information. If the RHS
// is already one of thse guys it's easy - just copy the two
// words. Otherwise, we need to rustle up the second word at
// compile time.
amap (lh);
address (lh);
if (rh->type == general) {
(&temp) = rh;
// make a copy for the second word
claim ((&temp)->base);
(&temp)->disp = (&temp)->disp + wordsize;
amap ((&temp));
} else {
(&temp) = 0;
(&temp)->type = integer;
(&temp)->disp = (rh->size << 4) + genmap[rh->type];
}
// We do the words backwards, so that parameter push works
lh->disp = lh->disp + wordsize;
store (lh, (&temp));
release ((&temp)->base);
lh->disp = lh->disp - wordsize;
amap (rh);
store (lh, rh);
poprel ();
poprel ();
return;
}
if (assop == 0) {
// ==
amap (lh);
// destination
amap (rh);
// ABD %string(*)%name NOT handled special here - should be?
}
if (lh->type == record) {
if (lh->base == sp) {
// pass record by value - destination is the stack
n = lh->size;
hazard (di);
dumpri (sub, sp, lh->size);
dumprr (mov, di, sp);
claim (di);
lh->base = di;
} else {
n = minrecordsize (lh, rh);
amap (lh);
loadreg (lh, di);
}
hazard (cx);
dumpri (mov, cx, n);
if (rh->form == constant) {
hazard (ax);
dumprr (xor, ax, ax);
// get a zero
dumprepstosb ();
} else {
amap (rh);
loadreg (rh, si);
dumprepmovsb ();
}
poprel ();
poprel ();
return;
}
if (lh->type == string) {
if ((assop > 0 && rh->format == 1)) {
// null string as zero byte ?
lh->type = byte;
poprel ();
// zap current RHS
pushconst (0);
// get a zero
assign (assop);
// and assign it
return;
}
// our copy routines expect DEST then SOURCE then LENGTH on the stack
if (lh->base == sp) {
// pass string by value - destination is the stack
// space is string size, plus one for length, plus make it even
p = lh->size + 1;
p = (p + align) & ((~(align)));
dumpri (sub, sp, p);
// we want to Push SP here - sadly different versions of x86
// architecture have different interpretations of "PUSH SP", so...
r = gpreg ();
dumprr (mov, r, sp);
dumpur (push, r);
} else {
amap (lh);
loadreg (lh, any);
dumpur (push, lh->base);
}
// It is likely that the RH variable is a temporary work area
// Before we trash the information, we try to release it
returnwork (rh->disp);
amap (rh);
loadreg (rh, any);
dumpur (push, rh->base);
poprel ();
poprel ();
dumppushi (0, lh->size, 0);
if (assop == 2)
perm (sjam, 3);
else
perm (smove, 3);
return;
}
address (lh);
store (lh, rh);
poprel ();
poprel ();
}
// assign
// >> ARRAY REF <<
// Array references always use the PERM
// unless they are 1 dimensional,
// AND the %control bit has been turned off
auto void arrayref (int mode)
{
stackfm *av;
int type;
int form;
int size;
int format;
if (mode != 0) {
// Put non-terminal index onto stack for PERM
if (top->type == byte) {
loadreg (top, any);
} else {
address (top);
}
dumpvpush (top);
poprel ();
return;
}
av = &stack[stp - 1] /* Pointer assignment */ ;
size = av->size;
if (av->type == string)
size += 1;
form = av->aform;
if ((form == namearray || form == namearrayname))
size = wordsize;
if ((control & checkarray == 0 && av->dim == 1)) {
// This will be unchecked, the top of the stack is the only index (1D),
// so we can do a cheap multiplication here
if (size != 1) {
// multiply offset by var size
pushconst (size);
operation (mulx);
}
} else {
// This is the final (and perhaps only) subscript for a checked array,
// so we are going to use the Perm - therefore pass this as a parameter
if (top->type == byte) {
loadreg (top, any);
} else {
address (top);
}
dumpvpush (top);
poprel ();
}
// How we do the rest of the access depends on whether this is a simple
// static array, or an array name...
if ((form == arrayname || form == namearrayname)) {
// array is a "name"
// We will AMAP the name, so we remember the info and then put it all back later
type = av->type;
format = av->format;
size = av->size;
if (form == arrayname)
form = vins;
else
form = ains;
amap (av);
if ((control & checkarray != 0 || av->dim > 1)) {
// do the rest of the check
// This is a bit clunky, because we may load registers in order
// to access AV, only to Hazard them for the PERM
address (av);
pushcopy (av);
claim (top->base);
top->disp = top->disp + wordsize;
// Dope Vector address follows A(0)
dumpvpush (top);
poprel ();
perm (aref, av->dim + 1);
// DV word, plus a word for every subscript
pushconst (0);
top->form = vinr;
top->base = ax;
claim (ax);
}
loadreg (top, anyp);
// make sure index is in a pointer register
operation (addx);
top->type = type;
top->form = form;
top->format = format;
top->size = size;
top->disp = 0;
} else {
// simple arrays are always 1D, but can still be checked
if (control & checkarray != 0) {
// Pass a pointer to the Dope Vector
dumppushi (cot, av->pbase, 0);
// simple arrays have compile-time DV's in the COT
perm (aref, 2);
pushconst (0);
top->form = vinr;
top->base = ax;
claim (ax);
}
address (av);
if (av->form != vins)
abort ("Aref Form");
if (top->form == constant) {
// simple constant a(k)
av->disp = av->disp + top->disp;
// just add it to the offset
} else {
loadreg (top, anyp);
// pick up index in a pointer
if (av->base != 0) {
// add the base we've already got
dumprr (add, top->base, av->base);
release (av->base);
}
av->base = top->base;
}
if (form == array)
av->form = vins;
else
av->form = ains;
popstack ();
}
top->aform = 0;
// not an array any more
}
// array ref
// >> TEST ZERO <<
// test a real/integer/byte variable against zero
auto void testzero (stackfm * v)
{
if ((v->type == integer || v->type == byte)) {
loadreg (v, any);
dumpri (cmp, v->base, 0);
} else {
abort ("Test Zero");
}
}
// test zero
auto void comparerecords (stackfm * l, stackfm * r, int n)
{
// JDM eventually compare the byte values of each record
// in the interim, barf
abort ("Compare Records");
}
// >> COMPARE REALS <<
auto void comparereals (stackfm * l, stackfm * r)
{
loadreg (l, anyf);
loadreg (r, anyf);
hazard (ax);
// who's ended up on top?
if (l->base > r->base) {
// l_base is the top of the FPU stack
dumpfloprr (fcmp, r->base, l->base);
} else {
dumpfloprr (fcmp, l->base, r->base);
invert = invert ^ 1;
}
dumpflopspec (fstsw);
// puts status into AX
dumpsimple (sahf);
// and move it to flags
compareunsign = 1;
// because FPU reports as if operands were unsigned
}
// compare reals
// >> COMPARE STRINGS <<
auto void comparestrings (stackfm * l, stackfm * r)
{
stackfm *(&temp);
if ((l->base == cot && l->disp == nullstring)) {
(&temp) = r /* Pointer assignment */ ;
r = l /* Pointer assignment */ ;
l = (&temp) /* Pointer assignment */ ;
invert = invert ^ 1;
}
if ((r->base == cot && r->disp == nullstring)) {
l->type = byte;
testzero (l);
} else {
amap (l);
loadreg (l, any);
dumpur (push, l->base);
amap (r);
loadreg (r, any);
dumpur (push, r->base);
perm (scomp, 2);
dumpri (cmp, ax, 0);
}
}
// compare strings
// >> COMPARE <<
auto void compare (stackfm * l, stackfm * r)
{
if ((l->type == 0 || l->type == string)) {
comparestrings (l, r);
return;
}
if ((floating (l) != 0 || floating (r) != 0)) {
comparereals (l, r);
return;
}
if (zero (r) != 0) {
testzero (l);
return;
}
if (zero (l) != 0) {
testzero (r);
invert = invert ^ 1;
return;
}
if (l->type == record) {
comparerecords (l, r, minrecordsize (l, r));
return;
}
loadreg (l, any);
if (r->type == byte) {
loadreg (r, anyg);
} else {
address (r);
}
dumprv (cmp, l->base, r);
}
// compare
// >> RESOLVE <<
auto void resolve (int flag)
{
// S -> A.(B).C
if (flag & 1 == 0)
pushconst (0);
else
amap (top);
// C missing?
loadreg (top, any);
dumpur (push, top->base);
poprel ();
amap (top);
// B
loadreg (top, any);
dumpur (push, top->base);
poprel ();
if (flag & 2 == 0)
pushconst (0);
else
amap (top);
// A missing?
loadreg (top, any);
dumpur (push, top->base);
poprel ();
amap (top);
// S
loadreg (top, any);
dumpur (push, top->base);
poprel ();
perm (sresln, 4);
if (flag & 4 != 0)
dumpri (cmp, ax, 0);
}
// resolve
auto int enter (void)
{
int cad;
uncondjump = (-(1));
// can get here
// This is a convenient place to include external definitions if needed
if (potype >= external) {
fillexternal (code, nextcad, externalid);
}
cad = nextcad;
dumpstaticalloc (cad, level, blockname);
// plant dummy ENTER instruction and pass marker to pass 3
return (cad);
}
// >> DUMP RETURN <<
auto void dumpreturn (void)
{
if (uncondjump == nextcad)
return; // can't get here ?
// Pure 8086 would need these two
// dumprr(MOV, SP, BP)
// dumpur(POP, BP)
// but now we use this instead...
dumpsimple (leave);
dumpsimple (ret);
uncondjump = nextcad;
}
// return
// Routine to do "to string" as an in-line, either by making
// a constant string in the CONST area, or putting one onto
// the current workspace
auto void compiletostring (stackfm * v)
{
int tmp;
if (_const_ (v) != 0) {
currentstring[0] = 1;
currentstring[1] = v->disp & 255;
v->base = 0;
v->scope = cot;
v->disp = getcots (currentstring);
} else {
tmp = getwork (wordsize);
loadreg (v, anyg);
// Must be a byte-addressable register
dumpmi (mov, bp, tmp, 0, 1);
dumpmr8 (mov, bp, tmp + 1, 0, v->base + 16);
release (v->base);
v->base = bp;
v->scope = 0;
v->disp = tmp;
}
v->type = string;
v->form = vins;
v->size = 1;
}
// >> COMPILE CALL <<
// Call the routine on the top of the stack. Note - the parameters
// are all hidden underneath the routine, so we need to push them
// here
auto void compilecall (stackfm * v)
{
static void *b[ /* bounds */ ] = { &&b_default };
// 1 = rem
// 2 = float
// 3 = to string
// 4 = addr
// 5 = integer
// 6 = byte integer
// 7 = string
// 8 = record
// 9 = real
// 10 = long real
// 11 = length
// 12 = charno
// 13 = type of ( type of general name parameter )
// 14 = size of ( physical length in bytes )
// 15 = int (from real)
const unsigned char newtype[12 - 5 + 1];
// integer, byte, string, record, real, lreal, byte, byte
int t;
int l;
int p;
if (v->base >= 128) {
// built-in primitive
l = 0;
t = v->disp;
sym = 0;
// 'sym=0' used as flag elsewhere
poprel ();
goto *b[t];
b_1: /* 1 */
operation (remx);
goto esac;
// REM
b_2: /* 2 */
loadreg (top, anyf);
goto esac;
// FLOAT
b_3: /* 3 */
compiletostring (top);
goto esac;
// TO STRING
b_4: /* 4 */
amap (top);
goto esac;
// ADDR
b_5: /* 5 */
// INTEGER
b_6: /* 6 */
// BYTE
b_7: /* 7 */
// STRING
b_8: /* 8 */
// RECORD
b_9: /* 9 */
// REAL
b_10: /* 10 */
// LONGREAL
vmap (top);
top->type = newtype[t];
top->size = vsize[top->type];
goto esac;
b_11: /* 11 */
// LENGTH
pushconst (0);
// length is charno zero
amap (&stack[stp - 1]);
operation (addx);
// LHS&RHS reversed in Operation??
vmap (top);
top->type = newtype[t];
top->size = vsize[top->type];
goto esac;
b_12: /* 12 */
// CHARNO
amap (&stack[stp - 1]);
operation (addx);
// LHS&RHS reversed in Operation??
vmap (top);
top->type = newtype[t];
top->size = vsize[top->type];
goto esac;
b_13: /* 13 */
// TYPEOF(..)
b_14: /* 14 */
// SIZEOF(..)
if (top->type != general) {
// type explicitly specified
if (t == 13) {
// type of
p = genmap[top->type];
} else {
p = top->size;
if (top->type == string)
p += 1;
}
release (top->base);
top->type = integer;
top->form = constant;
top->base = 0;
top->disp = p;
} else {
top->disp = top->disp + wordsize;
// reference property-word
top->form = vins;
top->type = integer;
if (t == 13) {
// type of
pushconst (15);
operation (andx);
} else {
// size of
pushconst (4);
operation (rshx);
}
}
goto esac;
b_15: /* 15 */
// INT(REAL)
loadreg (top, anyf);
release (top->base);
p = getwork (wordsize);
dumpfloprm (fsti, bp, p, 0);
top->type = integer;
top->form = vins;
top->base = bp;
top->disp = p;
goto esac;
esac:
} else {
// -- normal routine calls --
// String functions have a hidden last parameter to point
// to the result area
if ((v->type == string && v->aform == 8)) {
t = getwork (v->size + 1);
p = gpreg ();
dumprm (lea, p, bp, t, 0);
dumpur (push, p);
}
hazardall ();
if (v->scope == ext) {
// external
dumpextcall (v->disp);
} else {
if (v->base != 0) {
// procedure-as-parameter
dumpum (call, v->base, v->disp, v->extdisp);
// plants call indirect through variable
} else {
// local routine
dumpjump (call, v->disp);
// plants fixup for the tag
}
}
// adjust the stack
if (v->extra != 0)
dumpri (add, sp, v->extra);
if (v->type == 0) {
// not function or map
poprel ();
} else {
// Here we've got a result
v->scope = 0;
// Result is local, even if the function wasn't
if ((v->type == string && v->aform == 8)) {
v->base = bp;
// String result will have been copied back here
v->disp = t;
v->form = vins;
} else {
if (((v->type == real || v->type == lreal) && v->aform == 8)) {
// Floating result will be on the FPU stack
v->form = vinr;
v->base = fr0;
claim (fr0);
fpustack = 1;
} else {
v->base = ax;
// Result is always in AX
v->disp = 0;
// Clear this for MAP results
claim (ax);
}
}
}
}
}
// Compile Call
// >> COMPILE FOR <<
auto void compilefor (int lab)
{
stackfm *cv;
stackfm *iv;
stackfm *inc;
stackfm *fv;
int n;
// Lock a value into a temporary to make sure it is invariant
auto void stab (stackfm * v, int type)
{
int t;
int r;
if (_const_ (v) != 0)
return;
loadreg (v, any);
r = v->base;
t = getwork (wordsize);
dumpmr (mov, bp, t, 0, r);
v->base = bp;
v->disp = t;
v->scope = 0;
v->type = type;
v->form = vins;
release (r);
}
iv = top /* Pointer assignment */ ;
fv = &stack[stp - 1] /* Pointer assignment */ ;
inc = &stack[stp - 2] /* Pointer assignment */ ;
cv = &stack[stp - 3] /* Pointer assignment */ ;
stab (fv, integer);
stab (inc, integer);
// Check control variable is a plain value - otherwise save a pointer to it
// in case it changes
if ((cv->form != vins || ((0 < cv->base && cv->base <= di) && cv->base != bp))) {
n = cv->type;
amap (cv);
stab (cv, n);
cv->form = ains;
}
pushcopy (cv);
pushcopy (iv);
pushcopy (inc);
operation (subx);
assign (1);
// cv = iv - inc
definelabel (lab);
popstack ();
// zap unwanted copy of IV
// Stack is now top->[FV[INC[CV
pushcopy (cv);
// in case compare alters it
compare (top, fv);
jumpto (lab + 1, je, 1);
invert = 0;
// because the compare might have flipped this (N/A for JE)
// Stack is now top->[CV'[FV[INC[CV where CV' is a register copy of CV
release (fv->base);
fv = top;
// trash FV and make a copy of CV' in that slot
popstack ();
// discard the top copy
// stack is now top->[CV'[INC[CV
operation (addx);
assign (1);
}
// for
auto void endofblock (void)
{
if (amode >= 0) {
// No return code for %endoffile
dumpreturn ();
dumpstaticfill (staticalloc, frame + (level * wordsize), events, evep, evfrom);
// don't include the display
}
}
auto void compilebegin (void)
{
decvar = (&begin) /* Pointer assignment */ ;
decvar->disp = newtag ();
otype = 0;
spec = 0;
potype = 0;
if (level != 0) {
// not outermost %begin
pushconst (decvar->disp);
top->type = 0;
// it's not a function!
compilecall (top);
skipproc = newtag ();
dumpjump (jmp, skipproc);
dumplabel (decvar->disp);
// this is where to call
}
assemble (0, labs, names);
if (level != 0) {
dumplabel (skipproc);
lastskip = nextcad;
uncondjump = 0;
}
}
// Utility routine used when dumping initialisers for OWNs
// Note non-portable use of real values
auto void adump (void)
{
int i;
float rv32;
static void *ot[ /* bounds */ ] = { &&ot_default };
goto *ot[owntype];
ot_general: /* general */
abort ("General Own?");
ot_integer: /* integer */
gput (ownval);
goto done;
ot_real: /* real */
rv32 = rvalue;
// because our default variable is a 64 bit long real
for (i = 0; i <= 3; i += 1) {
gbyte (byteinteger (addr (rv32) + i));
}
goto done;
ot_string: /* string */
if (currentstring[0] + 1 > datasize) {
// check for overflow
// String constant too long - warn and truncate
warn (5);
currentstring[0] = datasize - 1;
}
for (i = 0; i <= datasize - 1; i += 1) {
gbyte (currentstring[i]);
}
goto done;
ot_record: /* record */
for (i = 1; i <= datasize; i += 1) {
gbyte (0);
}
goto done;
ot_byte: /* byte */
gbyte (ownval);
goto done;
ot_lreal: /* lreal */
for (i = 0; i <= 7; i += 1) {
gbyte (byteinteger (addr (rvalue) + i));
}
goto done;
done:
}
auto int userlabel (int lab)
{
varfm *v;
if (lab > names) {
names = lab;
v = &var[lab] /* Pointer assignment */ ;
v = 0;
v->form = pgmlabel;
v->disp = newtag ();
return (v->disp);
}
return (&var[lab]->disp);
}
auto void comparedouble (void)
{
lhs = &stack[stp - 1] /* Pointer assignment */ ;
rhs = top /* Pointer assignment */ ;
loadreg (rhs, any);
// We happen to know that Compare loads the left parameter in a register.
// We've already got RHS in a register, so we flip the LHS and RHS to the
// comparison and set Invert accordingly
compare (rhs, lhs);
invert = 1;
// release LH and then overwrite it with RH
release (lhs->base);
lhs = rhs;
popstack ();
}
auto void comparevalues (void)
{
lhs = &stack[stp - 1] /* Pointer assignment */ ;
rhs = top /* Pointer assignment */ ;
compare (lhs, rhs);
poprel ();
poprel ();
}
auto void compareaddresses (void)
{
amap (top);
amap (&stack[stp - 1]);
// Now do same as compare values
comparevalues ();
}
auto void definecompilerlabel (int _label_)
{
if (_label_ == 0) {
dumplabel (skipproc);
lastskip = nextcad;
uncondjump = 0;
} else {
definelabel (_label_);
}
}
auto void init (int n)
{
// N = Number of values to assign
int j;
if (stp != 0) {
// Value supplied?
ownval = top->disp;
if ((owntype == real || owntype == lreal)) {
if (top->type == integer)
rvalue = ownval;
// copy integer supplied into floater
}
popstack ();
} else {
// initialise to default pattern
ownval = 0;
currentstring[0] = 0;
// in case it's a string
}
if ((ownform == array || ownform == namearray)) {
for (j = 1; j <= n; j += 1)
adump ();
} else {
if (otype == 0) {
// %const .... %name
// Abort("Constant Name");
// JDM attempt to allow assignment of %const ... %name
decvar->scope = cot;
decvar->level = 0;
decvar->disp = ownval;
} else {
// non-array normal variables
decvar->level = 0;
if (otype == con) {
// constant - must be string or real type, because
// const integers are substituted by value in Pass 1
// Constant strings and reals are treated as literals
decvar->scope = cot;
if (owntype == string) {
decvar->disp = getcots (currentstring);
} else {
if ((owntype == real || owntype == lreal)) {
// constant reals are put in the COT. Depending on how
// the value was formed, ReadReal may have already planted this.
// Not to worry, because "real constant" will find it again.
decvar->disp = getcotdouble (rvalue);
} else {
abort ("Init?");
}
}
} else {
// must be %own or %external - use adump to put it in DATA segment
decvar->scope = data;
decvar->disp = datatp;
adump ();
}
}
}
}
auto void userjump (int _label_)
{
dumpjump (jmp, userlabel (_label_));
}
auto void defineuserlabel (int _label_)
{
dumplabel (userlabel (_label_));
}
auto void return (int mode)
{
int i;
if (mode == false) {
dumpri (mov, ax, 0);
}
if (mode == true) {
dumpri (mov, ax, (-(1)));
}
if (mode == map) {
amap (top);
loadreg (top, ax);
poprel ();
}
if (mode == fn) {
if (procvar->type == integer) {
loadreg (top, ax);
poprel ();
} else {
if ((procvar->type == real || procvar->type == lreal)) {
// Floating point results are put into store, and AX contains
// the address
// JDM - No, not for 32-bit code for IA-32 architecture ABI
// JDM - floating point results go onto the floating point stack in ST(0)
// JDM - that is the returned floating point stack should only be 1 deep
// JDM: loadreg(top,anyf) should push the result onto the floating point stack
loadreg (top, anyf);
poprel ();
} else {
// string or record - pass back through the hidden parameter
pushcopy (top);
// Make a copy of the thing on top
lhs = &stack[stp - 1] /* Pointer assignment */ ;
// point to the (now spare) next item
lhs->type = procvar->type;
// and make it look like a destination
lhs->size = procvar->size;
lhs->format = procvar->format;
lhs->base = bp;
lhs->disp = wordsize * 2;
// At the offset of the last parameter
lhs->form = ains;
assign (1);
}
}
}
if (mode == routine) {
// no need to do anything special
}
dumpreturn ();
}
auto void dimension (int dim, int n)
{
int i;
int j;
// Validate the ICODE Parameters
if (!((0 < dim && dim < 6)))
abort ("Array Dim");
if (inparams != 0) {
// Array in record
parms += n;
vub = top->disp;
popstack ();
vlb = top->disp;
popstack ();
if (vlb > vub)
abort ("Array Bounds");
dv = setdopevector ();
} else {
names -= n;
// Now we need to plant code to manufacture a dope vector
frame = (frame - ((dim * (2 * wordsize)) + (2 * wordsize))) & ((~(align)));
// space for :Dim:<bound pairs>:DataSize:
dv = frame;
// First store the dimension
dumpmi (mov, bp, dv, 0, dim);
// And the data size is also constant
dumpmi (mov, bp, dv + (dim * (2 * wordsize)) + wordsize, 0, datasize);
// Now the bounds
j = 0;
// points to before the first stack value
for (i = 1; i <= dim * 2; i += 1) {
j += 1;
lhs = &stack[j] /* Pointer assignment */ ;
if (lhs->form == constant) {
dumpmi (mov, bp, dv + (i * wordsize), 0, lhs->disp);
} else {
loadreg (lhs, any);
dumpmr (mov, bp, dv + (i * wordsize), 0, lhs->base);
}
}
// Now we need to allocate the space for the array
if ((dim > 1 || control & checkarray != 0)) {
// Do it with the PERM
while (stp != 0) {
poprel ();
// get rid of all the bounds - they are in the DV already
}
dumprm (lea, ax, bp, dv, 0);
dumpur (push, ax);
perm (adef, 1);
// We now need to make our result match the inline version
// by putting AX and DX into stacklike variables
pushconst (0);
lhs = top /* Pointer assignment */ ;
pushconst (0);
rhs = top /* Pointer assignment */ ;
lhs->base = ax;
lhs->form = vinr;
claim (ax);
rhs->base = dx;
rhs->form = vinr;
claim (dx);
popstack ();
popstack ();
} else {
pushconst (1);
operation (addx);
pushconst (datasize);
operation (mulx);
pushcopy (&stack[stp - 1]);
// suck up the lower bound
pushconst (datasize);
operation (mulx);
// top is now the lower bound, next is the upper, and a bogus copy of lb is next
loadreg (top, any);
// Make sure this is in a register
lhs = top /* Pointer assignment */ ;
// Point to it
popstack ();
// and drop (without release) this copy
loadreg (top, any);
// This is now UB - load it in a register as well
rhs = top /* Pointer assignment */ ;
// Point to it
popstack ();
// and keep RHS (Upper)
popstack ();
// dump the bogus lb
}
// Note - there are 4 GP registers, and we're going to need them ALL here
t = gpreg ();
// get a working register for the dope vector address
dumprm (lea, t, bp, dv, 0);
// load it
dv = t;
claim (dv);
// use this to hold the register number
t = gpreg ();
// the last one! (which we don't claim, 'cos we can't lose it)
dumprr (mov, t, sp);
// working copy of SP so that real SP is always "OK"
}
for (i = 1; i <= n; i += 1) {
decvar->dim = dim;
if (inparams == 0) {
// array not in record
names += 1;
decvar = &var[names] /* Pointer assignment */ ;
decvar->level = level;
frame -= (wordsize * 2);
// 2-word header
decvar->disp = frame;
if ((decvar->form == array || decvar->form == namearray))
decvar->form = decvar->form + 1;
// force arrayname
dumprr (sub, t, rhs->base);
dumpmr (mov, bp, frame, 0, t);
// store a(0) address
dumpmr (mov, bp, frame + wordsize, 0, dv);
// store dope vector pointer
dumprr (add, t, lhs->base);
} else {
// array-in-record
parms -= 1;
decvar = &var[parms] /* Pointer assignment */ ;
decvar->disp = frame - vlb;
frame += vub;
// noting that Set Dope Vector has changed VUB to the array size
decvar->pbase = dv;
}
}
if (inparams == 0) {
// We need to keep the stack pointer word aligned - 8086's run faster that way,
// and more importantly, Pentiums throw an exception if you don't!
if (datasize & align != 0)
dumpri (and, t, (~(align)));
dumprr (mov, sp, t);
release (lhs->base);
release (rhs->base);
release (dv);
}
}
auto void updateline (int line)
{
currentline = line;
if (stp != 0)
abort ("Stack?");
if (claimed != 0)
abort ("Claimed");
// Pass1 sends the line number multiple times if there's more than
// one statement per line - for debugging we only want "real" line numbers
if (echoline < currentline) {
dumplinenumber (currentline);
while (echoline < currentline) {
echosourceline ();
}
}
}
auto void switchjump (int switchid)
{
v = &var[switchid] /* Pointer assignment */ ;
pushconst (wordsize);
operation (mulx);
// subscript X WordSize
loadreg (top, anyp);
dumpum (jmp, swt | top->base, v->disp * wordsize, 0);
// swtab is word-size
poprel ();
uncondjump = nextcad;
}
auto void setrecordformat (int formatid)
{
top->format = formatid;
top->type = record;
}
auto void switchlabel (int switchlabel)
{
v = &var[switchlabel] /* Pointer assignment */ ;
uncondjump = 0;
j = top->disp;
popstack ();
t = newtag ();
dumplabel (t);
swtab[v->disp + j] = t;
}
auto void constantbounds (void)
{
vub = top->disp;
popstack ();
vlb = top->disp;
popstack ();
}
auto void internalhandler (int id)
{
while (stp < 2)
pushconst (0);
pushconst (id);
loadreg (top, any);
dumpur (push, top->base);
poprel ();
loadreg (top, any);
dumpur (push, top->base);
poprel ();
loadreg (top, any);
dumpur (push, top->base);
poprel ();
perm (signal, 3);
if (id != (-(1)))
uncondjump = nextcad;
// %monitor will return
}
auto void signalevent (int eventid)
{
internalhandler (eventid);
}
auto void monitor (void)
{
internalhandler ((-(1)));
}
auto void selectfield (int fieldindex)
{
// Contrary to earlier iCode versions, this one seems to use 'n' for
// both normal record member access and alternate formats?
lhs = top /* Pointer assignment */ ;
// Points to the base record
stackvar (&var[top->format]->pbase - fieldindex);
// Push descriptor for the i-th member
if (top->aform != recordformat) {
// not record format - must be a member
if ((lhs->form == vins || lhs->form == vinrec)) {
top->disp = top->disp + lhs->disp;
lhs->form = lhs->form - vins + top->form;
} else {
if (lhs->form == ainrec) {
lhs->form = vinrec;
lhs->type = integer;
loadreg (lhs, any);
lhs->form = top->form;
} else {
if (lhs->form <= vinr) {
lhs->form = top->form;
// ????
} else {
// A in S
lhs->extra = lhs->disp;
lhs->form = top->form + 3;
}
}
}
lhs->disp = top->disp;
lhs->type = top->type;
lhs->aform = top->aform;
lhs->dim = top->dim;
}
lhs->size = top->size;
lhs->format = top->format;
popstack ();
}
auto void eventtrap (int anevent, int evfrom)
{
// events: Events to trap (then comma)
// evfrom: Label to skip to
int (&temp);
events = anevent;
(&temp) = getwork (wordsize);
// get a temp location for SP
dumpmr (mov, bp, (&temp), 0, sp);
// because our signaller doesn't restore it
jumpto (evfrom, jmp, 1);
// go there now
// We need to make EVFROM into a label ID that pass 3 will recognise
// to build the trap table, so Jump To sets a variable we pick up here...
evfrom = jtag;
evep = newtag ();
// tag for the event body entry point
dumplabel (evep);
// which is here
dumprm (mov, sp, bp, (&temp), 0);
// First thing we do is restore SP
}
auto void doubleop (int opr)
{
int j;
int t;
lhs = &stack[stp - 1] /* Pointer assignment */ ;
t = lhs->type;
j = lhs->size;
if (t == string)
j += 1;
amap (lhs);
if (j == 0)
abort ("++/-- size");
pushconst (j);
operation (mulx);
operation (opr);
vmap (top);
top->type = t;
}
auto void setcd (int value, int *cd)
{
// JDM set value for the appropriate compiler pass
// In this case we are in pass2
if (value & 0xC000 == (passid & 3) << 14)
cd = value & 0x3FFF;
}
auto int finishparams (void)
{
int j;
if (amode < 0)
return (0 == 0); // end of %record %format defn.
if (procvar->level == 128)
return (0 == 0); // prim routine reference
// Here it's a real subroutine - copy any parameters to the PARM area
if (names > firstname) {
procvar->pbase = parms;
// Point one beyond the first parameter
frame = (frame + align) & ((~(align)));
// Even up the stack size
if ((procvar->type == string && procvar->form == 8)) {
frame += wordsize;
// string functions have a hidden result parameter
}
procvar->extra = frame;
// Remember the stack offset
procvar->dim = names - firstname;
// and the number of parameters
frame += (2 * wordsize);
// leave space for return linkage (IP + BP)
for (j = firstname + 1; j <= names; j += 1) {
ap = &var[j] /* Pointer assignment */ ;
parms -= 1;
fp = &var[parms] /* Pointer assignment */ ;
fp = ap;
// formal parameter base and displacement is implicit (on the stack)
fp->level = 0;
// we also need to adjust the offsets of the actual parameters, because
// they were allocated going "forwards", but will be pushed on the stack
// "backwards" - that is, the first item passed will end up with the
// highest address. DefineVar has done part of the work for us by tagging
// the displacements in the right style, but it can't tell the whole frame
// offset, so we calculate the final offsets here...
ap->disp = frame - ap->disp;
}
if (parms < names)
abort ("Params");
}
if (amode == 2)
return (0 == 0); // this was just a spec
dumplabel (procvar->disp);
staticalloc = enter ();
frame = (-((level * wordsize)));
// one word for each display entry
return (0 != 0);
}
auto int alternateformat (int n)
{
// Check the ICODE for faults
// and abort for any faulty intermediate code
if (!((n == 'A' || (n == 'B' || n == 'C'))))
abort (concat ("Alt Record '", concat (tostring (sym), "'.")));
if (n == 'B')
return (0 == 0); // alt end
if (n == 'A') {
// alt start
decvar = procvar /* Pointer assignment */ ;
assemble ((-(2)), labs, names);
}
if (n == 'C') {
// Compile the next alternate - update limit and set frame back to where we started
if (frame > maxframe)
maxframe = frame;
frame = oldframe;
}
return (0 != 0);
}
// ******************************************
// JDM JDM attempt to include the plant icode and machine code icode
auto void plant (void)
{
// Plant in-line code values (from "*=constant")
int j;
// We only expect one item on the stack
if (stp != 1)
abort ("Machine Literal");
for (j = 1; j <= stp; j += 1) {
// JDM JDM not sure what next 3 lines do, so commented out
// lhs == stacked(j)
// word (lhs_disp)
// drop (lhs)
}
// JDM empty the icode stack
stp = 0;
}
auto char *gettypename (int f)
{
char name[8 + 1];
strcpy (name, "????");
if (f == 0)
strcpy (name, "general");
if (f == 1)
strcpy (name, "integer");
if (f == 2)
strcpy (name, "real");
if (f == 3)
strcpy (name, "string");
if (f == 4)
strcpy (name, "record");
if (f == 5)
strcpy (name, "byte");
if (f == 6)
strcpy (name, "lreal");
return (name);
}
auto char *getformname (int f)
{
char name[24 + 1];
strcpy (name, "????");
static void *n[ /* bounds */ ] = { &&n_default };
unsigned char esac;
goto *n[f & 15];
n_0: /* 0 */
strcpy (name, "void");
goto esac;
n_1: /* 1 */
strcpy (name, "simple");
goto esac;
n_2: /* 2 */
strcpy (name, "name");
goto esac;
n_3: /* 3 */
strcpy (name, "_label_");
goto esac;
n_4: /* 4 */
strcpy (name, "recordformat");
goto esac;
n_5: /* 5 */
strcpy (name, "?????");
goto esac;
n_6: /* 6 */
strcpy (name, "switch");
goto esac;
n_7: /* 7 */
strcpy (name, "routine");
goto esac;
n_8: /* 8 */
strcpy (name, "function");
goto esac;
n_9: /* 9 */
strcpy (name, "map");
goto esac;
n_10: /* 10 */
strcpy (name, "predicate");
goto esac;
n_11: /* 11 */
strcpy (name, "array");
goto esac;
n_12: /* 12 */
strcpy (name, "arrayname");
goto esac;
n_13: /* 13 */
strcpy (name, "namearray");
goto esac;
n_14: /* 14 */
strcpy (name, "namearrayname");
goto esac;
n_15: /* 15 */
strcpy (name, "?????????????");
goto esac;
esac:
return (name);
}
// classify the type of the machine code instruction parameter
const int unknown = 0, variable = 1, register = 2, number = 3, mask = 4, name = 5, pointer = 6;
// param type is one of unknown, variable, register, number, mask, name, pointer
// param value is ???, tag, reg id, number, 32-bit mask, integer, reg id,
// param data is ???, tag name, reg name, N/A, N/A, name, reg name
// param offset is N/A, N/A, N/A, N/A, N/A, N/A, offset
//
auto void dumptagvar (int tag, char *prefix)
{
printstring (concat (" ", concat (prefix, concat (" tag=", itos (tag, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" name=", &var[tag]->idname))));
newline ();
printstring (concat (" ", concat (prefix, concat (" type=", concat (itos (&var[tag]->type, 0), concat (" ", gettypename (&var[tag]->type)))))));
newline ();
printstring (concat (" ", concat (prefix, concat (" form=", concat (itos (&var[tag]->form, 0), concat (" ", getformname (&var[tag]->form)))))));
newline ();
printstring (concat (" ", concat (prefix, concat (" level=", itos (&var[tag]->level, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" scope=", itos (&var[tag]->scope, 0)))));
printstring (concat (" ", relocname[&var[tag]->scope >> 4]));
newline ();
printstring (concat (" ", concat (prefix, concat (" disp=", itos (&var[tag]->disp, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" extdisp=", itos (&var[tag]->extdisp, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" size=", itos (&var[tag]->size, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" extra=", itos (&var[tag]->extra, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" format=", itos (&var[tag]->format, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" dim=", itos (&var[tag]->dim, 0)))));
newline ();
printstring (concat (" ", concat (prefix, concat (" pbase=", itos (&var[tag]->pbase, 0)))));
newlines (2);
}
auto void dumpparameter (int paramindex, int paramtype, char *paramname, int paramvalue, int paramoffset)
{
char t[255 + 1];
int tag;
int n;
printstring (concat ("Parameter(", concat (itos (paramindex, 0), concat (")='", concat (paramname, "'")))));
newline ();
if (paramtype == pointer) {
// dump the pointer data
if (paramoffset == 0) {
printstring (concat (" PTR id=", itos (paramvalue, 0)));
newline ();
printstring (concat (" PTR name=[", concat (paramname, "]")));
newline ();
printstring (" PTR offset=0");
newlines (2);
} else {
printstring (concat (" PTR id=", itos (paramvalue, 0)));
newline ();
printstring (concat (" PTR name=[", concat (paramname, concat (itos (paramoffset, 0), "]"))));
newline ();
printstring (concat (" PTR offset=", itos (paramoffset, 0)));
newlines (2);
}
} else if (paramtype == variable) {
// dump the variable data
dumptagvar (paramvalue, "VAR");
} else if (paramtype == register) {
// dump the register data
printstring (concat (" REG id=", itos (paramvalue, 0)));
newline ();
printstring (concat (" REG name=", paramname));
newlines (2);
} else if (paramtype == number) {
// dump the number data
printstring (concat (" NUMBER value=", itos (paramvalue, 0)));
newlines (2);
} else if (paramtype == mask) {
// dump the mask data
printstring (concat (" MASK value=2_", int2ascii (paramvalue, 2, 0)));
newlines (2);
} else if (paramtype == name) {
// dump the name data
printstring (concat (" NAME name=", paramname));
newline ();
printstring (concat (" NAME value=2_", int2ascii (paramvalue, 2, 0)));
newlines (2);
}
}
// >> MACHINE CODE <<
auto void machinecode (char *code)
{
// This is meant to insert a machine code fragment into the code stream
// For now do nothing with the machine code text
// JDM JDM JDM
// ok, lets go
// 1) need to parse the machine code text
char s[255 + 1];
char t[255 + 1];
char rname[255 + 1];
char instruction[5 + 1];
char parameters[255 + 1];
int paramscount;
// ass-u-me that a machine code instruction has at most 8 parameters
const int paramlimit = 8;
// Remember number of CPU registers (1..register limit)
const int registerlimit = 8;
// A machine code string has the form *op_ item*
// where op is an instruction name (a sequence of alphanumeric chars terminated by '_')
// An item has one of the forms:
// 1) varname == ' ' BB (where 0 <= B <= 255 and BB represent a definition tag)
// 2) constant == 'N' BBBB (where 0 <= B <= 255 and BBBB represents a 32-bit signed integer)
// 3) text == B+ (where 128 <= B <= 255 and then convert b = B - 128, so text is an ASCII sequence b+)
// and the code string can include the ASCII chars (excluding any varname,constant,text format)
// 4) chars == c* (where c is one of '<','>','[',']','(',')','#',',')
//
// An instruction can have 0,1,2 parameters separated by a ','
// One parameter type is a register mask of form '<' number (',' number)* '>'
// This is the ONLY other legal use of a ','
// The following defines the legal opcode parameters
// 1) register == constant (a register index, beware register range)
// 2) number == # constant (a 32-bit signed integer)
// 3) mask == '<' register (',' register)* '>' (a bit set of registers, beware limit on count of registers)
// 4) modifier == text number
// 5) variable == varname, pointer
// 6) pointer == '[' register ']', '[' register '+' offset ']', '{ register '-' offset ']'
// 7) offset == constant (a 32-bit signed integer)
//
// N.B. a variable could be the value held in varname or the address of varname.
// N.B. register always refers to its value, but pointer becomes an address
//
// Legal Intel 386 instruction formats
// The modifier, mask parameters are unused
// No-op instruction
// *op_
//
// One-op instruction
// *op_ register
// *op_ number
// *op_ variable
//
// Two-op MOV instruction
// *op_ register ',' register2 == register := register2
// *op_ register ',' number == register := number
// *op_ register ',' variable == register := variable
// *op_ variable ',' register == variable := register
// *op_ variable ',' number == variable := number
//
// Two-op instruction (non-MOV instruction)
// *op_ register ',' register2 == register := register op register2
// *op_ register ',' number == register := register op number
// *op_ register ',' variable == register := register op variable
// *op_ variable ',' register == variable := variable op register
// *op_ variable ',' number == variable := variable op number
typedef struct paramfm
{
char *data;
int scomma, pcomma, start, end;
char *paramname;
int paramtype, paramvalue, paramoffset;
} paramfm;
paramfm params[paramlimit - 1 + 1];
// JDM being lazy I created a dual purpose list to map
// op (NOP:JMP) to a corresponding opX
// op (NOP:JMP) to a text version of opX
// This list maps opId to internal opX
const int opgenericid[jmp - nop + 1];
// This list maps opId to internal opX name
const char *opgenericname[jmp - nop + 1];
char varname[255 + 1];
unsigned char ch;
char opnamex[5 + 1];
int i;
int j;
int k;
int n;
int plen;
int tag;
int rval;
int opid;
int opidx;
unsigned char inrbflag;
unsigned char insbflag;
unsigned char inabflag;
unsigned char hashflag;
unsigned char plusflag;
unsigned char minusflag;
static void *c[ /* bounds */ ] = { &&c_default };
unsigned char esac;
unsigned char default;
int start;
int end;
if ((diagnose & mcodelevela) != 0) {
selectoutput (listout);
newline ();
}
(void) imp_resolve ("..."); /* temp */
strcpy (s, "");
if (strcmp (parameters, "")) {
// parameters is a non-empty string so we ass-u-me at least one parameter
paramscount = 1;
plen = strlen (parameters);
inrbflag = 0;
// not inside round bracket sequence
insbflag = 0;
// not inside square bracket sequence
inabflag = 0;
// not inside angle bracket sequence
hashflag = 0;
// not expecting a number to follow
i = 1;
while (i <= plen) {
ch = parameters ((i) - 1);
if (ch < 128)
goto *c[ch];
// this is an ordinary ASCII char
// So, ch > 127, thus this "char" starts a tweaked "name"
strcpy (t, "%");
while (parameters ((i) - 1) > 127) {
// Append the converted char
t (strlen (t) + 1) = '\0'; // tweak appended "char" to be a legal 7-bit ASCII char
charno (t, strlen (t)) = parameters ((i) - 1) - 128;
i += 1;
}
¶ms[paramscount]->paramtype = name;
¶ms[paramscount]->paramvalue = 0;
// value acquired by next N section
¶ms[paramscount]->paramname = t;
strcat (s, concat (t, " "));
goto esac;
c_ ' ': /* ' ' */
// a variable/pointer reference is prefixed by a space.
n = (parameters ((i + 1) - 1) << 8) + parameters ((i + 2) - 1);
// now determine the variable name
t = &var[n]->idname;
// remember this parameter is a variable/pointer (and its tag)
if (insbflag == 1) {
¶ms[paramscount]->paramtype = pointer;
} else {
¶ms[paramscount]->paramtype = variable;
}
¶ms[paramscount]->paramvalue = n;
¶ms[paramscount]->paramname = t;
strcat (s, t);
i += 3;
goto esac;
c_ 'N': /* 'N' */
// A number is prefixed by an ASCII 'N'
n = 0;
n += parameters ((i + 1) - 1);
n = n << 8;
n += parameters ((i + 2) - 1);
n = n << 8;
n += parameters ((i + 3) - 1);
n = n << 8;
n += parameters ((i + 4) - 1);
if (¶ms[paramscount]->paramtype == name) {
// this number is associated with a "name" (i.e. %shl 4)
hashflag = 0;
// we have the "name" (i.e %shl)
// but now to get the associated numeric value
¶ms[paramscount]->paramvalue = n;
// convert number to text
if (n > 127) {
t = concat ("16_", int2ascii (n, 16, 0));
} else {
t = itos (n, 0);
}
// now to add the associated number to the s string
strcat (s, t);
} else if ((hashflag != 0 && ¶ms[paramscount]->paramtype == unknown)) {
// hashflag indicates this is a genuine integer
hashflag = 0;
// remember this parameter is a number
¶ms[paramscount]->paramtype = number;
¶ms[paramscount]->paramvalue = n;
strcpy (¶ms[paramscount]->paramname, "");
if (n > 127) {
t = concat ("16_", int2ascii (n, 16, 0));
} else {
t = itos (n, 0);
}
strcat (s, t);
¶ms[paramscount]->paramname = t;
} else if (¶ms[paramscount]->paramtype == mask) {
// Ah, we are between <> == mask
// So we need to update the mask
if ((0 < n && n <= registerlimit)) {
// ok, legal register mask range
k = 1 << (n - 1);
} else if ((0 < n && n <= 32)) {
// oops, bad mask specifier for this CPU
k = 1 << (n - 1);
} else {
// oops, even worse! Is this a CPU with > 32 registers.
// we can't fit this mask into a 32-bit integer
// so, we won't try
k = 0;
}
// add the register flag to the mask
¶ms[paramscount]->paramvalue = ¶ms[paramscount]->paramvalue | k;
// remember N represents the register number but add the reg name
// Ensure we are referencing a valid register
// Adjust register limit for a specific CPU
if ((0 < n && n <= registerlimit)) {
strcat (s, regname[n]);
} else {
strcat (s, "R??");
}
} else {
// ok this came from a constant integer in the IMP program
// ASS-U-ME that this constant represents a register
// So, replace the number with the register name
// Register name is specific to a processor architecture
// IMP code with embedded assembler should reference a
// register by number.
// The IMP pass2 for that processor should store a mapping
// between "register" number and register name.
// eg Intel eax or ebp
// remember this parameter is a variable/pointer (and its tag)
if (insbflag == 1) {
¶ms[paramscount]->paramtype = pointer;
} else {
¶ms[paramscount]->paramtype = register;
}
if (plusflag == 1) {
// remember this "parameter" is a positives pointer offset
¶ms[paramscount]->paramoffset = n;
t = itos (n, 0);
} else if (minusflag == 1) {
// remember this "parameter" is a negative pointer offset
¶ms[paramscount]->paramoffset = (-(n));
// however, negative sign (and or #) already output
t = itos (n, 0);
} else {
// remember this parameter is a register
¶ms[paramscount]->paramvalue = n;
// Ensure we are referencing a valid register
// Adjust register limit for a specific CPU
if ((0 < n && n <= registerlimit)) {
t = regname[n];
} else {
strcpy (t, "R??");
}
¶ms[paramscount]->paramname = t;
}
strcat (s, t);
}
i += 5;
goto esac;
c_ '#': /* '#' */
// let this char through
// BUT remember # is assumed to prefix a positive number
hashflag = 1;
goto default;
c_ ',': /* ',' */
// let this char through
// comma separates instruction parameters
// (or values between brackets)
if ((inabflag + inrbflag + insbflag) == 0) {
// REMEMBER, the parameter type and value should have been
// determined previously
// note comma location in the s string
¶ms[paramscount]->scomma = strlen (s) + 1;
// note comma location in the parameters string
¶ms[paramscount]->pcomma = i;
// beware fence post error
// we are counting fence posts (,)
// and their locations
// So "last" fence post at end of parameters string
// we have an additional parameter
paramscount += 1;
// BUT set the param type appropriately
¶ms[paramscount]->paramtype = unknown;
¶ms[paramscount]->paramoffset = 0;
}
goto default;
c_ '+': /* '+' */
// pass this char( only allowed between [] brackets
plusflag = 1;
minusflag = 0;
goto default;
c_ '-': /* '-' */
// pass this char( only allowed between [] brackets
plusflag = 0;
minusflag = 1;
goto default;
c_ '(': /* '(' */
// pass this char (opening round brackets)
inrbflag = 1;
goto default;
c_ ')': /* ')' */
// pass this char (closing round brackets)
inrbflag = 0;
goto default;
c_ '[': /* '[' */
// we are referencing an indirect variable
¶ms[paramscount]->paramtype = pointer;
// initialise the name,value and offset
strcpy (¶ms[paramscount]->paramname, "");
¶ms[paramscount]->paramvalue = 0;
¶ms[paramscount]->paramoffset = 0;
// pass this char (opening square brackets)
insbflag = 1;
goto default;
c_ ']': /* ']' */
// pass this char (closing square brackets)
plusflag = 0;
minusflag = 0;
insbflag = 0;
goto default;
c_ '<': /* '<' */
// We are starting a mask parameter
¶ms[paramscount]->paramtype = mask;
// initialise the value and name
strcpy (¶ms[paramscount]->paramname, "");
¶ms[paramscount]->paramvalue = 0;
¶ms[paramscount]->paramoffset = 0;
// pass this char (opening angle brackets)
inabflag = 1;
goto default;
c_ '>': /* '>' */
// pass this char (closing angle brackets)
inabflag = 0;
goto default;
default:
// AST 112084: DEFAULTCASE c
// pass these chars
// chars > 127 are already dealt with
// So, this deals with remaining chars
strcat (s, tostring (parameters ((i) - 1)));
i += 1;
goto esac;
esac:
}
} else {
// Oh, this instruction has no parameters
paramscount = 0;
}
if (paramscount != 0) {
// now to identify each instruction parameter inside the s string
for (i = 1; i <= paramscount; i += 1) {
if (i == 1)
¶ms[i]->start = 1;
else
¶ms[i]->start = ¶ms[i - 1]->scomma + 1;
if (i == paramscount)
¶ms[i]->end = strlen (s);
else
¶ms[i]->end = ¶ms[i]->scomma - 1;
strcpy (¶ms[i]->data, "");
for (j = ¶ms[i]->start; j <= ¶ms[i]->end; j += 1) {
¶ms[i]->data = concat (¶ms[i]->data, tostring (s ((j) - 1)));
}
}
}
// determine the opId for this instruction
// set a default "ILLEGAL" value for the opId
// Although Intel 386 has opCodes 0..255
// the count of opCode names is much less than 255
// so, we are safe to set opId and opIdx = 255
opid = (-(1));
opidx = (-(1));
for (i = nop; i <= jmp; i += 1) {
if (instruction == opgenericname[i]) {
opid = i;
opidx = opgenericid[opid];
if (opidx != (-(1))) {
opnamex = instruction;
} else {
opnamex = itos (opid, 0);
}
}
}
// We are NOT allowing any floating point instructions
// %for i = FILD,1,FLDPI %cycle
// %if instruction = flopname(i) %then opId = i
// %repeat
// %if (opId < FILD) %then instruction = opName(opId) %else instruction = flopName(opId)
// use short form of %if statement (as an example)
if (opid == (-(1)))
abort ("MCODE has illegal/unknown instruction name");
if ((diagnose & mcodelevela) != 0) {
selectoutput (listout);
printstring ("**** START MCODE ****");
newline ();
if ((diagnose & mcodeleveld) != 0) {
printstring (concat (" Raw Instruction text: '", concat (instruction, concat ("'_", parameters))));
newline ();
}
printstring (concat ("Translated Instruction: '", concat (instruction, concat ("' ", s))));
newline ();
printstring (concat (" Instruction: '", concat (instruction, concat ("' has ", concat (itos (paramscount, 0), " parameter")))));
if (paramscount != 1)
printsymbol ('s');
newline ();
printstring (concat (" Instruction OpId: ", itos (opid, 0)));
newline ();
printstring (concat (" Instruction OpIdx: ", itos (opidx, 0)));
newline ();
// now to identify each instruction parameter inside the s string
printstring ("*** start parameters ****");
newline ();
// Dump any parameters specified
for (i = 1; i <= paramscount; i += 1) {
dumpparameter (i, ¶ms[i]->paramtype, ¶ms[i]->paramname, ¶ms[i]->paramvalue, ¶ms[i]->paramoffset);
}
printstring ("*** end parameters ****");
newline ();
// ADDANEXTRANEWLINETOSPLITTHEABOVEDEBUGCODEFROM
// THEFOLLOWINGCODEGENERATIONCODE
newline ();
printstring ("**** START CODE GEN **********");
newline ();
}
// 2) need to interpret parsed code
if (paramscount == 0) {
selectoutput (listout);
printstring ("**** Instructions with no parameters not yet implemented");
newline ();
} else if (paramscount == 1) {
if (opid != (-(1))) {
if (¶ms[1]->paramtype == variable) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat (instruction, concat (" ", ¶ms[1]->paramname)));
newline ();
}
stackvar (¶ms[1]->paramvalue);
operation (opidx);
} else if (¶ms[1]->paramtype == pointer) {
selectoutput (listout);
printstring (concat ("Opcode ", concat (instruction, concat (" with one parameter can only operate on an address/register ", ¶ms[1]->paramname))));
newline ();
abort (concat ("Opcode ", concat (instruction, concat (" with one parameter can only operate on an address/register ", ¶ms[1]->paramname))));
} else if (¶ms[1]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat (instruction, concat (" ", ¶ms[1]->paramname)));
newline ();
}
dumpur (opid, ¶ms[1]->paramvalue);
} else {
abort (concat ("Opcode ", concat (instruction, concat (" is attempting to operate on unexpected location ", ¶ms[1]->paramname))));
}
} else {
abort (concat ("Attempting to apply unknown opcode ", instruction));
}
} else if (paramscount == 2) {
// 3) output the implied code fragment
if (opid == mov) {
if (¶ms[1]->paramtype == variable) {
if ((¶ms[2]->paramtype == variable || ¶ms[2]->paramtype == pointer)) {
selectoutput (listout);
printstring (" ILLEGAL PARAMETER COMBINATION");
newline ();
printstring (" ILLEGAL ADDRESSING MODE for Intel assembler");
newline ();
printstring (" No INTEL instruction can have indirect pointers for both source and destination");
newline ();
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a ASSIGN var1,reg2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := ", ¶ms[2]->paramname)));
newline ();
}
stackvar (¶ms[1]->paramvalue);
if ((top->type == general || (top->type == integer || (top->type == byte || top->type == record)))) {
storereg (top, ¶ms[2]->paramvalue);
} else {
abort (concat ("Attempting to store reg ", concat (¶ms[2]->paramname, " in a non-integer variable")));
}
poprel ();
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have an ASSIGN var1,#const2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := #", itos (¶ms[2]->paramvalue, 0))));
newline ();
}
stackvar (¶ms[1]->paramvalue);
pushconst (¶ms[2]->paramvalue);
assign (1);
} else {
abort (concat ("Attempting to store unexpected type in variable ", ¶ms[1]->paramname));
}
} else if (¶ms[1]->paramtype == pointer) {
if ((¶ms[2]->paramtype == variable || ¶ms[2]->paramtype == pointer)) {
selectoutput (listout);
printstring (" ILLEGAL PARAMETER COMBINATION");
newline ();
printstring (" ILLEGAL ADDRESSING MODE for Intel assembler");
newline ();
printstring (" No INTEL instruction can have indirect pointers for both source and destination");
newline ();
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a STORE [reg ((+,-) offset)?],reg2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := &", ¶ms[2]->paramname)));
newline ();
}
dumpmr (opid, ¶ms[1]->paramvalue, ¶ms[1]->paramoffset, 0, ¶ms[2]->paramvalue);
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a STORE [reg ((+,-) offset)?],const2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := &", ¶ms[2]->paramname)));
newline ();
}
selectoutput (listout);
printstring (" EXPERIMENTAL IMPLEMENTATION");
newline ();
dumpmi (opid, ¶ms[1]->paramvalue, ¶ms[1]->paramoffset, 0, ¶ms[2]->paramvalue);
printstring (" NOT YET IMPLEMENTED");
newline ();
} else {
abort (concat ("Attempting to store unexpected type in variable ", ¶ms[1]->paramname));
}
} else if (¶ms[1]->paramtype == register) {
if (¶ms[2]->paramtype == variable) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a LOAD reg1,var2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := ", ¶ms[2]->paramname)));
newline ();
}
stackvar (¶ms[2]->paramvalue);
loadreg (top, ¶ms[1]->paramvalue);
poprel ();
} else if (¶ms[2]->paramtype == pointer) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a LOAD reg1,[reg2 ((+,-) offset)?] scenario");
newline ();
if (¶ms[2]->paramoffset == 0) {
printstring (concat (¶ms[1]->paramname, concat (" := [", concat (¶ms[2]->paramname, "]"))));
newline ();
} else {
printstring (concat (¶ms[1]->paramname, concat (" := [", concat (¶ms[2]->paramname, concat (itos (¶ms[2]->paramoffset, 0), "]")))));
newline ();
}
}
dumprm (opid, ¶ms[1]->paramvalue, ¶ms[2]->paramvalue, ¶ms[2]->paramoffset, 0);
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a MOVE reg1,reg2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := ", ¶ms[2]->paramname)));
newline ();
}
dumprr (opid, ¶ms[1]->paramvalue, ¶ms[2]->paramvalue);
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring ("We have a LOAD reg1,#const2 scenario");
newline ();
printstring (concat (¶ms[1]->paramname, concat (" := #", itos (¶ms[2]->paramvalue, 0))));
newline ();
}
pushconst (¶ms[2]->paramvalue);
loadreg (top, ¶ms[1]->paramvalue);
poprel ();
} else {
abort (concat ("Attempting to store unexpected type in register ", ¶ms[1]->paramname));
}
} else {
abort (concat ("Attempting to ", concat (instruction, " into non-variable/register location")));
}
} else if (opidx != (-(1))) {
if (¶ms[1]->paramtype == variable) {
if ((¶ms[2]->paramtype == variable || ¶ms[2]->paramtype == pointer)) {
selectoutput (listout);
printstring (" ILLEGAL PARAMETER COMBINATION");
newline ();
printstring (" ILLEGAL ADDRESSING MODE for Intel assembler");
newline ();
printstring (" No INTEL instruction can have indirect pointers for both source and destination");
newline ();
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " var1,reg2 scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))));
}
stackvar (¶ms[1]->paramvalue);
dumpmr (opid, top->base | top->scope, top->disp, top->extdisp, top->base);
poprel ();
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " var1,#const2 scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" #", itos (¶ms[2]->paramvalue, 0))))));
newline ();
}
stackvar (¶ms[1]->paramvalue);
stackvar (¶ms[1]->paramvalue);
pushconst (¶ms[2]->paramvalue);
operation (opidx);
assign (1);
} else {
abort (concat ("Opcode ", concat (instruction, concat (" is attempting to store unexpected type in variable ", ¶ms[1]->paramname))));
}
} else if (¶ms[1]->paramtype == pointer) {
if ((¶ms[2]->paramtype == variable || ¶ms[2]->paramtype == pointer)) {
selectoutput (listout);
printstring (" ILLEGAL PARAMETER COMBINATION");
newline ();
printstring (" ILLEGAL ADDRESSING MODE for Intel assembler");
newline ();
printstring (" No INTEL instruction can have indirect pointers for both source and destination");
newline ();
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " [reg1 ((+,-) offset)?],reg2 scenario")));
newline ();
if (¶ms[1]->paramoffset == 0) {
printstring (concat ("[", concat (¶ms[1]->paramname, "] := ")));
printstring (concat ("[", concat (¶ms[1]->paramname, concat ("] ", concat (opnamex, concat (" ", ¶ms[2]->paramname))))));
} else {
printstring (concat ("[", concat (¶ms[1]->paramname, concat (itos (¶ms[1]->paramoffset, 0), "] := "))));
printstring (concat ("[", concat (¶ms[1]->paramname, concat (itos (¶ms[1]->paramoffset, 0), concat ("] ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))))));
}
newline ();
}
dumpmr (opid, ¶ms[1]->paramvalue, ¶ms[1]->paramoffset, 0, ¶ms[2]->paramvalue);
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " [reg1 ((+,-) offset)?],const2 scenario")));
newline ();
if (¶ms[1]->paramoffset == 0) {
printstring (concat ("[", concat (¶ms[1]->paramname, "] := ")));
printstring (concat ("[", concat (¶ms[1]->paramname, concat ("] ", concat (opnamex, concat (" ", ¶ms[2]->paramname))))));
} else {
printstring (concat ("[", concat (¶ms[1]->paramname, concat (itos (¶ms[1]->paramoffset, 0), "] := "))));
printstring (concat ("[", concat (¶ms[1]->paramname, concat (itos (¶ms[1]->paramoffset, 0), concat ("] ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))))));
}
newline ();
}
selectoutput (listout);
printstring (" EXPERIMENTAL IMPLEMENTATION");
newline ();
dumpmi (opid, ¶ms[1]->paramvalue, ¶ms[1]->paramoffset, 0, ¶ms[2]->paramvalue);
printstring (" NOT YET IMPLEMENTED");
newline ();
} else {
abort (concat ("Attempting to store unexpected type in variable ", ¶ms[1]->paramname));
}
} else if (¶ms[1]->paramtype == register) {
if (¶ms[2]->paramtype == variable) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " reg1,var2 scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))));
newline ();
}
stackvar (¶ms[2]->paramvalue);
dumprv (opid, ¶ms[1]->paramvalue, top);
poprel ();
} else if (¶ms[2]->paramtype == pointer) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " reg1,[reg2 (('+','-')offset)?] scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))));
newline ();
}
selectoutput (listout);
printstring (" EXPERIMENTAL IMPLEMENTATION");
newline ();
dumprm (opid, ¶ms[1]->paramvalue, ¶ms[2]->paramvalue, ¶ms[1]->paramoffset, 0);
printstring (" NOT YET IMPLEMENTED");
newline ();
} else if (¶ms[2]->paramtype == register) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " reg1,reg2 scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" ", ¶ms[2]->paramname)))));
newline ();
}
dumprr (opid, ¶ms[1]->paramvalue, ¶ms[2]->paramvalue);
} else if (¶ms[2]->paramtype == number) {
if ((diagnose & mcodelevela) != 0) {
printstring (concat ("We have a ", concat (instruction, " reg1,const2 scenario")));
newline ();
printstring (concat (¶ms[1]->paramname, " := "));
printstring (concat (¶ms[1]->paramname, concat (" ", concat (opnamex, concat (" #", itos (¶ms[2]->paramvalue, 0))))));
newline ();
}
dumpri (opid, ¶ms[1]->paramvalue, ¶ms[2]->paramvalue);
} else {
abort (concat ("Opcode ", concat (instruction, concat (" is attempting to store unexpected type in register ", ¶ms[1]->paramname))));
}
} else {
abort (concat ("Opcode ", concat (instruction, concat (" is attempting to store in unexpected location ", ¶ms[1]->paramname))));
}
} else {
abort (concat ("Attempting to apply unknown opcode ", instruction));
}
} else {
abort (concat ("Opcode ", concat (instruction, concat (" has unexpected number ", concat (itos (paramscount, 0), "of parameters.")))));
}
if ((diagnose & mcodelevela) != 0) {
selectoutput (listout);
newline ();
printstring ("**** END CODE GEN ********");
newline ();
printstring ("**** END MCODE ****");
newlines (2);
}
}
// ******************************************
// --------------------------------------------------------------
// Code for ASSEMBLE starts here...
firstname = names;
firstlabel = labs;
procvar = decvar /* Pointer assignment */ ;
lastskip = (-(1));
oldframe = frame;
frame = 0;
events = 0;
evep = 0;
evfrom = 0;
if (amode >= 0) {
// NOT A RECORDFORMAT
level += 1;
if ((level > maxlevel && spec == 0))
abort ("Level");
worklist[level] = 0;
if (amode == 0) {
// %begin block
if (level == 1) {
// Initial %begin ?
blockname = programip;
// For stack traceback readability
externalid = programep;
// linkage to program entry
otype = external;
potype = otype;
} else {
strcpy (blockname, "%begin block");
}
staticalloc = enter ();
frame = (-((level * wordsize)));
// 1 word for every display entry
}
} else {
if (amode == (-(1))) {
// normal record format
procvar->pbase = parms;
// where our members start
} else {
if (amode == (-(2)))
frame = oldframe;
// alternates start at the current offset
}
maxframe = frame;
// start counting space here
}
// --- main compilation loop ---
for (;;) {
sym = pending;
readsymbol (pending);
if ((sym < 33 || sym > 127)) {
selectoutput (0);
printsymbol ('(');
write (sym, 1);
printsymbol (',');
write (pending, 1);
printsymbol (')');
abort ("Bad I Code");
}
goto *c[sym];
c_ '!': /* '!' */
operation (orx);
continue;
c_ '"': /* '"' */
comparedouble ();
continue;
c_ '#': /* '#' */
jumpforward (readtag (), ne);
continue;
c_ '$': /* '$' */
definevar (readtag (), getascii (','), readtagcomma (), readtagcomma (), readtag ());
continue;
c_ '%': /* '%' */
operation (xorx);
continue;
c_ '&': /* '&' */
operation (andx);
continue;
c_ '\\': /* '\\' */
inputstringvalue (readstring ());
continue; // Stack string constant
c_ '(': /* '(' */
jumpforward (readtag (), le);
continue;
c_ ')': /* ')' */
jumpforward (readtag (), ge);
continue;
c_ '*': /* '*' */
operation (mulx);
continue;
c_ '+': /* '+' */
operation (addx);
continue;
c_ '-': /* '-' */
operation (subx);
continue;
c_ '.': /* '.' */
operation (concx);
continue;
c_ '/': /* '/' */
operation (divx);
continue;
c_ ':': /* ':' */
definecompilerlabel (readtag ());
continue; // Define compiler label
c_ ';': /* ';' */
endofblock ();
break;
c_ '<': /* '<' */
jumpforward (readtag (), lt);
continue;
c_ '=': /* '=' */
jumpforward (readtag (), eq);
continue;
c_ '>': /* '>' */
jumpforward (readtag (), gt);
continue;
c_ '?': /* '?' */
comparevalues ();
continue; // Compare values
c_ '@': /* '@' */
stackvar (readtag ());
continue; // Stack variable descriptor
c_ 'A': /* 'A' */
init (readtag ());
continue; // Initialise OWN variable
c_ 'B': /* 'B' */
jumpbackward (readtag ());
continue; // Backward Jump
c_ 'C': /* 'C' */
compareaddresses ();
continue; // Compare addresses
c_ 'D': /* 'D' */
inputrealvalue (readreal ());
continue; // Stack real constant
c_ 'E': /* 'E' */
compilecall (top);
continue;
c_ 'F': /* 'F' */
jumpforward (readtag (), always);
continue; // Forward Jump
c_ 'G': /* 'G' */
getaliasvalue (readstring ());
continue; // Alias for item about to be declared
c_ 'H': /* 'H' */
compilebegin ();
continue; // Start of BEGIN block
c_ 'I': /* 'I' */
abort ("Pascal?");
// %continue; ! {ESCAPE for Pascal etc.}
c_ 'J': /* 'J' */
userjump (readtag ());
continue; // Jump to user label
c_ 'K': /* 'K' */
return (false);
continue; // %false
c_ 'L': /* 'L' */
defineuserlabel (readtag ());
continue; // Define user label
c_ 'M': /* 'M' */
return (map);
continue; // MAP result
c_ 'N': /* 'N' */
pushconst (readinteger ());
continue; // Stack integer constant
c_ 'O': /* 'O' */
updateline (readtag ());
continue; // Set line number
c_ 'P': /* 'P' */
plant ();
continue; // Machine code literal
c_ 'Q': /* 'Q' */
operation (rdivx);
continue;
c_ 'R': /* 'R' */
return (routine);
continue; // RETURN
c_ 'S': /* 'S' */
assign (1);
continue; // Normal value assignment
c_ 'T': /* 'T' */
return (true);
continue; // %true
c_ 'U': /* 'U' */
operation (negx);
continue;
c_ 'V': /* 'V' */
return (fn);
continue; // FN result
c_ 'W': /* 'W' */
switchjump (readtag ());
continue; // Jump to switch
c_ 'X': /* 'X' */
operation (expx);
continue; // 'Y' - UNUSED
c_ 'Z': /* 'Z' */
assign (0);
continue; // Assign address '=='
c_ '[': /* '[' */
operation (lshx);
continue;
c_ '\\': /* '\\' */
operation (notx);
continue;
c_ ']': /* ']' */
operation (rshx);
continue;
c_ '^': /* '^' */
setrecordformat (readtag ());
continue; // {Set Format}
c_ '_': /* '_' */
switchlabel (readtag ());
continue; // Define switch label
c_ 'a': /* 'a' */
arrayref (0);
continue;
c_ 'b': /* 'b' */
constantbounds ();
continue; // Define constant bounded Dope Vector
// 'c' NOT IMPLEMENTED
c_ 'd': /* 'd' */
dimension (readtagcomma (), readtag ());
continue; // dimensions, count of variables - NB in params: =0 -> simple array, # 0 -> array-in-record
c_ 'e': /* 'e' */
signalevent (readtag ());
continue; // %signal event
c_ 'f': /* 'f' */
compilefor (readtag ());
continue;
c_ 'g': /* 'g' */
dimension (readtagcomma (), readtag ());
continue; // (different to PSR) dimensions, count of variables - NB in params: =0 -> simple array, # 0 -> array-in-record
c_ 'h': /* 'h' */
// compiler op(n)
// compiler op(ReadTag)
continue;
c_ 'i': /* 'i' */
arrayref (1);
continue;
c_ 'j': /* 'j' */
assign (2);
continue; // JAM transfer
c_ 'k': /* 'k' */
jumpforward (readtag (), ff);
continue; // Branch on FALSE (= 0)
c_ 'l': /* 'l' */
languageflags = readtag ();
continue; // We currently only support standard IMP - who knows the future
c_ 'm': /* 'm' */
monitor ();
continue; // %monitor
c_ 'n': /* 'n' */
selectfield (readtag ());
continue; // Select member from record format
c_ 'o': /* 'o' */
eventtrap (readtagcomma (), readtag ());
continue; // %on %event block
c_ 'p': /* 'p' */
assign ((-(1)));
continue; // Pass a parameter
c_ 'q': /* 'q' */
doubleop (subx);
continue; // --
c_ 'r': /* 'r' */
resolve (readtag ());
continue;
c_ 's': /* 's' */
perm (stop, 0);
continue; // %stop
c_ 't': /* 't' */
jumpforward (readtag (), jne);
continue; // Branch on TRUE (# 0)
c_ 'u': /* 'u' */
doubleop (addx);
continue; // ++
c_ 'v': /* 'v' */
operation (absx);
continue;
c_ 'w': /* 'w' */
machinecode (getascii (';'));
continue; // JDM: allowed call to Machine code
c_ 'x': /* 'x' */
operation (rexpx);
continue;
c_ 'y': /* 'y' */
setcd (readtag (), diagnose);
continue; // %diagnose n (what about pass3? how do we send to pass3)
c_ 'z': /* 'z' */
setcd (readtag (), control);
continue; // %control n
c_ '{': /* '{' */
inparams = (-(1));
// this is either a record format, a procedure, or a proc spec;
// - block type was set by decvar to tell us which
assemble (blocktype, labs, names);
continue; // Start of formal parameters
c_ '}': /* '}' */
inparams = 0;
if (finishparams ())
break;
continue; // End of formal parameters
c_ '~': /* '~' */
if (alternateformat (readbyte ()))
break;
continue; // alternate record format
// AST 125541: DEFAULTCASE c
abort ("Bad I Code");
// %continue; ! To catch the sinners!! (that is - an unimplemented iCode)
}
if (amode >= 0) {
// end of declarative block
while (worklist[level] != 0) {
worklist[level] = retgptag (worklist[level]);
}
level -= 1;
} else {
// end of record format defn
if (amode == (-(2))) {
// end of alternative only
if (maxframe > frame)
frame = maxframe;
// use the longest alternative
oldframe = frame;
} else {
frame = (frame + align) & ((~(align)));
// **** temporary ****
procvar->size = frame;
}
}
frame = oldframe;
}
// assemble
// -------- it all starts here ---------
// JDM - Before we do any file I/O we need to get the source file name
// (as used to feed the 'source' stream)
char thesourcefilename[255 + 1];
selectinput (source);
thesourcefilename = inputname;
// JDM - ok, now we can really start
selectinput (icode);
selectoutput (objout);
&var[0] = 0;
// for %RECORD(*) . . . . .
parms = maxvars;
// Initialise the GP Tag ASL
for (i = 1; i <= maxgp; i += 1) {
&gptags[i]->link = i - 1;
}
gpasl = maxgp;
// Tell the linker our source file name
dumpsourcename (thesourcefilename);
// JDM - hopefully not so bogus now!
// predefine the perms for the linker. We ignore
// the number (j) because we know they are in sequence
for (i = 1; i <= lastperm; i += 1) {
j = externalref (permname[i]);
}
readsymbol (pending);
// Prime SYM/NEXT pair
spec = 0;
decvar = (&begin) /* Pointer assignment */ ;
assemble ((-(3)), 0, 0);
// We flush constants
flushcot ();
flushdata ();
flushswitch ();
}