! 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
include "crc32.imp"
begin
! debugging assistance
routinespec checksum(string(255) which)
integer outstream = 0
routine errout
outstream = output stream
select output(0)
end
routine undo
select output(outstream)
end
!SIZE CONSTANTS
constinteger max vars = 1024
constinteger max stack = 16
constinteger max labs = 50
constinteger max level = 16
constinteger Max GP = 120
! SOME WEE ENVIRONMENTAL THINGS
conststring(12) program ip = "Main Program"; ! Main program internal name
conststring(8) program ep = "__impmain"; ! Main program external name
conststring(5) system prefix = "_imp_"; ! prefixed to %system routine idents
! I/O file handles
constinteger icode = 1
constinteger source = 2
constinteger report = 0
constinteger objout = 1
constinteger listout = 2
!DIAGNOSE BITS
constinteger passId = 2; ! JDM Identify which IMP pass this is
constinteger mcode level D = (1<<13); ! JDM peak level D debug diagnostics of Machine Code
constinteger mcode level C = (1<<12); ! JDM next level C debug diagnostics of Machine Code
constinteger mcode level B = (1<<11); ! JDM next level B debug diagnostics of Machine Code
constinteger mcode level A = (1<<10); ! JDM base level A debug diagnostics of Machine Code
!CONTROL BITS
constinteger check capacity = 1
constinteger check unass = 2
constinteger check array = 4
constinteger check bits = check array; ! The only one that does anything so far
!REGISTERS - basic register number = actual value + 1
constinteger AX = 1
constinteger CX = 2
constinteger DX = 3
constinteger BX = 4
constinteger SP = 5
constinteger BP = 6
constinteger SI = 7
constinteger DI = 8
! Floating point coprocessor stack registers
constinteger FR0 = 9
!%constinteger FR1 = 10
!%constinteger FR2 = 11
!%constinteger FR3 = 12
!%constinteger FR4 = 13
!%constinteger FR5 = 14
!%constinteger FR6 = 15
constinteger FR7 = 16
! 8 bit registers - actual value + 17
constinteger AL = 17
constinteger CL = 18
constinteger DL = 19
constinteger BL = 20
constinteger AH = 21
constinteger CH = 22
constinteger DH = 23
constinteger BH = 24
! Pseudo Registers
constinteger any = 25 ; ! Truly any register
constinteger anyg = 26 ; ! A "General Purpose" byte accessible register (AX, BX, CX, DX)
constinteger anyp = 27 ; ! A pointing register (BX, SI, DI)
constinteger anyf = 28 ; ! Generally means the top of the 8087 stack
!DATA FORMS
! EXTERNAL FORM
constinteger simple = 1
constinteger name = 2
constinteger label = 3
constinteger recordformat = 4
constinteger switch = 6
constinteger array = 11
constinteger arrayname = 12
constinteger namearray = 13
constinteger namearrayname = 14
! INTERNAL
constinteger constant = 0
constinteger v in r = 1
constinteger av in r = 2
constinteger a in r = 3
constinteger v in s = 4
constinteger av in s = 5
constinteger a in s = 6
constinteger v in rec = 7
constinteger av in rec = 8
constinteger a in rec = 9
constinteger pgm label = 10
!DATA TYPES
constinteger general = 0
constinteger integer = 1
constinteger real = 2
constinteger string = 3
constinteger record = 4
! Private internal derived types
constinteger byte = 5
constinteger lreal = 6
! SIZE OF EACH OF THOSE TYPES IN BYTES
constbyteintegerarray vsize(general:lreal) = 0,4,4,0,0,1,8
! Define type codes known externally (to pass 3 and user):
constbyteintegerarray gen map(general:lreal) =
0, 1, 2, 3, 4, 6, 8
! GENERIC STORE ALIGNMENT - ASSUME 80386
constinteger align = 3
constinteger wordsize = 4; ! in bytes
!OWN INFO
constinteger own = 1
constinteger con = 2
constinteger external = 3
constinteger system = 4
constinteger dynamic = 5
constinteger primrt = 6
constinteger permrt = 7
{Procedure end codes}
constinteger Map = -2,
Fn = -1, {negative implies stacked result}
Routine = 0,
True = 1,
False = 2
! PERM ROUTINE INDEXES
constinteger iexp = 1; ! Integer Exponent
constinteger fexp = 2; ! floating exponent
constinteger smove = 3; ! string copy (length checked)
constinteger sjam = 4; ! string copy (whatever fits)
constinteger sconc = 5; ! string concatenate (length checked)
constinteger sjconc = 6; ! concatenate whatever fits
constinteger sresln = 7; ! string resolution
constinteger scomp = 8; ! string compare
constinteger aref = 9; ! array access
constinteger adef = 10; ! array definition
constinteger signal = 11; ! %signal
constinteger stop = 12; ! %stop
constinteger lastperm = stop
! and the corresponding linkage names for the perms
const string(12)array permname(1:lastperm)=
"_IMPIEXP",
"_IMPFEXP",
"_IMPSTRCPY",
"_IMPSTRJAM",
"_IMPSTRCAT",
"_IMPSTRJCAT",
"_IMPSTRRES",
"_IMPSTRCMP",
"_IMPAREF",
"_IMPADEF",
"_IMPSIGNAL",
"_IMPSTOP"
! Compiler Internal Operations (not to be confused with OpCodes)
constinteger ADDx = 1
constinteger SUBx = 2
constinteger MULx = 3
constinteger DIVx = 4
constinteger CONCx = 5
constinteger ANDx = 6
constinteger ORx = 7
constinteger XORx = 8
constinteger LSHx = 9
constinteger RSHx = 10
constinteger REMx = 11
constinteger EXPx = 12
constinteger REXPx = 13
constinteger RDIVx = 14
constinteger NOTx = 15
constinteger NEGx = 16
constinteger ABSx = 17
constinteger unaries = 15
! opcode indexes...
! simple (no operand) ones first
constinteger NOP = 0
constinteger CWD = 1
constinteger RET = 2
constinteger SAHF = 3
constinteger LEAVE = 4
! simple unary math functions
constinteger DEC = 5
constinteger INC = 6
constinteger NEG = 7
constinteger NOT = 8
! simple unary moves
constinteger POP = 9
constinteger PUSH = 10
! two operand moves
constinteger LEA = 11
constinteger MOV = 12
constinteger XCHG = 13
! simple two operand math functions
constinteger ADC = 14
constinteger ADD = 15
constinteger AND = 16
constinteger CMP = 17
constinteger OR = 18
constinteger SUB = 19
constinteger XOR = 20
! slightly more complicated two operand math
constinteger SHL = 21
constinteger SHR = 22
constinteger IDIV = 23
constinteger IMUL = 24
! calls and jumps
constinteger CALL = 25
constinteger JE = 26
constinteger JNE = 27
constinteger JG = 28
constinteger JGE = 29
constinteger JL = 30
constinteger JLE = 31
constinteger JA = 32
constinteger JAE = 33
constinteger JB = 34
constinteger JBE = 35
constinteger 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
constinteger FILD = 37
constinteger FLDD = 38
constinteger FLDQ = 39
constinteger FSTI = 40
constinteger FSTD = 41
constinteger FSTQ = 42
constinteger FADD = 43
constinteger FSUB = 44
constinteger FSUBR = 45
constinteger FMUL = 46
constinteger FDIV = 47
constinteger FDIVR = 48
constinteger FCMP = 49
constinteger FCHS = 50
constinteger FABS = 51
! Special floating point things
constinteger FSTSW = 52
constinteger FLDZ = 53
constinteger FLDPI = 54
! modifiers to memory base for accessing global memory
constinteger DATA = 16_10
constinteger COT = 16_20
constinteger BSS = 16_30
constinteger DISPLAY = 16_40
constinteger EXT = 16_50
constinteger SWT = 16_60
constinteger CODE = 16_70
{Condition codes}
{ The "Never" test should never! be used. The others are all used }
constinteger EQ = 1, LT = 2, GT = 4, TT = 8, Always = 7,
NE = 6, LE = 3, GE = 5, FF = 9, Never = 0
constbytearray Reverse(Never:FF) = Never {Never},
EQ {EQ},
GT {LT},
GE {LE},
LT {GT},
LE {GE},
NE {NE},
Always {Always},
TT {TT},
FF {FF}
constbytearray Negated(Never:FF) = Always {Never},
NE {EQ},
GE {LT},
GT {LE},
LE {GT},
LT {GE},
EQ {NE},
Never {Always},
FF {TT},
TT {FF}
constbytearray TestToOp(Never:FF) = JMP {Never - This is added for completeness},
JE {EQ},
JL {LT},
JLE {LE},
JG {GT},
JGE {GE},
JNE {NE},
JMP {Always},
JNE {TT},
JE {FF}
constbytearray TestToUnsignedOp(Never:FF) = JMP {Never - This is added for completeness},
JE {EQ},
JB {LT},
JBE {LE},
JA {GT},
JAE {GE},
JNE {NE},
JMP {Always},
JNE {TT},
JE {FF}
! Standard IMPish data structures
! Variables are declared here
! JDM JDM added idname to remember the IMP variable names
recordformat varfm( string(255) idname, byteinteger type, form, level, scope, dim, integer disp, format, size, pbase, extra, extdisp )
record(varfm)array var(0:max vars)
record(varfm)name decvar
record(varfm) begin
! The compiler is stack based
! JDM JDM added idname to remember the IMP variable name
recordformat stackfm(string(255) idname, byteinteger type, form, aform, base, scope, dim, integer disp, format, size, pbase, extra, extdisp, var no)
record(stackfm)array stack(1:max stack)
record(stackfm) null
record(stackfm)name 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
recordformat LabelFm(integer id, tag)
record(LabelFm)array Labels(1:Max Labs)
integer J Tag; ! most recent Jump tag translation - needed when planting event blocks
! Status of registers
ownintegerarray activity(0:fr7) = 0, 0, 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
owninteger claimed = 0
! Pointer registers may be pointing to non-local display - we remember
! them for future use
ownintegerarray displayhint(AX:DI) = 0, 0, 0, 0, 0, 0, 0, 0
! Math Co-processor uses a stack - we remember where it should be
! with this pointer
owninteger fpustack = 0
! A general purpose workspace resource
recordformat gp tag(integer info, addr, flags, link)
record(gptag)array gptags(0:Max GP)
integer gp asl;
owninteger control = check bits; ! Current compiler flags (set by %control statement)
owninteger diagnose = 0; ! Current diagnostic flags (set by %diagnose statement)
owninteger Language Flags = 0; ! Special directive flags for languages (other than standard imp)
owninteger nextcad = 0; ! notional code address (not real - pass3 shuffles stuff)
owninteger level = 0; ! current contextual level
integer sym, Pending; ! CODE SYMBOL, NEXT SYMBOL
integer vlb,vub; ! VECTOR LOWER/UPPER BOUND
owninteger current line = 0; ! SOURCE LINE NUMBER
owninteger stp = 0; ! STACK POINTER
integer data size; ! CURRENT DATA ITEM SIZE
owninteger frame = 0; ! LOCAL STACK FRAME EXTENT
integer parms; ! START OF PARAMETER STACK
owninteger invert = 0; ! CONDITION INVERSION FLAG
owninteger compare unsign = 0; ! CONDITION WAS NON-STANDARD (GENERALLY FPU COMPARE)
owninteger uncond jump = 0; ! ADDRESS OF CODE HOLE
owninteger block type = 1; ! -1 = RECORDS, 1 = PROCEDURE, 2 = SPEC
owninteger in params = 0; ! NON-ZERO INSIDE PARAMETER LISTS
integer otype, owntype, ownform; ! Information about OWNs currently being declared
integer spec, potype; ! More about current declaration
integer i, j; ! used in the initialisation loops only
owninteger Fp Result Loc = -1; ! Place to store Real and LReal function results
constinteger max switch = 1000; ! Size in WORDS of switch segment table
integerarray swtab(0:max switch)
owninteger swtp = 0; ! pointer to next switch segment entry
ownstring(255) external id = "",
alias = "",
block name = ""
byteintegerarray current string(0:255); ! current string literal
integer xlen
byteintegerarray x sym buff(0:255); ! current external string name
! WORK List - used to optimise use of temporary storage
! There is a head of list for each contextual level
ownintegerarray worklist(1:max level) =
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
longreal rvalue; ! floating point value for constants and initialisers
owninteger ownval = 0; ! value to use when initialising OWNs
!-----------------------------------------------------------
! Start with machine independent utility functions and stack
! manipulation and debug
!-----------------------------------------------------------
! >> SHOW <<
routine show(record(stackfm)name v)
! JDM The field widths have been tweaked to align columns
write(v_varno,4)
print string(" : Typ="); write(v_type,1)
print string(" Frm="); write(v_form,1)
print string(" Bse="); write(v_base,3);
print string(" Dsp="); write(v_disp,5)
print string(" ExtDsp="); write(v_extdisp,4)
print string(" Siz="); write(v_size,3)
print string(" Xtr="); write(v_extra,3)
print string(" Fmt="); write(v_format,2)
print string(" Dim="); write(v_dim,1)
print string(" Pba="); write(v_pbase,4)
if (length(v_idname) # 0)start
print string(" Name='".v_idname."'") { JDM show the variable name also }
finish
newline
end
! Simple ABORT routine
routine abort(string(255) message)
integer j
select output(report)
printstring("Pass 2 abandoned at line ");
write(current line, 1);
printstring(" : ");
printstring(message)
newline
if stp # 0 start
print string("STACK:"); newline
spaces(11) and show(stack(j)) for j = 1,1,stp
finish
stop
end
! >> WARN <<
routine warn(integer n)
switch w(1:8)
select output(report)
print string("*WARNING: line")
write(current line, 1); print string(": ")
-> w(n)
w(1): print string("division by zero"); -> at
w(2): print string("Illegal FOR"); -> at
w(3): print string("Non-local control variable?"); -> at
w(4): print string("Invalid parameter for READ SYMBOL"); -> at
w(5): print string("String constant too long"); -> at
w(6): print string("No. of shifts outwith 0..31"); -> at
w(7): print string("Illegal constant exponent"); -> at
w(8): print string("Numerical constant too big"); -> at
at: newline
select output(objout)
end
! >> MONITOR <<
routine monitor(record(stackfm)name v, string(15) text)
select output(report)
print string(text); print symbol(':')
spaces(10-length(text))
show(v)
select output(objout)
end
! >> GET GP TAG <<
integerfn get gp tag
integer l
if gp asl = 0 then abort("GP Tags")
l = gp asl
gp asl = gp tags(l)_link
result = l
end
! >> RET GP TAG <<
integerfn ret gp tag(integer index)
integer link
link = gp tags(index)_link
gp tags(index)_link = gp asl
gp asl = index
result = link
end
!------------------------------------------------------
! 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:
constinteger IF OBJ = 0; ! A - plain object code
constinteger IF DATA = 1; ! B - dataseg offset code word
constinteger IF CONST = 2; ! C - const seg offset code word
constinteger IF DISPLAY = 3; ! D - display seg offset code word
constinteger IF JUMP = 4; ! E - unconditional jump to label
constinteger IF JCOND = 5; ! F - cond jump to label JE, JNE, JLE, JL, JGE, JG
constinteger IF CALL = 6; ! G - call a label
constinteger IF LABEL = 7; ! H - define a label
constinteger IF FIXUP = 8; ! I - define location for stack fixup instruction
constinteger IF SETFIX = 9; ! J - stack fixup <location> <amount>
constinteger IF REQEXT = 10; ! K - external name spec
constinteger IF REFLABEL = 11; ! L - relative address of label (JDM JDM added new IBJ command)
constinteger IF REFEXT = 12; ! M - external name relative offset code word (call external)
constinteger IF BSS = 13; ! N - BSS segment offset code word
constinteger IF COTWORD = 14; ! O - Constant table word
constinteger IF DATWORD = 15; ! P - Data segment word
constinteger IF SWTWORD = 16; ! Q - switch table entry - actually a label ID
constinteger IF SOURCE = 17; ! R - name of the source file
constinteger IF DEFEXTCODE = 18; ! S - define a code label that is external
constinteger IF DEFEXTDATA = 19; ! T - define a data label that is external
constinteger IF SWT = 20; ! U - switch table offset code word
constinteger IF LINE = 21; ! V - line number info for debugger
constinteger IF ABSEXT = 22; ! W - external name absolute offset code word (data external)
routine writenibble(integer n)
n = n & 16_f;
if 0 <= n and n <= 9 start
printsymbol(n + '0');
else
printsymbol(n + ('A' - 10));
finish
end
! print a number in hexadecimal, to "places" size
routine write hex(integer n, places)
integer p, shift
shift = (places - 1) * 4
while shift > 0 cycle
p = n >> shift
writenibble(p)
shift = shift - 4
repeat
writenibble(n)
end
routine writeifrecord(integer type, integer length, byteintegerarrayname buffer)
integer c1, c2, i;
select output(objout)
printsymbol('A'+type);
if (length > 255) then abort("Intermediate file record too long");
writenibble(length>>4);
writenibble(length&15);
i = 0;
while (length > 0) cycle
c1 = buffer(i) >> 4;
c2 = buffer(i) & 15;
writenibble(c1);
writenibble(c2);
i = i + 1;
length = length - 1;
repeat
newline
end
! Simple buffered output of code bytes...
own integer objectptr = 0;
const integer objbufmax = 20
own byte integer array objectbytes(0:objbufmax);
! And corresponding bytes for the listing (not always the same for fudged opcodes)
own integer listptr = 0;
const integer lstbufmax = 11
own byte integer array listbytes(0:lstbufmax);
! routine to clean to object buffer
routine ClearObjectBuffer
integer i
for i = 0,1,objbufmax cycle
objectbytes(i) = 0
repeat
objectptr = 0;
end
! Routine to provide the address and hex opcode listing in the
! diagnostic output
routine listpreamble
integer i;
select output(listout)
space; writehex(nextcad, 4); space;
for i = 0, 1, 7 cycle
if i < listptr start
writehex(listbytes(i), 2)
space
else
spaces(3)
finish
repeat
spaces(8)
nextcad = nextcad + listptr;
listptr = 0;
end
! flush the code buffer
routine flushcode
if objectptr # 0 start
writeifrecord(IF OBJ, objectptr, objectbytes);
ClearObjectBuffer; ! clear the output pipe
finish
end
! puts a normal code byte into the listing and code pipes
routine putcodebyte(integer b)
objectbytes(objectptr) = b;
objectptr = objectptr + 1;
end
! puts a normal code byte into the listing and code pipes
routine putlistbyte(integer b)
listbytes(listptr) = b;
listptr = listptr + 1;
end
! puts a normal code byte into the listing and code pipes
routine putbyte(integer b)
putlistbyte( b );
putcodebyte( b );
end
! A very handy little boolean function, used for instructions
! with variable size immediate operands
integerfn issmall(integer i)
result = 1 if i < 128 and i > -128
result = 0;
end
! 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
routine modrmreg(integer reg1, integer reg2)
putbyte(16_C0 ! (reg1 << 3) ! (reg2));
end
! tags corresponding to linker directives...
const integer array reltag(0:6) =
0, { no relocation }
IF DATA, { dataseg offset code word }
IF CONST, { const seg offset code word }
IF BSS, { BSS relative code word }
IF DISPLAY, { display seg offset code word }
IF ABSEXT, { external name absolute offset code word }
IF SWT { switch table offset code word }
! plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
routine norelocateoffset( integer offset )
integer i;
for i=1,1,wordsize cycle
putbyte(offset & 255)
offset = offset >> 8
repeat
end
! plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
routine relocateoffset(integer reloc, integer offset, integer extdisp)
integer tag, i;
if reloc = 0 start
norelocateoffset( offset )
else
flushcode; ! so that only the offset is going into the queue
tag = reltag(reloc);
if tag = IF ABSEXT start
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,1,wordsize cycle
putbyte(offset & 255); offset = offset >> 8
repeat
writeifrecord(tag, wordsize, objectbytes);
ClearObjectBuffer; ! clear the queue
finish
finish
end
! plant a modrm reference where the rh operand is in memory
! Parameter REG1 is an actual register number, but BASE is an internal ID
routine modrmmem(integer reg1, integer base, integer disp, integer extdisp)
integer mod, reloc;
reloc = base>>4;
base = base & 15;
if base = 0 start; ! no register, just a displacement
! mod = 000, rm = 101
putbyte((reg1 << 3) ! 5);
relocateoffset(reloc, disp, extdisp );
else
if disp = 0 and base # BP start
mod = 0
else
if issmall(disp) # 0 start; ! fits in one byte
mod = 1
else
mod = 2
finish
finish
! unfortunately displacement (even zero) must be output in full if
! the offset is relocatable
if reloc # 0 then mod = 2;
if base > DI or base = SP start
abort("Internal address mode error");
finish
! Note - base-1 maps internal ID to real register
putbyte((mod << 6)!(reg1 << 3)!(base - 1));
if mod = 1 start
putbyte(disp);
else
if mod = 2 then relocateoffset(reloc, disp, extdisp )
finish
finish
end
const string(3) array regname(AX:DI) =
"EAX", "ECX", "EDX", "EBX", "ESP", "EBP", "ESI", "EDI"
const string(2) array reg8name(AL:BH) =
"AL", "CL", "DL", "BL", "AH", "CH", "DH", "BH"
const string(7) array relocname(0:6) =
"", "DATA", "COT", "BSS", "DISPLAY", "EXTERN", "SWTAB"
! Print the corresponding memory access string
! BASE is an internal ID, not an actual register number
routine printmemref(integer base, integer disp)
integer reloc;
reloc = base >> 4;
base = base & 15;
selectoutput(listout)
printsymbol('[');
if base # 0 start
printstring(regname(base));
if reloc # 0 start
printsymbol('+'); printstring(relocname(reloc));
finish
if disp # 0 then start
printsymbol('+') if disp > 0
write(disp,1)
finish
else
if reloc # 0 start
printstring(relocname(reloc)); printsymbol('+')
finish
writehex(disp, 4)
finish
printsymbol(']');
end
! opcodes
const string(5) array opname(NOP:JMP) =
"NOP", "CWD", "RET", "SAHF", "LEAVE",
"DEC", "INC", "NEG", "NOT",
"POP", "PUSH",
"LEA", "MOV", "XCHG",
"ADC", "ADD", "AND", "CMP", "OR", "SUB", "XOR",
"SHL", "SHR", "IDIV", "IMUL",
"CALL", "JE", "JNE",
"JG", "JGE", "JL", "JLE",
"JA", "JAE", "JB", "JBE", "JMP"
const byte integer array opvalue(NOP:JMP) =
16_90, 16_99, 16_C3, 16_9E, 16_C9,
16_FF, 16_FF, 16_F7, 16_F7,
16_8F, 16_FF,
16_8B, 16_89, 16_87, { LEA is fudged as if it were m <- r, to allow the flip }
16_11, 16_01, 16_21, 16_39, 16_09, 16_29, 16_31,
16_D1, 16_D1, 16_F7, 16_F7,
16_E8, 16_74, 16_75,
16_7F, 16_7D, 16_7C, 16_7E,
16_77, 16_73, 16_72, 16_76, 16_EB
! 8 bit equivalent opcodes
const byte integer array op8value(NOP:JMP) =
16_90, 16_99, 16_C3, 16_9E, 16_C9, { not 8 bit, included for completeness }
16_FE, 16_FE, 16_F6, 16_F6,
16_8F, 16_FF, { not 8 bit, included for completeness }
16_8B, 16_88, 16_86, { LEA is not applicable for 8 bit }
16_10, 16_00, 16_20, 16_38, 16_08, 16_28, 16_30,
16_D0, 16_D0, 16_F6, 16_F6,
16_E8, 16_74, 16_75,
16_7F, 16_7D, 16_7C, 16_7E,
16_77, 16_73, 16_72, 16_76, 16_EB { not 8 bit, included for completeness }
! An opcode with no operands (eg RET)
routine dumpsimple(integer opn)
putbyte(opvalue(opn));
listpreamble;
printstring(opname(opn));
newline
flushcode;
end
! A special bit of magic, used in record assignment
routine dumprepmovsb
putbyte(16_f3); ! rep
putbyte(16_a4); ! movsb
listpreamble;
printstring("REP MOVSB");
newline
flushcode;
end
! Used in record = 0 assignment
routine dumprepstosb
putbyte(16_f3); ! rep
putbyte(16_aa); ! stosb
listpreamble;
printstring("REP STOSB");
newline
flushcode;
end
! unary register operation - DEC, INC, NEG, NOT, POP, PUSH, IDIV, IMUL
! REG is an internal ID, not an actual register number
routine dumpur(integer opn, integer reg)
switch ops(DEC:IMUL) ; ! 5:24
displayhint(reg) = 0;
->ops(opn)
ops(DEC): putbyte(16_48 + reg - AX); ->break;
ops(INC): putbyte(16_40 + reg - AX); ->break;
ops(NEG): putbyte(16_F7); modrmreg(3, reg - AX); ->break;
ops(NOT): putbyte(16_F7); modrmreg(2, reg - AX); ->break;
ops(POP): putbyte(16_58 + reg - AX); ->break;
ops(PUSH): putbyte(16_50 + reg - AX); ->break;
ops(IDIV): putbyte(16_F7); modrmreg(7, reg - AX); ->break;
ops(IMUL): putbyte(16_F7); modrmreg(5, reg - AX); ->break;
break:
listpreamble;
printstring(opname(opn))
space
printstring(regname(reg));
newline
flushcode
end
! Plant code for a unary operation on memory
! BASE is an internal ID, not the actual register number
routine dumpum(integer opn, integer base, integer disp, integer extdisp)
switch ops(DEC:JMP)
->ops(opn)
ops(DEC): putbyte(16_FF); modrmmem(1, base, disp, extdisp); ->break;
ops(INC): putbyte(16_FF); modrmmem(0, base, disp, extdisp); ->break;
ops(NEG): putbyte(16_F7); modrmmem(3, base, disp, extdisp); ->break;
ops(NOT): putbyte(16_F7); modrmmem(2, base, disp, extdisp); ->break;
ops(POP): putbyte(16_8F); modrmmem(0, base, disp, extdisp); ->break;
ops(PUSH): putbyte(16_FF); modrmmem(6, base, disp, extdisp); ->break;
ops(IDIV): putbyte(16_F7); modrmmem(7, base, disp, extdisp); ->break;
ops(IMUL): putbyte(16_F7); modrmmem(5, base, disp, extdisp); ->break;
ops(JMP): putbyte(16_FF); modrmmem(4, base, disp, extdisp); ->break;
ops(CALL): putbyte(16_FF); modrmmem(2, base, disp, extdisp); ->break;
break:
listpreamble;
printstring(opname(opn))
printstring(" WORD "); ! otherwise it's ambiguous for the reader
printmemref(base, disp);
newline
flushcode;
end
! 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
routine dumpum8(integer opn, integer base, integer disp, integer extdisp)
integer base op, index
if opn = DEC or opn = INC start
base op = 16_FE
if opn = DEC then index = 1 else index = 0
else
if opn = NOT or opn = NEG start
base op = 16_F6
if opn = NOT then index = 2 else index = 3
else
Abort("Invalid UM8")
finish
finish
putbyte(base op)
modrmmem(index, base, disp, extdisp )
listpreamble;
printstring(opname(opn))
printstring(" BYTE "); ! otherwise it's ambiguous for the reader
printmemref(base, disp);
newline
flushcode;
end
! Plant a Memory <- Reg operation
! Both BASE and REG are internal ID's, not actual register numbers
routine dumpmr(integer opn, integer base, integer disp, integer extdisp, integer reg)
if opn = SHL start; ! special "shift by CL"
putbyte(16_D3);
modrmmem(4, base, disp, extdisp );
else
if opn = SHR start
putbyte(16_D3);
modrmmem(5, base, disp, extdisp );
else; ! normal stuff
putbyte(opvalue(opn));
modrmmem(reg - AX, base, disp, extdisp );
finish
finish
listpreamble;
printstring(opname(opn))
space
printmemref(base, disp);
printsymbol(',')
printstring(regname(reg));
newline
flushcode;
end
! Plant an 8 bit Memory <- Reg operation
! Both BASE and REG are internal ID's, not actual register numbers
routine dumpmr8(integer opn, integer base, integer disp, integer extdisp, integer reg)
if opn = SHL start; ! special "shift by CL"
putbyte(16_D2);
modrmmem(4, base, disp, extdisp );
else
if opn = SHR start
putbyte(16_D2);
modrmmem(5, base, disp, extdisp );
else; ! normal stuff
putbyte(op8value(opn));
modrmmem(reg - AL, base, disp, extdisp );
finish
finish
listpreamble;
printstring(opname(opn))
space
printmemref(base, disp);
printsymbol(',')
printstring(reg8name(reg));
newline
flushcode;
end
! Plant a 16 bit Reg <- Memory operation
! Both BASE and REG are internal ID's, not actual register numbers
routine dumprm(integer opn, integer reg, integer base, integer disp, integer extdisp)
! We optimise the fairly common instruction MOV AX,[disp] with
! the special short-form quirk of the 8086...
if reg = AX and opn = MOV and base & 15 = 0 start
putbyte(16_A1)
relocateoffset(base>>4, disp, extdisp)
else
displayhint(reg) = 0;
putbyte(opvalue(opn)+2);
modrmmem(reg - AX, base, disp, extdisp);
finish
listpreamble;
printstring(opname(opn))
space
printstring(regname(reg));
printsymbol(',')
printmemref(base, disp);
newline
flushcode;
end
! Plant an 8 bit Reg <- Memory operation
! Both BASE and REG are internal ID's, not actual register numbers
routine dumprm8(integer opn, integer reg, integer base, integer disp, integer 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;
end
! Plant a word Reg <- Reg operation
! Both register parameters are internal ID's
routine dumprr(integer opn, integer reg1, integer reg2)
displayhint(reg1) = 0;
if opn = SHL start; ! special "shift by CL"
putbyte(16_D3);
modrmreg(4, reg1 - AX);
else
if opn = SHR start
putbyte(16_D3);
modrmreg(5, reg1 - AX);
else; ! normal stuff
putbyte(opvalue(opn));
modrmreg(reg2 - AX, reg1 - AX);
finish
finish
listpreamble;
printstring(opname(opn))
space
printstring(regname(reg1));
printsymbol(',')
printstring(regname(reg2));
newline
flushcode;
end
routine dumprr8(integer opn, integer reg1, integer reg2)
if opn = SHL start; ! special "shift by CL"
putbyte(16_D2);
modrmreg(4, reg1 - AL);
else
if opn = SHR start
putbyte(16_D2);
modrmreg(5, reg1 - AL);
else
putbyte(op8value(opn));
modrmreg(reg2 - AL, reg1 - AL);
finish
finish
listpreamble;
printstring(opname(opn))
space
printstring(reg8name(reg1));
printsymbol(',')
printstring(reg8name(reg2));
newline
flushcode;
end
const byte integer array aximmediatevalue(NOP:XOR) =
0, 0, 0, 0, 0,
0, 0, 0, 0,
0, 0,
0, 16_B8, 0,
16_15, 16_05, 16_25, 16_3D, 16_0D, 16_2D, 16_35
! Register immediate operations - can be MOV, Math, or Shift
! The immediate operand may be a relocated offset as part of
! an address calculation
routine dumprioffset(integer opn, integer reg, integer reloc, integer immed, integer extdisp)
integer subop;
switch ops(MOV:SHR)
displayhint(reg) = 0;
reloc = reloc >> 4; ! because we pass around the or-able version
if reg = AX and opn <= XOR start
putbyte(aximmediatevalue(opn));
relocateoffset(reloc, immed, extdisp);
->break
else
->ops(opn)
finish
ops(MOV):
putbyte(16_B8 + reg - AX); relocateoffset(reloc, immed, extdisp ); ->break;
ops(ADD):
subop = 0
if issmall(immed) # 0 and reloc = 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp );
finish; ->break;
ops(ADC):
subop = 2
if issmall(immed) # 0 and reloc = 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp );
finish; ->break;
ops(CMP):
subop = 7
if issmall(immed) # 0 and reloc = 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp );
finish; ->break;
ops(SUB):
subop = 5
if issmall(immed) # 0 and reloc = 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp );
finish; ->break;
ops(AND):
subop = 4
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp ); ->break;
ops(OR):
subop = 1
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp ); ->break;
ops(XOR):
subop = 6
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed, extdisp ); ->break;
ops(SHL):
subop = 4
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1)
modrmreg(subop, reg - AX)
else
putbyte(16_C1)
modrmreg(subop, reg - AX)
putbyte(immed)
finish; ->break;
ops(SHR):
subop = 5
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1)
modrmreg(subop, reg - AX)
else
putbyte(16_C1)
modrmreg(subop, reg - AX)
putbyte(immed)
finish; ->break;
break:
listpreamble;
printstring(opname(opn))
space
printstring(regname(reg));
printsymbol(',')
if reloc # 0 start
printstring(relocname(reloc)); printsymbol('+')
finish
write(immed, 1)
newline
flushcode;
end
! Register immediate operations - can be MOV, Math, or Shift
routine dumpri(integer opn, integer reg, integer immed)
integer subop;
switch ops(MOV:SHR)
displayhint(reg) = 0;
if reg = AX and opn <= XOR start
putbyte(aximmediatevalue(opn));
norelocateoffset( immed );
->break
else
->ops(opn)
finish
ops(MOV):
putbyte(16_B8 + reg - AX); norelocateoffset( immed ); ->break;
ops(ADD):
subop = 0
if issmall(immed) # 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed );
finish; ->break;
ops(ADC):
subop = 2
if issmall(immed) # 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed );
finish; ->break;
ops(CMP):
subop = 7
if issmall(immed) # 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed );
finish; ->break;
ops(SUB):
subop = 5
if issmall(immed) # 0 start
putbyte(16_83);
modrmreg(subop, reg - AX);
putbyte(immed & 255);
else
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed );
finish; ->break;
ops(AND):
subop = 4
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed ); ->break;
ops(OR):
subop = 1
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed ); ->break;
ops(XOR):
subop = 6
putbyte(16_81);
modrmreg(subop, reg - AX);
norelocateoffset( immed ); ->break;
ops(SHL):
subop = 4
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1)
modrmreg(subop, reg - AX)
else
putbyte(16_C1)
modrmreg(subop, reg - AX)
putbyte(immed)
finish; ->break;
ops(SHR):
subop = 5
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1)
modrmreg(subop, reg - AX)
else
putbyte(16_C1)
modrmreg(subop, reg - AX)
putbyte(immed)
finish; ->break;
break:
listpreamble;
printstring(opname(opn))
space
printstring(regname(reg));
printsymbol(',')
write(immed, 1)
newline
flushcode;
end
! Memory (word) immediate operations - can be MOV, Math, or Shift
routine dumpmi(integer opn, integer base, disp, extdisp, integer immed)
integer subop;
switch ops(MOV:SHR)
->ops(opn)
ops(MOV):
putbyte(16_C7)
modrmmem(0, base, disp, extdisp )
norelocateoffset( immed ); ->break;
ops(ADD):
subop = 0
if issmall(immed) # 0 start
putbyte(16_83);
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255);
else
putbyte(16_81);
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed )
finish; ->break;
ops(ADC):
subop = 2
if issmall(immed) # 0 start
putbyte(16_83);
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255);
else
putbyte(16_81);
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed )
finish; ->break;
ops(CMP):
subop = 7
if issmall(immed) # 0 start
putbyte(16_83);
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255);
else
putbyte(16_81);
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed )
finish; ->break;
ops(SUB):
subop = 5
if issmall(immed) # 0 start
putbyte(16_83);
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255);
else
putbyte(16_81);
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed )
finish; ->break;
ops(AND):
subop = 4
putbyte(16_81)
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed ); ->break;
ops(OR):
subop = 1
putbyte(16_81)
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed ); ->break;
ops(XOR):
subop = 6
putbyte(16_81)
modrmmem(subop, base, disp, extdisp )
norelocateoffset( immed ); ->break;
ops(SHL):
subop = 4;
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1);
modrmmem(subop, base, disp, extdisp )
else
putbyte(16_C1);
modrmmem(subop, base, disp, extdisp )
putbyte(immed)
finish; ->break;
ops(SHR):
subop = 5
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D1);
modrmmem(subop, base, disp, extdisp )
else
putbyte(16_C1);
modrmmem(subop, base, disp, extdisp )
putbyte(immed)
finish; ->break;
break:
listpreamble;
printstring(opname(opn))
printstring(" WORD "); ! otherwise it's ambiguous for the reader
printmemref(base, disp);
printsymbol(',')
write(immed, 1)
newline
flushcode;
end
! Memory (8 bit) immediate operations - can be MOV, Math, or Shift
routine dumpmi8(integer opn, integer base, disp, extdisp, integer immed)
integer subop;
switch ops(MOV:SHR)
->ops(opn)
ops(MOV):
subop = 0
putbyte(16_C6)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(ADD):
subop = 0
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(ADC):
subop = 2
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(CMP):
subop = 7
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(SUB):
subop = 5
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(AND):
subop = 4
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(OR):
subop = 1
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(XOR):
subop = 6
putbyte(16_80)
modrmmem(subop, base, disp, extdisp )
putbyte(immed & 255); ->break;
ops(SHL):
subop = 4
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D0)
modrmmem(subop, base, disp, extdisp )
else
putbyte(16_C0)
modrmmem(subop, base, disp, extdisp )
putbyte(immed)
finish; ->break;
ops(SHR):
subop = 5
if immed = 1 start; ! special shift-by-one instruction
putbyte(16_D0)
modrmmem(subop, base, disp, extdisp )
else
putbyte(16_C0)
modrmmem(subop, base, disp, extdisp )
putbyte(immed)
finish; ->break;
break:
listpreamble;
printstring(opname(opn))
printstring(" BYTE "); ! otherwise it's ambiguous for the reader
printmemref(base, disp);
printsymbol(',')
write(immed, 1)
newline
flushcode;
end
! Finally, a catch-all that recasts operations using generic
! Var Stack structures
! Plant a 16 bit Reg <- Var operation
routine dumprv(integer opn, integer reg, record(stackfm)name v)
if v_form = V in R start
dumprr(opn, reg, v_base)
else
if v_form = V in S start
dumprm(opn, reg, v_base!v_scope, v_disp, v_extdisp )
else
if v_form = constant start
dumprioffset(opn, reg, v_scope, v_disp, v_extdisp )
else
abort("Address Mode")
finish
finish
finish
end
! Another special dumper - the only "Unary" operation that
! takes an immediate operand is PUSH
routine dumppushi(integer reloc, integer immed, integer extdisp )
reloc = reloc >> 4; ! because we pass around the or-able version
if reloc = 0 and is small(immed) # 0 start
putbyte(16_6A);
putbyte(immed & 255);
else
putbyte(16_68);
relocateoffset(reloc, immed, extdisp );
finish
listpreamble;
printstring("PUSH")
space
if reloc # 0 start
printstring(relocname(reloc)); printsymbol('+')
finish
write(immed, 1)
newline
flushcode
end
routine dumpvpush(record(stackfm)name v)
if v_form = V in R start
dumpur(PUSH, v_base)
else
if v_form = V in S start
dumpum(PUSH, v_base!v_scope, v_disp, v_extdisp )
else
if v_form = constant start
dumppushi(v_scope, v_disp, v_extdisp )
else
abort("Push Mode")
finish
finish
finish
end
!----------------------------------------------------------
! Floating point instructions - much simpler since there are
! only two forms - RR and RM
conststring(10)array flopname(FILD:FLDPI) =
"FILD", "FLD DWORD", "FLD QWORD", "FISTP",
"FSTP DWORD", "FSTP QWORD", "FADDP", "FSUBP",
"FSUBRP", "FMULP", "FDIVP", "FDIVRP",
"FCOMPP", "FCHS", "FABS",
"FSTSW AX", "FLDZ", "FLDPI"
! The prefix opcode
constbyteintegerarray flprefix(FILD:FLDPI) =
16_DB, 16_D9, 16_DD, 16_DB,
16_D9, 16_DD, 16_DE, 16_DE,
16_DE, 16_DE, 16_DE, 16_DE,
16_DE, 16_D9, 16_D9,
16_DF, 16_D9, 16_D9
! The function selector to put in the field in the second byte
! (or the second byte)
constbyteintegerarray flindex(FILD:FLDPI) =
16_00, 16_00, 16_00, 16_03,
16_03, 16_03, 16_C0, 16_E8,
16_E0, 16_C8, 16_F8, 16_F0,
16_D8, 16_E0, 16_E1,
16_E0, 16_EE, 16_EB
! Plant a Floating Point Reg <- Memory operation
! BASE is an internal ID, not actual register number
! Destination register is implicitly the stack top
routine dumpfloprm(integer opn, integer base, integer disp, integer extdisp )
if opn <= FLDQ start; ! a load type
fpu stack = fpu stack + 1
if fpu stack > 8 then abort("FPU Stack Overflow")
else
fpu stack = fpu stack - 1
if fpu stack < 0 then abort("FPU Stack Underflow")
finish
! 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;
end
! Plant a Floating Point Reg <- Reg operation
! Both register parameters are internal ID's that we
! convert to stack offsets
routine dumpfloprr(integer opn, integer reg1, integer reg2)
integer top
top = fpustack + (FR0 - 1)
if reg2 # top then abort("FPU Stack Address")
if opn < FCHS start; ! two operands - will pop one
fpu stack = fpu stack - 1
if opn = FCMP then fpu stack = fpu stack - 1; ! COMPP pops both registers
if fpu stack < 0 then abort("FPU Stack Underflow")
finish
! 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;
end
! Plant a "special" floating point operation
routine dumpflopspec(integer opn)
if opn >= FLDZ start; ! load a constant
fpu stack = fpu stack + 1
if fpu stack > 8 then abort("FPU Stack Overflow")
finish
! putbyte(16_9B); ! we prepend a WAIT to everything
putbyte(flprefix(opn));
putbyte(flindex(opn))
listpreamble
printstring(flopname(opn))
newline
flushcode
end
routine dumpjump(integer opn, integer 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 then putbyte(0);
listpreamble;
printstring(opname(opn))
space
{ JDM JDM }
if (opn = CALL) start
! See if we can show the routine name
printstring("'".top_idname."' (INTERNAL ")
printsymbol('L');
write(labelid,1)
printstring(" )")
else
printsymbol('L')
write(labelid,1)
finish
{ JDM JDM }
newline
ClearObjectBuffer; ! zap the current contents of the pipe
if (opn = JMP) start
putcodebyte(labelid & 255)
putcodebyte(labelid >> 8)
writeifrecord(IF JUMP, 2, objectbytes)
ClearObjectBuffer; ! zap the current contents of the pipe
finish else if (opn = CALL) start
! 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( 16_E8 ); ! call with relative address
writeifrecord(IF OBJ, 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(IF REFLABEL, 4, objectbytes);
ClearObjectBuffer; ! zap the current contents of the pipe
finish else start
! 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(IF JCOND, 3, objectbytes)
ClearObjectBuffer; ! zap the current contents of the pipe
finish
! finally, calls may trash registers...
if opn = CALL start
displayhint(BX) = 0
displayhint(SI) = 0
displayhint(DI) = 0
finish
end
! call the n'th external routine we've spec'ed
routine dumpextcall(integer 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) start
! This is an internal "perm" routine
! So, show the name
printstring("'".permname(labelid)."'")
else
! this is an external routine
printstring("'".top_idname."'")
finish
printstring(" (EXTERN ")
write(labelid, 1)
printstring(")")
newline
! JDM JDM
writeifrecord(IF REFEXT, wordsize, objectbytes);
! writeifrecord(IF REFEXT, 2, objectbytes);
ClearObjectBuffer; ! zap the current contents of the pipe
end
routine dumplabel(integer labelid)
select output(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(IF LABEL, 2, objectbytes);
ClearObjectBuffer; ! zap the current contents of the pipe
displayhint(BX) = 0
displayhint(SI) = 0
displayhint(DI) = 0
end
routine dumpstaticalloc(integer which, level, string(255)name name)
integer i, len
! we pretend to dump "C8 00 00 lev ENTER 0000,lev" but we actually plant a special pass 2 directive
putbyte(16_C8)
putbyte(16_00)
putbyte(16_00)
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 = length(name)
if len > 16 then len = 16
for i=1,1,len cycle
putcodebyte(charno(name,i))
repeat
writeifrecord(IF FIXUP, len+3, objectbytes);
ClearObjectBuffer; ! zap the current contents of the pipe
end
! 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
routine dumpstaticfill(integer which, size, events, evep, 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(IF SETFIX, 10, objectbytes);
ClearObjectBuffer; ! zap the current contents of the pipe
end
! dump words for the constant segment or the data segment
! Adjusts CAD so that the diagnostic listing looks sensible
routine dumpcdword(integer word, integer which)
integer tag, tmpcad, hi, lo
owninteger cptr = 0
owninteger dptr = 0
owninteger sptr = 0
tmpcad = next cad
if which = 2 start
tag = IF SWTWORD;
next cad = sptr; sptr = sptr + 2
else
if which = 1 start
tag = IF COTWORD;
next cad = cptr; cptr = cptr + 2
else
tag = IF DATWORD;
next cad = dptr; dptr = dptr + 2
finish
finish
hi = word >> 8
lo = word & 255
putbyte(lo);
putbyte(hi);
listpreamble;
printstring("db ")
writehex(lo, 2); printsymbol(','); writehex(hi, 2);
printstring(" ; ")
if lo > 32 and lo < 127 then printsymbol(lo) else printsymbol('.')
if hi > 32 and hi < 127 then printsymbol(hi) else printsymbol('.')
newline
writeifrecord(tag, 2, objectbytes);
ClearObjectBuffer; ! clear the pipe
nextcad = tmp cad; ! restore the real CAD
end
! tell the object file maker what source line we are on
byteintegerarray buffer(0:1); ! moved outside of dump line number to make accessible to checksum()
routine dump line number(integer line)
buffer(0) = (line & 255);
buffer(1) = (line >> 8);
writeifrecord(IF LINE, 2, buffer);
end
! utility to copy an IMP string into a simple buffer to
! pass to the IF Record routine
routine str to xsym(string(255)name s)
integer l
l = length(s)
xlen = 0
while xlen < l cycle
x sym buff(xlen) = charno(s, xlen+1)
xlen = xlen + 1
repeat
end
! tell the object maker the source file name
routine dumpsourcename(string(255) filename)
str to xsym(filename)
writeifrecord(IF SOURCE, xlen, x sym buff);
end
! Plant a request to the linker for the external name, and
! return an index number to refer to it with in future
integerfn externalref(string(255) extname)
owninteger nextextref=1
str to xsym(extname)
writeifrecord(IF REQEXT, xlen, x sym buff);
nextextref = nextextref + 1
result = nextextref - 1;
end
! tell the linker about an external definition
routine fill external(integer seg, offset, string(255) extname)
str to xsym(extname)
if seg = CODE start
writeifrecord(IF DEFEXTCODE, xlen, x sym buff);
else
writeifrecord(IF DEFEXTDATA, xlen, x sym buff);
! er, this doesn't actually work yet!
finish
end
!------------------------------------------------------
! 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.
!------------------------------------------------------
constinteger cot size = 2000
ownbyteintegerarray contable(0:cot size)
owninteger cotp = 0
owninteger cotoffset = 0; ! updated on a flush
routine flushcot
integer 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 cycle
dumpcdword((contable(i+1) << 8) ! contable(i), 1)
i = i + 2;
repeat
! Update the pointers
cotp = 0
cotoffset = cotoffset + i
! and send another hint
selectoutput(listout)
printstring(" CONST ENDS"); newline;
printstring(" _TEXT SEGMENT WORD PUBLIC 'CODE'"); newline
end
! return the offset in the const segment of a byte
! with value b
integerfn getcotb(byteinteger b)
integer i
i = 0
while i < cotp cycle
if contable(i) = b then result = i + cotoffset
i = i + 1
repeat
! value wasn't there
if cotp = cot size then flushcot
contable(cotp) = b
cotp = cotp + 1
result = (cotp - 1) + cotoffset
end
! return the offset in the const segment of a word
! with value w
integerfn getcotw(integer w)
integer i, cw
i = 0
while i < cotp-3 cycle
cw = contable(i)!(contable(i+1)<<8)!(contable(i+2)<<16)!(contable(i+3)<<24)
if cw = w then result = i + cotoffset
i = i + wordsize
repeat
! value wasn't there - first make sure there is space
if cotp > cot size-wordsize then flushcot
! now round off the COT
cotp = (cotp + align) & (¬align)
for i=1,1,wordsize cycle
contable(cotp) = w & 255
w = w >> 8
cotp = cotp + 1
repeat
result = (cotp - wordsize) + cotoffset
end
! return the offset in the const segment of double precision real number
integerfn getcotdouble(longreal double)
integer i
i = 0
while i < cotp-7 cycle
if contable(i) = byteinteger(addr(double)) c
and contable(i+1) = byteinteger(addr(double)+1) c
and contable(i+2) = byteinteger(addr(double)+2) c
and contable(i+3) = byteinteger(addr(double)+3) c
and contable(i+4) = byteinteger(addr(double)+4) c
and contable(i+5) = byteinteger(addr(double)+5) c
and contable(i+6) = byteinteger(addr(double)+6) c
and contable(i+7) = byteinteger(addr(double)+7) then result = i + cotoffset
i = i + 4
repeat
! value wasn't there - first make sure there is space
if cotp > cot size-8 then flushcot
! now round off the COT
cotp = (cotp + align) & (¬align)
for i=0,1,7 cycle
contable(cotp) = byteinteger(addr(double)+i)
cotp = cotp + 1
repeat
result = (cotp - 8) + cotoffset
end
! return the offset in the const segment of a quad word
! with value q0:q1:q2:q3 (lo to hi)
integerfn getcot4(integer q0, q1, q2, q3)
integer i, cw0, cw1, cw2, 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 cycle
cw3 = contable(i+12)!(contable(i+13)<<8)!(contable(i+14)<<16)!(contable(i+15)<<24)
if cw0 = q0 and cw1 = q1 and cw2 = q2 and cw3 = q3 then result = i + cotoffset
i = i + word size
cw0 = cw1
cw1 = cw2
cw2 = cw3
repeat
! value wasn't there - first make sure there is space
if cotp > cot size-16 then flushcot
! now round off the COT
cotp = (cotp + align) & (¬align)
for i=1,1,wordsize cycle
contable(cotp) = q0 & 255
q0 = q0 >> 8
cotp = cotp + 1
repeat
for i=1,1,wordsize cycle
contable(cotp) = q1 & 255
q1 = q1 >> 8
cotp = cotp + 1
repeat
for i=1,1,wordsize cycle
contable(cotp) = q2 & 255
q2 = q2 >> 8
cotp = cotp + 1
repeat
for i=1,1,wordsize cycle
contable(cotp) = q3 & 255
q3 = q3 >> 8
cotp = cotp + 1
repeat
result = (cotp - 16) + cotoffset
end
owninteger null string = -1
! get an index into the constant table for the string literal
! in the array s
integerfn getcots(byteintegerarrayname b)
integer i, first, slen, match;
slen = b(0)
! We optimise the Null String "" in comparisons, so we remember
! the location here
if slen = 0 start
null string = getcotb(0)
result = null string
finish
first = 0; ! offset to search in contable
while first + slen < cotp cycle; ! so long as there are that many bytes left
match = 1
! Simple check of string lengths
if slen # contable(first) start
match = 0
exit
finish
! ok, so lengths match but do the contents
for i = 1, 1, slen cycle
if b(i) # contable(first + i) start
match = 0
exit
finish
repeat
if match = 1 then result = first + cotoffset
first = first + 1; ! try the next solution
repeat
! if we get here, it wasn't already in the constant table
! Ok, so will we overflow the buffer
if (cotp + slen + 1) >= cot size then flushcot
! dump the string length
first = cotp
contable(cotp) = slen
cotp = cotp + 1
! Now, dump the string contents
for i = 1,1,slen cycle
contable(cotp) = b(i)
cotp = cotp + 1
repeat
result = first + cotoffset
end
!------------------------------------------------------
! 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...
!------------------------------------------------------
constinteger datat limit = 1999; ! Size in bytes of data segment table
byteintegerarray datat(0:datat limit)
owninteger datatp = 0; ! pointer to next data segment byte
owninteger datat offset = 0; ! updated on a flush
! Flush the accumulated data table
routine flush data
integer i, 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 - datat offset
while i < limit cycle
dumpcdword((datat(i+1) << 8) ! datat(i), 0)
i = i + 2;
repeat
datat offset = datat p
! and send another hint
selectoutput(listout)
printstring(" DATA ENDS"); newline
end
! >> GBYTE <<
! Simple byte in data segment
routine gbyte(integer n)
flush data if (datatp - datat offset) > datat limit
datat(datatp - datat offset) = n & 255;
datatp = datatp + 1
end
! >> GPUT <<
! Put a word into data segment
routine gput(integer n)
integer i
for i=1,1,wordsize cycle
gbyte(n)
n = n >> 8;
repeat
end
! >> GFIX <<
! round off the datasegment pointer for alignment
routine gfix(integer align)
gbyte(0) while datatp & align # 0
end
!-----------------------------------------------------
! 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
routine flush switch
integer i
select output(listout)
printstring(" ENDS"); newline
printstring(" _SWTAB SEGMENT WORD PUBLIC '_SWTAB'"); newline
i = 0
while i < swtp cycle
dumpcdword(swtab(i), 2)
i = i + 1
repeat
! and send another hint
selectoutput(listout)
printstring(" _SWTAB ENDS"); newline
end
!-------------------------------------------------------------
! Print the source code lines up to the indicated line
! number - these will interleave with the diagnostic assembly
! output
owninteger echoline = 0
routine echo source line
integer ch
owninteger source eof = 0
echoline = echoline + 1; ! update the count even if there's no input
if source eof # 0 then return; ! silently ignore lack of source file
select input(source)
select output(listout)
cycle
readsymbol(ch)
printsymbol(ch)
exit if ch = 10 or ch < 0
repeat
if ch < 0 then source eof = 1
select input(icode)
select output(objout)
end
!-----------------------------------------------------------
! General descriptor and register manipulation routines
!-----------------------------------------------------------
! >> FLOATING <<
integerfn floating(record(stackfm)name v)
! check descriptor for floating point quantity
result = 1 if v_type = real or v_type = lreal
result = 0
end
! >> ZERO <<
integerfn zero(record(stackfm)name v)
! CHECK DESCRIPTOR FOR (INTEGER) ZERO
result = 0 if v_disp # 0 or v_base # 0 or (v_form # constant and v_form # AV in S)
result = 1
end
! >> CONST <<
integerfn const(record(stackfm)name v)
! CHECK DESCRIPTOR FOR CONSTANT (INTEGER) VALUE
result = 0 unless v_form = constant
result = 0 if v_type > byte
result = 1
end
integerfn Min Record Size(record(stackfm)name A, B)
integer N, M
N = A_format; N = var(N)_size & 16_7FFF if N # 0
M = B_format; M = var(M)_size & 16_7FFF if M # 0
N = M if N = 0 or (M # 0 and M < N)
result = N if N > 0
Abort("Min Rec Size")
end
! >> MULSHIFT <<
integerfn mulshift(integer n)
integer shift, ref
ref = 1
for shift = 1, 1, 14 cycle
ref = ref<<1
if ref >= n start
if ref = n then result = shift else result = -1
finish
repeat
result = -1
end
! >> SAME <<
integerfn same(record(stackfm)name v,w)
! Test whether or not V and W describe the same object.
result = 0 if v_disp # w_disp or v_base # w_base
result = 0 if v_type # w_type or v_form # w_form
result = 0 if v_extra # w_extra or v_scope # w_scope
result = 1
end
! grab a slab of working store in the local stack
integerfn getwork(integer size)
integer cell;
cell = worklist(level);
while cell # 0 cycle
if gp tags(cell)_info = size and gp tags(cell)_flags = 0 start; ! suitable candidate?
gp tags(cell)_flags = 1; ! mark it as in use
result = gp tags(cell)_addr;
finish
cell = gp tags(cell)_link;
repeat
! no space available already - make more
cell = get gp tag
frame = (frame - size) & (¬align); ! make them all even boundaries
gp tags(cell)_addr = frame;
gp tags(cell)_info = size;
gp tags(cell)_link = worklist(level);
worklist(level) = cell;
gp tags(cell)_flags = 1; ! in use
result = frame;
end
! 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
routine Return Work(integer addr)
integer cell
cell = worklist(level);
while cell # 0 cycle
if gp tags(cell)_addr = addr start
if gp tags(cell)_flags = 0 then abort("Return Work")
gp tags(cell)_flags = 0; ! mark it as free
return
finish
cell = gp tags(cell)_link;
repeat
! Here, work area was not found - it probably wasn't a work area!
end
! 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
integerfn Is Work(record(stackfm)name v)
integer cell
if v_base # BP or v_disp >= 0 or v_scope # 0 or v_form # v in s then result = 0
cell = worklist(level);
while cell # 0 cycle
if gp tags(cell)_addr = v_disp start
if gp tags(cell)_flags = 0 then abort("Is Work")
if gp tags(cell)_info # 256 then result = 0
result = 1
finish
cell = gp tags(cell)_link;
repeat
result = 0
end
! >> RELEASE <<
routine release(integer reg)
! Hazard the value in a register
! abort("Release bad register") %if reg > fr7
return if reg = 0 or reg > fr7 or activity(reg) < 0; ! LOCKED
activity(reg) = activity(reg)-1
abort("Release inactive") if activity(reg) < 0
claimed = claimed - 1
end
! >> CLAIM <<
routine claim(integer reg)
! Cherish the value in a register
abort("Claim bad register") if reg > fr7
return if reg = 0 or activity(reg) < 0
activity(reg) = activity(reg)+1
claimed = claimed+1
end
! >> HAZARD <<
! Protect any value in register REG by storing in a temporary.
routine hazard(integer reg)
integer i, n, t, type
routine mod(record(stackfm)name v)
switch sw(0:a in rec)
v_base = BP
n = n-1
-> sw(v_form)
sw(a in rec):
sw(av in rec):
sw(v in rec):
sw(constant):
abort("Mod")
sw(v in s):
if v_disp = 0 and v_scope = 0 start
v_disp = t
v_form = a in s
else
! change (X in S) to (X in REC)
v_form = v_form + 3
v_extra = t
finish; -> out1
sw(a in s):
sw(av in s):
v_form = v_form + 3
v_extra = t; -> out1; ! change (X in S) to (X in REC)
sw(v in r):
v_form = v in s
v_disp = t
v_type = type; -> out1
out1:
end
n = activity(reg); return if n <= 0; ! NOT IN USE OR CLAIMED
claimed = claimed - n
activity(reg) = 0
if reg >= fr0 start
! 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 >= FPU Stack then hazard(reg+1); ! and recurse as required
type = lreal
t = getwork(8)
dumpfloprm(FSTQ, BP, t, 0)
else
type = integer
t = getwork(word size)
dumpmr(MOV, BP,t, 0, reg)
finish
for i = 1, 1, stp cycle
mod(stack(i)) if stack(i)_base = reg
repeat
abort("Usage Outstanding") if n # 0; ! USE STILL OUTSTANDING
end
! >> HAZARD ALL <<
routine hazard all
integer j
if claimed # 0 start; ! at least one register claimed
hazard(j) for j = AX,1,FR7
finish
end
! >> 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)
integerfn gpreg
integer r
! look for an empty one
for r = AX,1,BX cycle
result = r if activity(r) = 0
repeat
! look for an unlocked one
for r = AX,1,BX cycle
if activity(r) > 0 start
hazard(r)
result = r
finish
repeat
abort("Get Reg")
end
! >> PT REG <<
integerfn pt reg
! Get a register we can use as a pointer. We deliberately rotate
! around the candidates to make re-use more likely
constbyteintegerarray pt pref(0:2) =
7, 8, 4
! SI, DI, BX
owninteger next = 0
integer r,j
! look for an empty one
for j = 1,1,3 cycle
r = pt pref(next)
next = next+1; next = 0 if next = 3
result = r if activity(r) = 0
repeat
! look for an unlocked one
for j = 1,1,3 cycle
r = pt pref(j)
if activity(r) > 0 start
hazard(r)
result = r
finish
repeat
abort("Get PT Reg")
end
! >> GET DISPLAY <<
! return the register to use to access display level <n>
integerfn getdisplay(integer l)
integer r, lev
lev = l & 15; ! get rid of any relocation info
if lev = 0 then result = l; ! global
if lev = level then result = BP; ! local
! We now try the 3 pointer register - they are not contiguously
! numbered, which is why this is unrolled!
if displayhint(BX) = lev then result = BX
if displayhint(SI) = lev then result = SI
if displayhint(DI) = lev then result = DI
r = pt reg
dumprm(MOV, r, BP, -(lev * word size), 0 ); ! displays are first words in frame
displayhint(r) = lev
result = r
end
! >> 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.
integerfn set dope vector
integer t, dv
t = vub-vlb+1
dv = getcot4(1, vlb, vub, data size)
vub = t*data size; vlb = vlb*data size
result = dv
end
! >> PERM <<
! calls a PERM and adjusts the stack by SPACE words afterwards
routine perm(integer n, 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 then dumpri( ADD, SP, space * word size)
end
! >> ASSEMBLE <<
! AMODE:
! -3: initial call
! -2: alternate record format
! -1: record format
! 0: begin block
! 1: procedure
! 2: %spec
routine Assemble(integer amode, labs, names)
switch c(33:127)
record(varfm)name v; ! General purpose pointer
record(varfm)name procvar; ! Var of the current procedure we're compiling
record(varfm)name ap; ! Actual parameter ptr, used to copy parms to parm area
record(varfm)name fp; ! formal parameter ptr, used to copy parms to parm area
record(stackfm)name lhs; ! General stack pointer
record(stackfm)name rhs; ! General stack pointers
integer max frame; ! Used for alternate records to find the largest alternate
integer first name; ! First descriptor at this level
integer staticalloc; ! Tag used by pass 3 to fix up this level's stack allocation
integer skipproc, lastskip; ! Used to jump around routines
integer events, evep, evfrom; ! Event info (mask, entry point, block start)
integer First label; ! First label at this level
integer old frame; ! Previous level's static allocation
integer j, t
integer dv
routinespec compile to string(record(stackfm)name v)
routinespec loadreg(record(stackfm)name v, integer reg); ! JDM change name from load()
routinespec storereg(record(stackfm)name v, integer reg); ! JDM new code
routinespec assign(integer assop)
routinespec array ref(integer mode)
routinespec Operation(integer n)
routinespec compare(record(stackfm)name l,r)
routinespec test zero(record(stackfm)name v)
integerfnspec new tag
! 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 <<
integerfn ReadTag
integer s1, s2
s1 = Pending
readsymbol(s2)
readsymbol(Pending)
result = s1<<8!s2
end
integerfn ReadTagComma
integer t
t = ReadTag
readsymbol(Pending)
result = t
end
integerfn ReadInteger
integer s1, s2, s3, s4
s1 = Pending
readsymbol(s2)
readsymbol(s3)
readsymbol(s4)
readsymbol(Pending)
result = (s1<<24)!(s2<<16)!(s3<<8)!s4
end
integerfn ReadByte
integer s1
s1 = Pending
readsymbol(Pending)
result = s1
end
! >> 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
longrealfn ReadReal
integer n
longreal p, r
n = ReadTagComma; ! char count, skip comma
r = 0
! Start with the bit ahead of the decimal point
cycle
sym = Pending; read symbol(Pending)
exit if sym = '.'
n = n-1
-> power if sym = '@'
r = r*10+(sym-'0')
-> SIGN if n = 0
repeat
p = 1
cycle
n = n-1; -> SIGN if n = 0
sym = Pending; read symbol(Pending)
-> POWER if sym = '@'
p = p/10
r = r + (sym-'0')*p
repeat
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 start
! ok, non-zero exponent
if 0 < n < 32768 start
! positive exponent
while n > 0 cycle
r = r * 10
n = n - 1
repeat
else
! a negative exponent
! So, convert to negative value
n = n - 65536
! Now, attempt to update the float value
while n < 0 cycle
r = r / 10
n = n + 1
repeat
finish
finish
SIGN:
! sign of whole value
if Pending = 'U' start
read symbol(Pending)
r = -r
finish
result = r
end
string(255)function ReadString
integer J, Sym, Limit
string(255) s
Limit = Size of(s)-1
s = ""
for J = Pending, -1,1 cycle
Readsymbol(Sym)
s = s.Tostring(Sym) if Length(s) < Limit
repeat
Readsymbol(Pending)
result = s
end
string(255)function Get Ascii( integer terminator)
string(255) a
integer Sym
a = ""
cycle
sym = Pending; read symbol(Pending); exit if sym = terminator
if length( a ) # 255 start
a = a.to string(sym)
finish
repeat
result = a
end
! End of parsing routines
! >> DEFINE VAR <<
routine Define Var( integer decl, string(255) internal id, integer tf, size, scope )
integer type, form, format, s, new, round, dimension
integer dv; ! dope vector offset
owninteger prim no = 0
new = 0
round = align
! Get the var index
if decl = 0 start
! RECORD FORMAT ELEMENT NAME
parms = parms-1
abort("Def Var Parms") if parms <= names
decvar == var(parms)
decvar = 0
else
abort("Def Var Names (decl=".itos(decl,0)." parms=".itos(parms,0).")") if decl >= parms
decvar == var(decl)
if decl > names start
names = decl
new = 1
decvar = 0
finish
finish
! 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) and (size # 1) start
! INTEGER
type = byte and round = 0 if size = 2
size = vsize(type)
finish else if (type = real) start
! REAL
type = lreal if size = 4; ! LONG REAL
size = vsize(type)
finish else if (type = record) start
! record
format = size
decvar_format = format
size = var(format)_size if format <= names
finish else if (type = string) start
! string
round = 0
decvar_size = size
size = size + 1
else
size = vsize(type)
finish
! JDM JDM remember the variable name
! Needed should an embedded code fragment refer to an IMP variable
var(decl)_idname = internal id
decvar_size = size if type # string
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) start
! Set external linkage name if appropriate
if (otype >= external) start
if length(alias) # 0 start
external id = alias
finish else if (otype = system) start
external id = system prefix.internal id
else
external id = "_".internal id
finish
otype = external if otype <= dynamic
! external, system, dynamic
finish
finish
alias = ""
! JDM: Ensure the external displacement is zero
decvar_extdisp = 0
if (switch < form) and (form < array) start
! PROCEDURE
block type = 1 + spec; ! 1 for normal proc, 2 for spec
if (otype # 0) and (spec # 0) start
! external spec
if otype = primrt start
primno = primno + 1
decvar_level = 128
decvar_disp = prim no
return
finish
decvar_disp = externalref(external id)
decvar_extdisp = decvar_disp; ! JDM: Remember the base external displacement
decvar_level = 0
decvar_scope = EXT
return
finish
if (in params = 0) start
! NOT A PARAMETER
potype = otype
if new # 0 start
! NEW NAME
decvar_disp = new tag
! Procedure ID
finish
block name = internal id if spec = 0
return
finish
otype = 0
size = word size
data size = word size
! procedure parameter
else
! This is not a procedure declaration
data size = size
if (form # simple) start
Round = Align
if (type = general) start
! General %name
decvar_extra = in params; ! FOR LABELS
size = word size * 2
finish else if (form = array) or (form = name array) start
! We will fill in dimensions and allocate space when
! we are told the bounds later
size = 0
data size = word size if (form = name array)
finish else if (form = array name) or (form = name array name) start
decvar_dim = dimension
size = word size * 2
round = align; ! array header
else
size = word size; ! integer (etc) %name
finish
finish
finish
! Now deal with OWN (or const/extern/etc) data items
if (otype # 0) start
! OWN DATA
if (otype = con) start
! CONST INTEGER ETC.
data size = 0 if (type = string) and (form = simple); ! use actual size for plain strings
if (form = name) or (form = arrayname) or (form = namearrayname) start
otype = 0; ! Treat as special later
finish
else
! OWN, not CONST
gfix(round); ! so make it even if needed
finish
! set globals used by our data collection utilities
own type = type
own form = form
own type = integer and data size = word size if form = 2; ! %name's are really integers
if (spec = 0) start
if (form = array) or (form = name array) start
gfix(align)
dv = set dope vector; ! 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
finish
fill external(DATA, decvar_disp, external id) if otype = external
else
decvar_level = 0
decvar_scope = EXT
decvar_disp = external ref(external id)
! 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
finish
finish else if (form = label) start
!%label
decvar_disp = new tag
finish else if (form = switch) start
size = vub - vlb
if swtp + size > Max Switch then abort("Switch Table Full")
decvar_scope = SWT
decvar_disp = swtp - vlb
decvar_extra = set dope vector
for s = swtp, 1, swtp + size cycle
swtab(s) = 0; ! should really deal with undefined switch entries
repeat
swtp = swtp + size + 1
finish else if (form = record format) start
if (in params # 0) start
frame = decvar_size if decvar_size > frame
else
block type = -1; spec = -1
finish
finish else start
! Here we've got an ordinary local variable, parameter or record entry
decvar_level = level
if (in params = 0) start
! local variable
frame = (frame - size) & (¬round)
decvar_disp = frame
finish else if (block type > 0) start
! procedure parameters
frame = (frame + size + align) & (¬align); ! parameters are always word aligned
decvar_disp = frame; ! offset will be adjusted at '}'
finish else start
! records
frame = (frame + round) & (¬round)
decvar_disp = frame
frame = frame + size
decvar_level = 0; ! no base register
finish
finish
end; ! Define Var
!---------------------------------------------------------------------
! Stack manipulation routines
!---------------------------------------------------------------------
! >> POP STACK <<
! Pop the top of the stack
routine Pop Stack
if stp = 0 then abort("Pop")
monitor(top, "Pop") if diagnose&1 # 0
stp = stp - 1
if stp # 0 then top == stack(stp) else top == null
end
! >> POP REL <<
! Pop the top of the stack, and release its' register
routine pop rel
release(top_base)
pop stack
end
constbyteintegerarray fmap(0:15) =
0, v in s, a in s, pgm label, recordformat, 0, switch, 0,
{ void, simple, name, label, recordformat, ?, switch, routine, }
v in r, v in s, v in r, v in s, a in s, v in s, a in s, 0
{ function, map, predicate, array, arrayname, namearray, namearrayname, ? }
! >> 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.
routine Stack Var(integer var no)
record(varfm)name w
abort("Stack Var Idx") unless 0 <= var no and var no <= max vars
w == var(varno)
stp = stp + 1
if stp > Max Stack then abort("Push V Stack Overflow")
top == stack(stp)
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 start
if w_level = level then top_base = BP else top_base = w_level + 16
else
top_base = 0
finish
! 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
monitor(top, "Var stack") if diagnose&1 # 0
end
! >> PUSH COPY <<
! Push a duplicate of a stack record onto the stack
routine push copy(record(stackfm)name v)
stp = stp + 1
if stp > Max Stack then abort("Stack Copy")
top == stack(stp)
top = v
monitor(top, "Stack Copy") if diagnose&1 # 0
end
! >> PUSH CONST <<
! Push a constant on the stack
routine push const(integer n)
stp = stp + 1
if stp > Max Stack then abort("Stack Const")
top == stack(stp)
top = 0
top_disp = n
top_extdisp = 0
top_type = integer
top_form = constant
monitor(top, "push const") if diagnose&1 # 0
end
!---------------------------------------------------------------------
!STRING PROCESSING
!---------------------------------------------------------------------
! >> INPUT STRING VALUE<<
! Read a string literal from the iCode stream
routine Input String Value( string(255) s)
integer i
current string(0)= length(s)
for i = 1,1,length(s) cycle
current string(i) = charno(s,i)
repeat
! 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' and Pending # '$' start
otype = con; ! anonymous %const
push const( getcots(current string) );
top_type = string
top_base = 0;
top_scope = COT;
top_form = VinS;
top_format = current string(0)+1
else
push const(0); ! explicit string initialisation coming next
finish
end
routine Get Alias Value( string(255) s )
alias = s
end
routine Input Real Value( longreal r)
if r = 0 then start
push const(0)
else
if Pending # 'A' then start
otype = con; ! anonymous %const
push const(0)
top_type = lreal;
top_scope = COT;
top_disp = getcotdouble(r); ! N.B. ** %fn + side-effect **
top_extdisp = 0
top_form = v in s
finish
finish
rvalue = r
end
!-------------------------------------------------------
!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
integerfn new tag
owninteger free tag = 999
free tag = free tag + 1
result = free tag
end
! >> NEW LABEL <<
! Get the next available label database index
integerfn New Label
labs = labs+1; abort("Labels") if labs > Max Labs
result = labs
end
! >> FIND LABEL<<
! return the index in our label table of the Pass 1 label
integerfn Find Label(integer label)
integer lp
lp = labs
while lp # first label cycle
result = lp if labels(lp)_id = label
lp = lp-1
repeat
result = 0
end
! >> DEFINE LABEL <<
! This label is "here"
routine Define Label(integer label)
integer lp
record(labelfm)name l
lp = Find Label(label)
if lp = 0 start; ! Not yet been used
lp = New Label
l == labels(lp)
l_id = label
l_tag = new tag
else
l == labels(lp)
if l_tag & 16_8000 # 0 and label > 0 then l_tag = new tag
finish
dump label(l_tag)
l_tag = l_tag ! 16_8000
uncond jump = 0; ! You can get here
end; ! define label
! >> JUMP TO <<
! A wrapper for conditional jumps to labels that we're going
! to map into tags
routine Jump To(integer label, op, flag)
record(labelfm)name l
integer lp
lp = Find Label(label)
if lp = 0 start
lp = New Label
l == labels(lp)
l_id = label
l_tag = new tag
else
l == labels(lp)
if flag # 0 and l_tag & 16_8000 # 0 then l_tag = new tag
finish
! 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 & 16_7FFF
dump jump(op, JTag)
if op = JMP then uncond jump = nextcad
end; ! jump to
routine Jump Forward( integer val, test )
integer opr
! FF,TT tests need a value to compare
! TT == TRUE (#0)
! FF == FALSE (=0)
if (Test = FF) or (Test = TT) then 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 then start
if last skip # next cad then start
skip proc = new tag
dumpjump(opr, skip proc)
finish
else
! Check if we need to reverse the test
! So, re-choose the operator
if invert # 0 then Test = Reverse( Test )
invert = 0;
! convert the operators to unsigned versions if needed
if compare unsign # 0 then opr = TestToUnsignedOp( Test ) else opr = TestToOp( Test )
compare unsign = 0
jump to(val, opr, 1)
finish
end; ! Jump Forward
routine Jump Backward( integer val )
jump to(val, JMP, 0);
end
!-------------------------------------------------------
! 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
routine reduce(record(stackfm)name v)
integer type, form, disp, scope, 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 start
scope = v_scope
v_scope = 0
else
scope = 0
finish
v_disp = v_extra;
v_type = integer;
v_form = v in s
loadreg(v, anyp)
v_type = type;
v_form = form
v_disp = disp;
v_extdisp = extdisp;
v_scope = scope
end
! >> AMAP <<
! convert V into a descriptor for the address of V
routine amap(record(stackfm)name v)
integer f
constintegerarray addr map(0:15) =
{ 0, 1, 2, 3, 4, 5, 6, 7, }
-1, -2, -3, -4, AV in S, -5, V in S, AV in REC,
{ 8, 9, 10, 11, 12, 13, 14, 15 }
-6, V in REC, -7, -8, -9, -10, {PGM LABEL} -11, {record format} -12
! ABD - should be code here to deal with ADDR(pgm label)
f = addr map(v_form)
if f < 0 start
monitor(v, "AMAP target")
abort("AMAP")
finish
! Try to simplify some forms...
if v_disp = 0 and v_scope = 0 start
if (f = AV in S) start
if v_base = 0 then f = constant else f = V in R
finish else if (f = V in REC) or (f = AV in REC) start
! eliminate redundant LOAD
if (f = V in REC) then f = A in S else f = V in S
v_disp = v_extra
finish
finish
v_type = integer
v_form = f
end
! >> VMAP <<
! The inverse of AMAP: i.e. vmap(amap(x)) => x
routine vmap(record(stackfm)name v)
integer f, t
constintegerarray var map(0:8) =
{ 0, 1, 2, 3, 4, 5, 6, 7, 8 }
V in S, V in S, -1, -2, A in S, V in S, -3, A in REC, V in REC
if (v_form = A in S) or (v_form = A in REC) start
t = v_type
amap(v)
loadreg(v,anyp)
v_type = t
v_form = V in S
finish
f = var map(v_form)
v_form = f
abort("VMap") if f < 0
end; ! 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
routine address(record(stackfm)name v)
integer type, form
monitor(v, "ADDRESS") if diagnose&2 # 0
form = v_form
type = v_type
if form >= V in REC start
reduce(v)
form = v_form
finish
! Now pick up a base register if we needed one...
if v_base > 16 start
v_base = get display(v_base - 16)
claim(v_base)
finish
return if form = V in R or form = constant
if form = AV in S start
if v_base = 0 start
v_form = constant
else
if v_disp = 0 and v_scope = 0 start
v_form = V in R
else
loadreg(v, any)
finish
finish
return
finish
return if form = V in S
if form = A in S start
v_form = V in S
v_type = integer
loadreg(v,anyp)
v_type = type
v_form = V in S
v_disp = 0
finish
end; ! 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.
routine LoadReg(record(stackfm)name v, integer r)
switch f(0:9)
integer ptr, op
monitor(v, "LOAD") if diagnose&2 # 0
if r = anyf start
! 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 then loadreg(v, any)
if v_form = V in R start
return if v_base >= FR0
! This must be an integer in a CPU register - we need to store it
! before we can use it
v_disp = getwork(word size)
dumpmr(MOV, BP, v_disp, v_extdisp, v_base)
release(v_base)
v_base = BP
v_scope = 0
v_form = V in S
! Now it looks like an integer V in S
finish
if v_form = constant start; ! This is an integer constant
if v_disp = 0 start; ! We have a special instruction for zero
r = FR0 + FPU Stack
dumpflopspec(FLDZ)
v_base = r
claim(r)
v_disp = 0;
v_form = v in r
v_type = real
return
finish
! Otherwise, we need it in store
v_disp = getcotw(v_disp)
v_form = V in S
v_base = 0
v_scope = COT
finish
! Now everything that's left is a V in S
if v_type = integer start
op = FILD
else
if v_type = real start
op = FLDD
else
op = FLDQ
finish
finish
! register is going to be the top of stack
r = FR0 + FPU Stack
dumpfloprm(op, v_base!v_scope, v_disp, v_extdisp )
release(v_base)
v_base = r
claim(r)
v_disp = 0;
v_form = v in r
v_type = real
return
finish
! 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 start
if r = any then r = anyg
! What's more, there is only one register that is both a pointer
! and a legal byte destination
if r = anyp then r = BX
finish
! 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 then start
v_base = get display(v_base - 16)
claim(v_base)
finish
! Now go ahead and allocate a register
if r = any then start
! 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 and activity(v_base) = 1 and displayhint(v_base) = 0 start
r = v_base
else
r = gp reg
finish
else
if r = anyg then start
if 0 < v_base and v_base <= BX and activity(v_base) = 1 start
r = v_base
else
r = gp reg
finish
else
if r = anyp then start
if activity(v_base) = 1 and (v_base = BX or v_base = SI or v_base = DI) then start
r = v_base
else
r = pt reg
finish
else
!errout;printstring("Line 3583: r = ");write(r, 0);printstring(" v_base = ");write(v_base, 0);printstring(" (Note: reg code 3 is EDX)");newline;undo
if v_base = r start
if activity(r) > 1 start; ! 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
finish
else
hazard(r)
finish
finish
finish
finish
-> f(v_form)
f(v in rec):
reduce(v); ->f(v_form)
f(av in rec):
reduce(v); ->f(v_form)
f(a in rec):
reduce(v); ->f(v_form)
f(av in r): Abort("Unexpected Stack Form")
f(a in r): Abort("Unexpected Stack Form")
f(constant):
if v_disp = 0 and v_scope = 0 start
dumprr(XOR, r, r)
else
dumprioffset(MOV, r, v_scope, v_disp, v_extdisp )
finish
v_base = r
v_disp = 0
v_scope = 0
v_form = v in r
claim(r)
return
f(v in r):
return if v_base = r
dumprr(MOV, r, v_base)
release(v_base)
v_base = r
v_disp = 0
v_scope = 0
v_form = v in r
claim(r)
return
f(a in s):
! is the register a pointer?
if r = BX or r = SI or r = DI start
ptr = r
else
ptr = pt reg
finish
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 start
dumprm(MOV, r, v_base!v_scope, v_disp, v_extdisp )
else
if v_type = byte start
! watch out for register re-use here...
if r # v_base then 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 then dumpri(AND, r, 255); ! otherwise a more expensive clear later
v_type = integer
else; ! reals
abort("Load Real")
finish
finish
release(v_base)
v_base = r
v_disp = 0
v_scope = 0
v_form = v in r
claim(r)
return
f(v in s):
if v_type = integer start
dumprm(MOV, r, v_base!v_scope, v_disp, v_extdisp )
else
if v_type = byte start
! watch out for register re-use here...
if r # v_base then 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 then dumpri(AND, r, 255); ! otherwise a more expensive clear later
v_type = integer
else; ! reals
abort("Load Real")
finish
finish
release(v_base)
v_base = r
v_disp = 0
v_scope = 0
v_form = v in r
claim(r)
return
f(av in s):
if v_base # 0 start
dumprm(LEA, r, v_base!v_scope, v_disp, v_extdisp )
release(v_base)
v_type = integer
else
! else
if v_disp = 0 and v_scope = 0 start
dumprr(XOR, r, r)
else
dumprioffset(MOV, r, v_scope, v_disp, v_extdisp )
finish
finish
v_base = r
v_disp = 0
v_scope = 0
v_form = v in r
claim(r)
return
end; ! 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
routine Store Reg(record(stackfm)name lhs, integer reg)
if lhs_base = SP start; ! it's a push
if lhs_type = integer or lhs_type = byte start
dumpur(PUSH, reg)
finish
finish else if lhs_type = integer start
dumpmr(MOV, lhs_base!lhs_scope, lhs_disp, lhs_extdisp, reg)
finish else if lhs_type = byte start
dumpmr8(MOV, lhs_base!lhs_scope, lhs_disp, lhs_extdisp, reg+16)
finish else if lhs_type = record start
dumpmr(MOV, lhs_base!lhs_scope, lhs_disp, lhs_extdisp, reg)
finish
end; ! STORE REG
! >> OPERATION <<
! perform the operation OP on the top two elements of the stack.
! (single element for unary operators)
routine Operation(integer op)
record(stackfm)name lhs, rhs
integer assign pending, work, value, s
switch oper(1:17), roper(1:17), fold(1:17)
constintegerarray opmap(1:17) =
ADD, SUB, IMUL, IDIV, 0, AND, OR, XOR, SHL, SHR, IDIV, 0, 0, 0, NOT, NEG, 0
constintegerarray flopmap(1:17) =
FADD, FSUB, FMUL, FDIV, 0, 0, 0, 0, 0, 0, 0, 0, 0, FDIV, 0, FCHS, FABS
constintegerarray indec(-1:1) = DEC, 0, INC; ! decrement, and increment opcodes
routine swap
record(stackfm) temp
temp = lhs
lhs = rhs
rhs = temp
end
assign pending = 0
rhs == top
if op < Unaries then start
lhs == stack(stp-1)
if lhs_type = real or lhs_type = lreal or op >= REXPx then ->reals
finish
if rhs_type = real or rhs_type = lreal then ->reals
if rhs_form = constant and (op >= Unaries or lhs_form = constant) then ->fold(op)
! now look for optimisations for x = x <op> whatever
if Pending = 'S' or Pending = 'j' start; ! the next task is an assignment
if op >= Unaries start
if same(top, stack(stp-1)) # 0 then assign pending = 1
else
if same(lhs, stack(stp-2)) # 0 then assign pending = 1
finish
finish
->oper(op)
oper(NOTx):
oper(NEGx):
! we optimise for e.g. fred = -fred as one instruction
if assign pending # 0 then start
read symbol(Pending)
address(rhs)
if rhs_type = byte start
dumpum8(opmap(op), rhs_base!rhs_scope, rhs_disp, rhs_extdisp )
else
dumpum(opmap(op), rhs_base!rhs_scope, rhs_disp, rhs_extdisp )
finish
pop rel
pop rel
return
finish
loadreg(rhs, any)
dumpur(opmap(op), rhs_base)
return
! 8086 has no "abs" instructions, so we do a test and jump
oper(ABSx):
loadreg(rhs, any)
dumpri(CMP, rhs_base, 0)
work = new tag
dumpjump(JGE, work)
dumpur(NEG, rhs_base)
dumplabel(work)
return
oper(ADDX):
if lhs_form = constant then swap
! and fall through to minus
oper(SUBx):
! First look for fred = fred + <whatever>
! We can only safely do this for bytes if we're jamming or ignoring overflow
if (assign pending # 0) c
and ((lhs_type = integer) or ((control & check capacity) = 0) or (Pending = 'j')) then start
readsymbol(Pending) ; ! we will do the assignment ourselves
address(lhs) ; ! make LHS accessible
if rhs_form = constant then start
value = rhs_disp
if value # 0 start
if op = SUBx then value = -value
! look for increment or decrement instructions
if value < 2 and value > -2 then start
if lhs_type = byte start
dumpum8(indec(value), lhs_base!lhs_scope, lhs_disp, lhs_extdisp )
else
dumpum(indec(value), lhs_base!lhs_scope, lhs_disp, lhs_extdisp )
finish
else
if lhs_type = byte start
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)
finish
finish
finish
else; ! RHS not a constant
loadreg(rhs, any)
if lhs_type = byte start
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)
finish
finish
pop rel
pop rel
pop rel
return
finish
! So, there is no assign pending
if rhs_form = constant then start
value = rhs_disp
if op = SUBx then value = -value
! If it is already an address, do the math on the address offset
if lhs_form = avins or lhs_form = avinrec start
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 start; ! 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 and value > -2 then start
if value # 0 then dumpur(indec(value), lhs_base)
else
dumpri(opmap(op), lhs_base, rhs_disp)
finish
finish
finish
else; ! not a constant
if op = ADDx and rhs_form = v in r then swap; ! commutative, so flip it
loadreg(lhs, any)
if rhs_type = byte start
loadreg(rhs, any)
else
address(rhs)
finish
dumprv(opmap(op), lhs_base, rhs)
finish
pop rel; ! the RHS
return
oper(ANDx):
oper(ORx):
oper(XORx):
! Logical ops are a subset of ADD - similar behaviour, but no inc/dec/addr short forms
if lhs_form = constant then swap
! First look for fred = fred <op> <whatever>
if assign pending # 0 then start
readsymbol(Pending); ! we will do the assignment ourselves
address(lhs); ! make LHS accessible
if rhs_form = constant then start
value = rhs_disp
if lhs_type = byte start
warn(8) if rhs_disp & (¬255) # 0
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)
finish
else; ! RHS not a constant
loadreg(rhs, any)
if lhs_type = byte start
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)
finish
finish
pop rel; ! RHS
pop rel; ! LHS
pop rel; ! Assignment destination
return
finish
! So, there is no assign pending
if rhs_form = constant then start
value = rhs_disp
loadreg(lhs, any)
dumpri(opmap(op), lhs_base, value)
else; ! not a constant
if rhs_form = v in r then swap; ! all these are commutative, so flip it to make it easier
loadreg(lhs, any)
if rhs_type = byte and op = ANDx start; ! AND needs all the bits to make sense
loadreg(rhs, any); ! NB Load changes type to Integer
else
address(rhs)
finish
if rhs_type = byte start; ! 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)
finish
finish
pop rel; ! the RHS
return
oper(MULx):
if lhs_form = constant or rhs_base = AX then swap
if rhs_form = constant then start
value = rhs_disp
if value = 0 then start; ! mul by zero is zero
release(lhs_base)
lhs = rhs
pop stack
return
finish
if value = 1 then start; ! mul by 1 is the identity
pop stack
return
finish
s = mulshift(value); ! find a shift factor
if s > 0 then start
rhs_disp = s
op = LSHx
-> shift it
finish
! 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 = V in S
! and fall through to the not-a-constant path
finish
do mul:
loadreg(lhs, AX)
address(rhs)
hazard(DX)
if rhs_form = V in R start
dumpur(IMUL, rhs_base)
else
dumpum(IMUL, rhs_base!rhs_scope, rhs_disp, rhs_extdisp )
finish
pop rel
return
oper(DIVx):
oper(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 start
if rhs_disp = 0 then warn(1)
rhs_base = 0; rhs_scope = COT; rhs_disp = getcotw(rhs_disp)
rhs_form = V in S
finish
if rhs_form = V in R start
dumpur(IDIV, rhs_base)
else
dumpum(IDIV, rhs_base!rhs_scope, rhs_disp, rhs_extdisp )
finish
pop rel
if op = DIVx then start
lhs_base = AX
else
lhs_base = DX
release(AX)
claim(DX)
finish
return
oper(LSHx):
oper(RSHx):
shift it:
if (assign pending # 0) c
and ((op = RSHx) or (lhs_type = integer) or (control & check capacity = 0) or (Pending = 'j')) then start
readsymbol(Pending); ! we will do the assignment ourselves
address(lhs); ! make LHS accessible
if rhs_form = constant start
warn(6) unless 0 <= rhs_disp <= 31
if rhs_disp # 0 start; ! shift by zero is a no-op
if lhs_type = byte start
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)
finish
finish
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 start
hazard(CX)
address(rhs)
dumprm8(MOV, CL, rhs_scope!rhs_base, rhs_disp, rhs_extdisp )
else
loadreg(rhs,CX)
finish
if lhs_type = byte start
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)
finish
finish
pop rel; ! RHS
pop rel; ! LHS
pop rel; ! Assignment destination
return
finish
! deal with constant shifts first...
if rhs_form = constant then start
value = rhs_disp
warn(6) unless 0 <= value <= 31
if value # 0 start
loadreg(lhs, any)
dumpri(opmap(op), lhs_base, value)
finish
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 start
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)
finish
loadreg(lhs, any)
dumprr(opmap(op), lhs_base, CX);
finish
pop rel
return
oper(EXPx):
if rhs_form = constant then start
if rhs_disp = 0 start
pop rel
pop rel
push const(1)
return
finish
if rhs_disp = 1 then start
pop rel
return
finish
if rhs_disp = 2 then start
rhs = lhs
claim(rhs_base)
->do mul
finish
finish
loadreg(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
loadreg(lhs, any)
dumpur(PUSH, lhs_base)
release(lhs_base)
perm(iexp, 2)
lhs_base = AX; claim(AX)
lhs_form = V in R
return
oper(REXPx):
oper(RDIVx):
abort("Oper unexpected op")
!-----------------------------------------------
! Fold constant expressions at compile time
fold(NEGx):
value = -rhs_disp; -> set unary
fold(NOTx):
value = ¬rhs_disp; -> set unary
fold(ABSx):
value = rhs_disp; if value < 0 then value = -value; -> set value
fold(ADDx):
value = lhs_disp + rhs_disp; -> set value
fold(SUBx):
value = lhs_disp - rhs_disp; -> set value
fold(ORx):
value = lhs_disp ! rhs_disp; -> set value
fold(ANDx):
value = lhs_disp & rhs_disp; -> set value
fold(XORx):
value = lhs_disp !! rhs_disp; -> set value
fold(LSHx):
value = lhs_disp << rhs_disp; -> set value
fold(MULx):
value = lhs_disp * rhs_disp; -> set value
fold(RSHx):
value = lhs_disp >> rhs_disp; -> set value
fold(EXPx):
if rhs_disp < 0 then abort("Fold -ve Exp")
value = 1
for op=1, 1, rhs_disp cycle
value = value * lhs_disp
repeat
-> set value
fold(REMx):
fold(DIVx):
value = rhs_disp;
warn(1) and value = 1 if value = 0
value = lhs_disp // value
if op = DIVx then -> set value
value = lhs_disp - (rhs_disp * value)
-> set value
fold(REXPx):
abort("Fold REXPx - Not implemented")
fold(RDIVx):
abort("Fold RDIVx - Not implemented")
set value:
pop stack
set unary:
top_disp = value
return
fold(CONCx):
abort("Fold CONCx - Not implemented")
!--------------------------------------------------------------------
! String operations - the only one is concatenate...
oper(CONCx):
if assign pending # 0 start; ! It's S = S.T
amap(lhs)
loadreg(lhs, any)
dumpur(PUSH, lhs_base)
amap(rhs)
loadreg(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
pop rel
dumppushi(0, lhs_size, 0)
if Pending = 'S' then perm(sconc, 3) else perm(sjconc, 3)
! and finally, skip the pending assignment, and drop the LHS
readsymbol(Pending)
pop rel
return
finish
! 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 Is Work(lhs) = 0 start; ! Not a work area
work = getwork(256)
push const(work)
top_form = av in s
top_base = BP
loadreg(top, any)
dumpur(PUSH, top_base)
pop rel
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 = V in S
lhs_base = BP
lhs_disp = work
lhs_size = 255
finish
! 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
push copy(lhs)
amap(top)
loadreg(top, any)
dumpur(PUSH, top_base)
poprel
amap(rhs)
loadreg(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
dumppushi(0, lhs_size, 0)
perm(sconc, 3)
return
Reals:
if op < Unaries then loadreg(lhs, anyf)
if op # REXPx then loadreg(rhs, anyf)
->roper(op)
roper(NEGx):
roper(ABSx):
dumpfloprr(flopmap(op), rhs_base, rhs_base)
return
roper(ADDx):
roper(MULx):
! Commutative, so we don't care
if lhs_base > rhs_base then swap
dumpfloprr(flopmap(op), lhs_base, rhs_base)
pop rel
return
roper(SUBx):
roper(DIVx):
roper(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 start
swap
op = op + 1
finish
dumpfloprr(op, lhs_base, rhs_base)
pop rel
return
roper(REXPx):
! This is implemented as a PERM routine
loadreg(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
! 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 + (8//wordsize))
! Since rexp is actually a standard C routine, the result will
! be on the FPU stack
lhs_base = FR0; claim(FR0)
fpu stack = 1
lhs_form = V in R
lhs_type = lreal
return
roper(NOTx):
abort("NOTx: Unsupported Real Operation")
roper(ANDx):
abort("ANDx: Unsupported Real Operation")
roper(ORx):
abort("ORx: Unsupported Real Operation")
roper(XORx):
abort("XORx: Unsupported Real Operation")
roper(REMx):
abort("REMx: Unsupported Real Operation")
roper(LSHx):
abort("LSHx: Unsupported Real Operation")
roper(RSHx):
abort("RSHx: Unsupported Real Operation")
roper(EXPx):
abort("EXPx: Unsupported Real Operation")
end; ! Operation
! >> ASSIGN <<
! ASSOP = -1: parameter assignment
! 0: == assignment
! 1: = assignment
! 2: <- assignment
routine assign(integer assop)
record(stackfm)name lh,rh
record(stackfm) temp
integer n, p, form, 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
routine Store(record(stackfm)name lhs, rhs)
integer pt, s, op
if lhs_base = SP start; ! it's a push
if lhs_type = integer or lhs_type = byte start
if rhs_type = byte start
loadreg(rhs, any)
else
address(rhs)
finish
dumpvpush(rhs)
else; ! must be a real
if lhs_type = real start
s = 4
op = FSTD
else
s = 8
op = FSTQ
finish
loadreg(rhs, anyf)
pt = ptreg
dumpri(SUB, SP, s)
dumprr(MOV, pt, SP)
dumpfloprm(op, pt, 0, 0)
finish
return
finish
if lhs_type = integer start
if rhs_form = constant and rhs_scope = 0 start
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)
finish
else
if lhs_type = byte start
if rhs_form = constant and rhs_scope = 0 start
dumpmi8(MOV, lhs_base!lhs_scope, lhs_disp, lhs_extdisp, rhs_disp)
else
if rhs_type = byte start; ! try to avoid pointless promoting to an int
! We will reproduce a "Load" but without the word extension
address(rhs)
pt = gp reg
dumprm8(MOV, pt+16, rhs_base!rhs_scope, rhs_disp, rhs_extdisp )
release(rhs_base)
rhs_base = pt; rhs_form = V in R; rhs_type = Integer
claim(pt)
else
loadreg(rhs, any)
! ABD - should add a capacity check here
finish
dumpmr8(MOV, lhs_base!lhs_scope, lhs_disp, lhs_extdisp, rhs_base+16)
finish
else
loadreg(rhs, anyf)
if lhs_type = real start
op = FSTD
else; ! long real
op = FSTQ
finish
dumpfloprm(op, lhs_base!lhs_scope, lhs_disp, lhs_extdisp )
finish
finish
end
abort("Assign Stack") if stp < 2
rh == top
lh == stack(stp-1)
form = lh_form; ! to avoid the ravages of amap, load etc
if diagnose&4 # 0 start
monitor(lh, "ASS LH")
monitor(rh, "ASS RH")
finish
if same(lh, rh) # 0 then start
pop rel
pop rel
return
finish
if assop < 0 start; ! Parameter
if lh_base >= 128 start; ! Special - prim routine
temp = lh; lh = rh; rh = temp
return
finish
! Extract the next formal parameter and make it our target
lh_pbase = lh_pbase - 1
Stack Var(lh_pbase)
! Now make our destination look reasonable
lh == top
lh_base = SP; ! target is the stack
assop = 0 if lh_form # v in s; ! %name parameter is '=='
! We need special treatment for procedure parameters
if 7 <= lh_aform <= 10 start; ! 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 = V in S
if rh_base # 0 start; ! RH is already a parameter
rh_form = V in S
else
if rh_scope = EXT start; ! it is an external procedure
rh_form = A V in S; ! 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 >= Max Switch then abort("Proc - Switch Table Full")
swtab(swtp) = rh_disp; rh_disp = swtp * word size; swtp = swtp+1
rh_scope = SWT
rh_form = V in S
finish
finish
finish
finish
if array <= rh_aform and rh_aform <= namearrayname start; ! 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 or rh_aform = name array start; ! simple static - DV in COT
! We will rustle up a dummy record for the DV address
temp = 0
temp_form = A V in S
temp_type = integer
temp_disp = rh_pbase
temp_scope = COT
else; ! already an array name
temp = rh; claim(temp_base)
temp_disp = temp_disp + word size
finish
lh_disp = lh_disp+word size
store(lh, temp)
release(temp_base)
lh_disp = lh_disp-word size
store(lh, rh)
pop rel
pop rel
return
finish
if lh_type = general start; ! general %name parameter
abort("Assign GenName") unless assop = 0; ! 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 start
temp = rh; ! make a copy for the second word
claim(temp_base); temp_disp = temp_disp + word size
amap(temp)
else
temp = 0
temp_type = integer
temp_disp = (rh_size << 4) + genmap(rh_type)
finish
! We do the words backwards, so that parameter push works
lh_disp = lh_disp + word size
store(lh, temp)
release(temp_base)
lh_disp = lh_disp-word size
amap(rh)
store(lh, rh)
pop rel
pop rel
return
finish
if assop = 0 start; ! ==
amap(lh); ! destination
amap(rh); ! ABD %string(*)%name NOT handled special here - should be?
finish
if Lh_Type = record start
if lh_base = SP start; ! 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 = Min Record Size(Lh, Rh)
amap(lh)
loadreg(lh, DI)
finish
hazard(CX)
dumpri(MOV, CX, n)
if rh_Form = Constant start
hazard(AX)
dumprr(XOR, AX,AX); ! get a zero
dumprepstosb
else
amap(rh)
loadreg(rh, SI)
dumprepmovsb
finish
pop rel
pop rel
return
finish
if lh_type = string start
if assop > 0 and rh_format = 1 start; ! null string as zero byte ?
lh_type = byte
pop rel; ! zap current RHS
push const(0); ! get a zero
assign(assop); ! and assign it
return
finish
! our copy routines expect DEST then SOURCE then LENGTH on the stack
if lh_base = SP start; ! 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 = gp reg
dumprr(MOV, r, SP)
dumpur(PUSH, r)
else
amap(lh)
loadreg(lh, any)
dumpur(PUSH, lh_base)
finish
! It is likely that the RH variable is a temporary work area
! Before we trash the information, we try to release it
Return Work(rh_disp)
amap(rh)
loadreg(rh, any)
dumpur(PUSH, rh_base)
pop rel
pop rel
dumppushi(0, lh_size, 0)
if assop = 2 then perm(sjam, 3) else perm(smove, 3)
return
finish
address(lh)
store(lh, rh)
pop rel
pop rel
end; ! assign
! >> ARRAY REF <<
! Array references always use the PERM
! unless they are 1 dimensional,
! AND the %control bit has been turned off
routine array ref(integer mode)
record(stackfm)name av
integer type, form, size, format
if mode#0 then start
! Put non-terminal index onto stack for PERM
if top_type = byte start
loadreg(top, any)
else
address(top)
finish
dumpvpush(top)
pop rel
return
finish
av == stack(stp-1)
size = av_size
size = size + 1 if av_type = string
form = av_aform
if form=namearray or form=namearrayname then size = word size
if control & check array = 0 and av_dim = 1 start
! 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 start; ! multiply offset by var size
push const(size)
Operation(MULx)
finish
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 start
loadreg(top, any)
else
address(top)
finish
dumpvpush(top)
pop rel
finish
! How we do the rest of the access depends on whether this is a simple
! static array, or an array name...
if form = arrayname or form = namearrayname start; ! 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 then form = v in s else form = a in s
amap(av)
if control & check array # 0 or av_dim > 1 start; ! 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)
push copy(av); claim(top_base)
top_disp = top_disp + word size; ! Dope Vector address follows A(0)
dumpvpush(top)
pop rel
perm(aref, av_dim + 1); ! DV word, plus a word for every subscript
push const(0)
top_form = V in R; top_base = AX; claim(AX)
finish
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 & check array # 0 start
! 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)
push const(0)
top_form = V in R; top_base = AX; claim(AX)
finish
address(av)
if av_form # v in s then abort("Aref Form")
if top_form = constant start; ! 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 start; ! add the base we've already got
dumprr(ADD, top_base, av_base)
release(av_base)
finish
av_base = top_base
finish
if form = array then av_form = v in s else av_form = a in s
pop stack
finish
top_aform = 0; ! not an array any more
end; ! array ref
! >> TEST ZERO <<
! test a real/integer/byte variable against zero
routine test zero(record(stackfm)name v)
if v_type = integer or v_type = byte start
loadreg(v,any)
dumpri(CMP, v_base, 0)
else
abort("Test Zero")
finish
end; ! test zero
routine Compare Records(record(stackfm)name L, R, integer N)
! JDM eventually compare the byte values of each record
! in the interim, barf
abort("Compare Records")
end
! >> COMPARE REALS <<
routine compare reals(record(stackfm)name l,r)
loadreg(l, anyf)
loadreg(r, anyf)
hazard(AX)
! who's ended up on top?
if l_base > r_base start; ! 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
finish
dumpflopspec(FSTSW); ! puts status into AX
dumpsimple(SAHF); ! and move it to flags
compare unsign = 1; ! because FPU reports as if operands were unsigned
end; ! compare reals
! >> COMPARE STRINGS <<
routine compare strings(record(stackfm)name l,r)
record(stackfm)name temp
if l_base = COT and l_disp = null string start
temp == r; r == l; l == temp
invert = invert !! 1
finish
if r_base = COT and r_disp = null string start
l_type = byte
test zero(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)
finish
end; ! compare strings
! >> COMPARE <<
routine compare(record(stackfm)name l,r)
if l_type = 0 or l_type = string start
compare strings(l,r); return
finish
if floating(l)#0 or floating(r)#0 start
compare reals(l,r); return
finish
if zero(r) # 0 start
test zero(l); return
finish
if zero(l) # 0 start
test zero(r); invert = invert !! 1
return
finish
if l_Type = Record start
Compare Records(L, R, Min Record Size(L, R)) ;! currently aborts
return
finish
loadreg(l,any)
if r_type = byte start
loadreg(r, anyg)
else
address(r)
finish
dumprv(CMP, l_base, r)
end; ! compare
! >> RESOLVE <<
routine resolve(integer flag)
!S -> A.(B).C
if flag&1 = 0 then push const(0) else amap(top); ! C missing?
loadreg(top, any)
dumpur(PUSH, top_base)
pop rel
amap(top); ! B
loadreg(top, any)
dumpur(PUSH, top_base)
pop rel
if flag&2 = 0 then push const(0) else amap(top); ! A missing?
loadreg(top, any)
dumpur(PUSH, top_base)
pop rel
amap(top); ! S
loadreg(top, any)
dumpur(PUSH, top_base)
pop rel
perm(sresln, 4)
if flag&4 # 0 then dumpri(CMP, AX, 0)
end; ! resolve
integerfn enter
integer cad;
uncond jump = -1; ! can get here
! This is a convenient place to include external definitions if needed
if potype >= external start
fill external(CODE, next cad, external id)
finish
cad = nextcad;
dumpstaticalloc(cad, level, block name); ! plant dummy ENTER instruction and pass marker to pass 3
result = cad;
end
! >> DUMP RETURN <<
routine dump return
return if uncond jump = next cad; ! 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);
uncond jump = next cad
end; ! 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
routine compile to string(record(stackfm)name v)
integer tmp
if const(v)#0 start
current string(0) = 1; current string(1) = v_disp&255
v_base = 0; v_scope = COT; v_disp = getcots(current string)
else
tmp = getwork(word size)
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
finish
v_type = string; v_form = VinS; v_size = 1
end
! >> 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
routine Compile Call(record(stackfm)name v)
switch b(1:15)
! 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)
constbyteintegerarray new type(5:12) =
1, 5, 3, 4, 2, 6, 5, 5
! integer, byte, string, record, real, lreal, byte, byte
integer t,l,p
if v_base >= 128 start; ! built-in primitive
l = 0; t = v_disp; sym = 0; ! 'sym=0' used as flag elsewhere
pop rel
-> b(t)
b(1): Operation(REMx); -> esac; ! REM
b(2): loadreg(top, anyf); -> esac; ! FLOAT
b(3): compile to string(top); -> esac; ! TO STRING
b(4): amap(top); -> esac; ! ADDR
b(5):; ! INTEGER
b(6):; ! BYTE
b(7):; ! STRING
b(8):; ! RECORD
b(9):; ! REAL
b(10):; ! LONG REAL
vmap(top); top_type = new type(t)
top_size = v size(top_Type)
-> esac
b(11):; ! LENGTH
push const(0); ! length is charno zero
amap(stack(stp-1))
Operation(ADDx); !LHS&RHS reversed in Operation??
vmap(top); top_type = new type(t)
top_size = v size(top_Type)
-> esac
b(12):; ! CHARNO
amap(stack(stp-1))
Operation(ADDx); !LHS&RHS reversed in Operation??
vmap(top); top_type = new type(t)
top_size = v size(top_Type)
-> esac
b(13):; ! type of(..)
b(14):; ! size of(..)
if top_type # general start; ! type explicitly specified
if t = 13 start; ! type of
p = gen map(top_type)
else
p = top_size; p = p+1 if top_type = string
finish
release(top_base)
top_type = integer; top_form = constant
top_base = 0; top_disp = p
else
top_disp = top_disp + word size; ! reference property-word
top_form = V in S; top_type = integer
if t = 13 start; ! type of
push const(15); Operation(ANDx)
else; ! size of
push const(4); Operation(RSHx)
finish
finish
-> esac
b(15):; ! INT(real)
loadreg(top, anyf)
release(top_base)
p = getwork(word size)
dumpfloprm(FSTI, BP, p, 0 )
top_type = integer
top_form = V in S
top_base = BP
top_disp = p
-> esac
esac:
else
! -- normal routine calls --
! String functions have a hidden last parameter to point
! to the result area
if v_type = string and v_aform = 8 start
t = getwork(v_size+1)
p = gp reg
dumprm(LEA, p, BP, t, 0)
dumpur(PUSH, p)
finish
hazard all
if v_scope = EXT start; ! external
dumpextcall(v_disp)
else
if v_base # 0 start; ! 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
finish
finish
! adjust the stack
if v_extra # 0 then dumpri(ADD, SP, v_extra)
if v_type = 0 start; ! not function or map
pop rel
else; ! Here we've got a result
v_scope = 0; ! Result is local, even if the function wasn't
if v_type = string and v_aform = 8 start
v_base = BP; ! String result will have been copied back here
v_disp = t
v_form = V in S
else
if (v_type = real or v_type = lreal) and v_aform = 8 start
! Floating result will be on the FPU stack
v_form = V in R
v_base = FR0; claim(FR0)
fpu stack = 1
else
v_base = AX; ! Result is always in AX
v_disp = 0; ! Clear this for MAP results
claim(AX)
finish
finish
finish
finish
end; ! Compile Call
! >> COMPILE FOR <<
routine compile for( integer lab )
record(stackfm)name cv, iv, inc, fv
integer n
! Lock a value into a temporary to make sure it is invariant
routine stab(record(stackfm)name v, integer type)
integer t,r
return if const(v)#0
loadreg(v,any); r = v_base
t = getwork(word size)
dumpmr(MOV, BP,t, 0, r)
v_base = BP; v_disp = t; v_scope = 0
v_type = type; v_form = V in S
release(r)
end
iv == top
fv == stack(stp-1)
inc == stack(stp-2)
cv == stack(stp-3)
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 # v in s or (0 < cv_base <= DI and cv_base # BP) start
n = cv_type
amap(cv)
stab(cv, n)
cv_form = a in s
finish
push copy(cv)
push copy(iv)
push copy(inc);
Operation(SUBx)
assign(1); ! cv = iv - inc
define label(lab)
pop stack;! zap unwanted copy of IV
! Stack is now top->[FV[INC[CV
push copy(cv); ! in case compare alters it
compare(top, fv)
jump to(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
pop stack; ! discard the top copy
! stack is now top->[CV'[INC[CV
Operation(ADDx)
assign(1)
end; ! for
routine End of Block
if amode >= 0 start; ! No return code for %endoffile
dump return
dumpstaticfill(staticalloc, frame+(level*word size), events, evep, evfrom); ! don't include the display
finish
end
routine Compile Begin
decvar == begin
decvar_disp = new tag
otype = 0
spec = 0
potype = 0
if level # 0 start; ! not outermost %begin
push const(decvar_disp)
top_type = 0; ! it's not a function!
compile call(top)
skip proc = new tag
dump jump(JMP, skip proc)
dump label(decvar_disp); ! this is where to call
finish
assemble(0,labs,names)
if level # 0 start
dump label(skip proc)
last skip = next cad
Uncond Jump = 0
finish
end
! Utility routine used when dumping initialisers for OWNs
! Note non-portable use of real values
routine adump
integer i
real rv32
switch ot(0:6)
->ot(own type)
ot(general):
abort("General Own?")
ot(integer):
gput(ownval); -> done
ot(real):
rv32 = rvalue; ! because our default variable is a 64 bit long real
for i = 0,1,3 cycle
gbyte(byteinteger(addr(rv32)+i))
repeat
-> done
ot(string):
if current string(0)+1 > data size start; ! check for overflow
! String constant too long - warn and truncate
warn(5); current string(0) = data size-1
finish
for i = 0,1,data size-1 cycle
gbyte(current string(i))
repeat
-> done
ot(record):
for i = 1,1,data size cycle
gbyte(0)
repeat
-> done
ot(byte):
gbyte(ownval); -> done
ot(lreal):
for i = 0,1,7 cycle
gbyte(byteinteger(addr(rvalue)+i))
repeat
-> done
done:
end
integerfn user label(integer lab)
record(varfm)name v
if lab > names start
names = lab
v == var(lab)
v = 0
v_form = pgm label
v_disp = new tag
result = v_disp
finish
result = var(lab)_disp
end
routine Compare Double
LHS == stack(stp-1)
RHS == top
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
pop stack
end
routine Compare Values
LHS == stack(stp-1)
RHS == top
compare(lhs,rhs)
pop rel
pop rel
end
routine Compare Addresses
amap(top);
amap(stack(stp-1)); ! Now do same as compare values
Compare Values
end
routine Define Compiler Label( integer label)
if label = 0 start
dump label(skipproc)
last skip = next cad
Uncond Jump = 0
else
define label( label );
finish
end
routine Init( integer N )
! N = Number of values to assign
integer j
if stp # 0 start; ! Value supplied?
own val = top_disp
if own type = real or own type = lreal start
rvalue = own val if top_type = integer; ! copy integer supplied into floater
finish
pop stack
else; ! initialise to default pattern
ownval = 0
current string(0) = 0; ! in case it's a string
finish
if own form = array or own form = name array start
adump for j = 1,1,N
else
if otype = 0 start ; ! %const .... %name
! Abort("Constant Name");
! JDM attempt to allow assignment of %const ... %name
decvar_scope = COT
decvar_level = 0
decvar_disp = own val
else
! non-array normal variables
decvar_level = 0
if otype = con start
! 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 own type = string start
decvar_disp = getcots(current string)
else
if own type = real or own type = lreal start
! 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?")
finish
finish
else
! must be %own or %external - use adump to put it in DATA segment
decvar_scope = DATA
decvar_disp = datatp
adump
finish
finish
finish
end
routine User Jump ( integer label )
dumpjump(JMP, user label( label ))
end
routine Define User Label( integer label )
dump label(user label( label ))
end
routine Return( integer mode)
integer i
if mode = False start
dumpri(MOV, AX, 0)
finish
if mode = True start
dumpri(MOV, AX, -1)
finish
if mode = Map start
amap(top)
loadreg(top, AX)
pop rel
finish
if mode = Fn start
if procvar_type = integer start
loadreg(top, AX)
pop rel
else
if procvar_type = real or procvar_type = lreal start
! 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);
pop rel
else ; ! string or record - pass back through the hidden parameter
push copy(top); ! Make a copy of the thing on top
lhs == stack(stp-1); ! 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 = word size * 2; ! At the offset of the last parameter
lhs_form = a in s
assign(1)
finish
finish
finish
if mode = Routine start
! no need to do anything special
finish
dump return
end
routine Dimension( integer dim, n )
integer i,j
! Validate the ICODE Parameters
abort("Array Dim") unless 0 < dim < 6
if in params # 0 start; ! Array in record
parms = parms+n
vub = top_disp; pop stack
vlb = top_disp; pop stack
abort("Array Bounds") if vlb > vub
dv = set dope vector
else
names = names-n
! Now we need to plant code to manufacture a dope vector
frame = (frame - ((dim * (2 * word size))+(2 * word size)))&(¬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 * word size)) + word size, 0, data size)
! Now the bounds
j = 0; ! points to before the first stack value
for i=1,1,dim*2 cycle
j = j + 1; lhs == stack(j)
if lhs_form = constant start
dumpmi(MOV, BP, dv + (i*word size), 0, lhs_disp)
else
loadreg(lhs, any)
dumpmr(MOV, BP, dv + (i*word size), 0, lhs_base)
finish
repeat
! Now we need to allocate the space for the array
if dim > 1 or control & check array # 0 start
! Do it with the PERM
while stp # 0 cycle
pop rel; ! get rid of all the bounds - they are in the DV already
repeat
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
push const(0); lhs == top
push const(0); rhs == top
lhs_base = AX; lhs_form = V in R; claim(AX)
rhs_base = DX; rhs_form = V in R; claim(DX)
pop stack
pop stack
else
push const(1)
Operation(ADDx)
push const(data size)
Operation(MULx)
push copy(stack(stp-1)); ! suck up the lower bound
push const(data size)
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; ! Point to it
pop stack; ! and drop (without release) this copy
loadreg(top, any); ! This is now UB - load it in a register as well
rhs == top; ! Point to it
pop stack; ! and keep RHS (Upper)
pop stack; ! dump the bogus lb
finish
! Note - there are 4 GP registers, and we're going to need them ALL here
t = gp reg; ! 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 = gp reg; ! 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"
finish
for i = 1,1,n cycle
decvar_dim = dim
if in params = 0 start; ! array not in record
names = names+1; decvar == var(names)
decvar_level = level
frame = frame - (word size * 2); ! 2-word header
decvar_disp = frame
if decvar_form = array or decvar_form = namearray then 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 + word size, 0, dv);! store dope vector pointer
dumprr(ADD, t, lhs_base);
else; ! array-in-record
parms = parms-1; decvar == var(parms)
decvar_disp = frame - vlb
frame = frame + vub; ! noting that Set Dope Vector has changed VUB to the array size
decvar_pbase = dv
finish
repeat
if in params = 0 start
! 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 data size & align # 0 then dumpri(AND, t, ¬align)
dumprr(MOV,SP,t)
release(lhs_base)
release(rhs_base)
release(dv)
finish
end
routine Update Line( integer line)
current line = line
abort("Stack?") if stp # 0
abort("Claimed") if claimed # 0
! 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 echo line < current line start
dump line number(current line)
while echo line < current line cycle
echo source line
repeat
finish
end
routine Switch Jump( integer switch id )
v == var( switch id )
push const(word size); Operation(MULx); ! subscript X WordSize
loadreg(top, anyp)
dumpum(JMP, SWT!top_base, v_disp * word size, 0); ! swtab is word-size
pop rel
uncond jump = next cad
end
routine Set Record Format( integer format id )
top_format = format id
top_type = record
end
routine Switch Label( integer switch label )
v == var( switch label )
uncond jump = 0
j = top_disp; pop stack
t = new tag
dumplabel(t);
swtab(v_disp+j) = t;
end
routine Constant Bounds
vub = top_disp; pop stack
vlb = top_disp; pop stack
end
routine Internal Handler ( integer id )
push const(0) while stp < 2
push const( id )
loadreg(top, any); dumpur(PUSH, top_base); pop rel
loadreg(top, any); dumpur(PUSH, top_base); pop rel
loadreg(top, any); dumpur(PUSH, top_base); pop rel
perm(signal, 3)
uncond jump = next cad if id # -1; ! %monitor will return
end
routine Signal Event( integer event id )
Internal Handler ( event id )
end
routine Monitor
Internal Handler ( -1 )
end
routine SelectField( integer field index )
! Contrary to earlier iCode versions, this one seems to use 'n' for
! both normal record member access and alternate formats?
lhs == top; ! Points to the base record
Stack Var(var(top_format)_pbase - field index); ! Push descriptor for the i-th member
if top_aform # recordformat start; ! not record format - must be a member
if lhs_form = v in s or lhs_form = VinRec start
top_disp = top_disp + lhs_disp
lhs_form = lhs_form - v in s + top_form
else
if lhs_form = a in rec start
lhs_form = VinRec; lhs_type = integer
loadreg(lhs,any)
lhs_form = top_form
else
if lhs_form <= VinR start
lhs_form = top_form; ! ????
else; ! A in S
lhs_extra = lhs_disp
lhs_form = top_form + 3
finish
finish
finish
lhs_disp = top_disp
lhs_type = top_type
lhs_aform = top_aform
lhs_dim = top_dim
finish
lhs_size = top_size; lhs_format = top_format
pop stack
end
routine EventTrap( integer anevent, evfrom )
! events: Events to trap (then comma)
! evfrom: Label to skip to
integer 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
jump to(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 = J Tag
evep = new tag; ! tag for the event body entry point
dump label(evep); ! which is here
dumprm(MOV, SP, BP, temp, 0); ! First thing we do is restore SP
end
routine DoubleOp( integer opr )
integer j,t
lhs == stack(stp-1)
t = lhs_type;
j = lhs_size
j = j+1 if t = string
amap(lhs)
abort("++/-- size") if j = 0
push const(j)
Operation(MULx)
Operation(opr)
vmap(top); top_type = t
end
routine Set CD(integer Value, integername CD)
! JDM set value for the appropriate compiler pass
! In this case we are in pass2
CD = Value&x'3FFF' if Value&x'C000' = (PassId&3)<<14
end
predicate Finish Params
integer j
true if amode < 0; ! end of %record %format defn.
true if procvar_level = 128; ! prim routine reference
! Here it's a real subroutine - copy any parameters to the PARM area
if names > first name start
procvar_pbase = parms; ! Point one beyond the first parameter
frame = (frame + align) & (¬align); ! Even up the stack size
if procvar_type = string and procvar_form = 8 start
frame = frame + word size; ! string functions have a hidden result parameter
finish
procvar_extra = frame; ! Remember the stack offset
procvar_dim = names - first name; ! and the number of parameters
frame = frame + (2 * word size); ! leave space for return linkage (IP + BP)
for j = first name+1, 1, names cycle
ap == var(j)
parms = parms-1; fp == var(parms)
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
repeat
abort("Params") if parms < names
finish
true if amode = 2; ! this was just a spec
dumplabel(procvar_disp)
static alloc = enter
frame = -(level * word size); ! one word for each display entry
false
end
predicate AlternateFormat( integer N )
! Check the ICODE for faults
! and abort for any faulty intermediate code
abort("Alt Record '".tostring(sym)."'.") unless (N = 'A') or (N = 'B') or (N = 'C')
true if N = 'B'; ! alt end
if N = 'A' start; ! alt start
decvar == procvar
assemble(-2,labs,names)
finish
if N = 'C' start
! Compile the next alternate - update limit and set frame back to where we started
max frame = frame if frame > max frame
frame = old frame
finish
false
end
! ******************************************
! JDM JDM attempt to include the plant icode and machine code icode
routine PLANT
! Plant in-line code values (from "*=constant")
integer j
! We only expect one item on the stack
abort("Machine Literal") if (stp <> 1)
for j = 1, 1, stp cycle
! JDM JDM not sure what next 3 lines do, so commented out
! lhs == stacked(j)
! word (lhs_disp)
! drop (lhs)
repeat
! JDM empty the icode stack
stp = 0
end
string(255) function get type name( integer f)
string(8) name
name = "????"
name = "general" if (f = 0)
name = "integer" if (f = 1)
name = "real" if (f = 2)
name = "string" if (f = 3)
name = "record" if (f = 4)
name = "byte" if (f = 5)
name = "lreal" if (f = 6)
result = name
end
string(255) function get form name( integer f )
string(24) name
name = "????"
switch n(0:15)
label esac
-> n(f & 15)
n( 0): name = "void"; -> esac
n( 1): name = "simple"; -> esac
n( 2): name = "name"; -> esac
n( 3): name = "label"; -> esac
n( 4): name = "recordformat"; -> esac
n( 5): name = "?????"; -> esac
n( 6): name = "switch"; -> esac
n( 7): name = "routine"; -> esac
n( 8): name = "function"; -> esac
n( 9): name = "map"; -> esac
n(10): name = "predicate"; -> esac
n(11): name = "array"; -> esac
n(12): name = "arrayname"; -> esac
n(13): name = "namearray"; -> esac
n(14): name = "namearrayname"; -> esac
n(15): name = "?????????????"; -> esac
esac:
result = name;
end
! classify the type of the machine code instruction parameter
constant integer 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
!
routine dump tag var( integer tag, string(3) prefix )
print string(" ".prefix." tag=".itos(tag,0)); newline
print string(" ".prefix." name=".var(tag)_idname); newline
print string(" ".prefix." type=".itos(var(tag)_type,0)." ".get type name(var(tag)_type)); newline
print string(" ".prefix." form=".itos(var(tag)_form,0)." ".get form name(var(tag)_form)); newline
print string(" ".prefix." level=".itos(var(tag)_level,0)); newline
print string(" ".prefix." scope=".itos(var(tag)_scope,0)); printstring(" ".relocname(var(tag)_scope>>4) );newline
print string(" ".prefix." disp=".itos(var(tag)_disp,0)); newline
print string(" ".prefix." extdisp=".itos(var(tag)_extdisp,0)); newline
print string(" ".prefix." size=".itos(var(tag)_size,0)); newline
print string(" ".prefix." extra=".itos(var(tag)_extra,0)); newline
print string(" ".prefix." format=".itos(var(tag)_format,0)); newline
print string(" ".prefix." dim=".itos(var(tag)_dim,0)); newline
print string(" ".prefix." pbase=".itos(var(tag)_pbase,0)); newlines(2)
end
routine dump parameter( integer param index, integer param type, string(255) param name, integer param value, param offset )
string(255) t
integer tag,n
printstring( "Parameter(".itos(param index,0).")='".param name."'"); newline
if (param type = pointer) start
! dump the pointer data
if (param offset = 0) start
print string(" PTR id=".itos(param value,0)); newline
print string(" PTR name=[".param name."]"); newline
print string(" PTR offset=0"); newlines(2)
finish else start
print string(" PTR id=".itos(param value,0)); newline
print string(" PTR name=[".param name.itos(param offset,0)."]"); newline
print string(" PTR offset=".itos(param offset,0)); newlines(2)
finish
finish else if (param type = variable) start
! dump the variable data
dump tag var( param value, "VAR" )
finish else if (param type = register) start
! dump the register data
print string(" REG id=".itos(param value,0)); newline
print string(" REG name=".param name); newlines(2)
finish else if (param type = number) start
! dump the number data
print string(" NUMBER value=".itos(param value,0)); newlines(2)
finish else if (param type = mask) start
! dump the mask data
print string(" MASK value=2_".int2ascii(param value,2,0)); newlines(2)
finish else if (param type = name) start
! dump the name data
print string(" NAME name=".param name); newline
print string(" NAME value=2_".int2ascii(param value,2,0)); newlines(2)
finish
end
! >> MACHINE CODE <<
routine Machine Code( string(255) 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
string(255) s,t,rname
string(5) instruction
string(255) parameters
integer params count
! ass-u-me that a machine code instruction has at most 8 parameters
constant integer param limit = 8;
! Remember number of CPU registers (1..register limit)
constant integer register limit = 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
recordformat paramFm(string(255) data, integer scomma,pcomma,start,end, string(255) param name, integer param type,param value, param offset)
record(paramFm)array params(1:param limit)
! 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
constant integer array opGenericId(NOP:JMP) =
-1, -1, -1, -1, -1, -1, -1, NEGx,
{ NOP, CWD, RET, SAHF, LEAVE, DEC, INC, NEG, }
NOTx, POP, PUSH, -1, -1, -1, -1, ADDx,
{ NOT, POP, PUSH, LEA, MOV, XCHG, ADC, ADD, }
ANDx, -1, ORx, SUBx, XORx, LSHx, RSHx, DIVx,
{ AND, CMP, OR, SUB, XOR, SHL, SHR, IDIV, }
MULx, -1, -1, -1, -1, -1, -1, -1,
{ IMUL, CALL, JE, JNE, JG, JGE, JL, JLE, }
-1, -1, -1, -1, -1
{ JA, JAE, JB, JBE, JMP }
! This list maps opId to internal opX name
constant string(5) array opGenericName(NOP:JMP) =
"NOP", "CWD", "RET", "SAHF", "LEAVE", "DEC", "INC", "NEGx",
"NOT", "POP", "PUSH", "LEA", "MOV", "XCHG", "ADC", "ADD",
"AND", "CMP", "OR", "SUB", "XOR", "SHL", "SHR", "IDIV",
"IMUL", "CALL", "JE", "JNE", "JG", "JGE", "JL", "JLE",
"JA", "JAE", "JB", "JBE", "JMP"
string(255) varname
byte ch
string(5) opNameX
integer i,j,k,n,plen,tag,rval,opId,opIdx
byte inrbflag,insbflag,inabflag,hashflag,plusFlag,minusFlag
switch c(0:127)
label esac, default
integer start,end
if ((diagnose&mcode level A) # 0) start
selectoutput(listout)
newline
finish
code -> instruction.("_").parameters ;! This is not good IMP. The string contains binary data.
s = ""
if (parameters # "") start
! parameters is a non-empty string so we ass-u-me at least one parameter
params count = 1
plen = length(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) cycle
ch = charno( parameters, i)
-> c(ch) if (ch < 128); ! this is an ordinary ASCII char
! So, ch > 127, thus this "char" starts a tweaked "name"
t = "%"
while (charno(parameters, i) > 127) cycle
! Append the converted char
length(t) = length(t) + 1
! tweak appended "char" to be a legal 7-bit ASCII char
charno( t, length(t)) = charno(parameters, i) - 128
i = i + 1
repeat
params( params count )_param type = name
params( params count )_param value = 0; ! value acquired by next N section
params( params count )_param name = t
s = s.t." "
-> esac
c(' '):
! a variable/pointer reference is prefixed by a space.
n = (charno( parameters, i+1 ) << 8) + charno( parameters, i+2 )
! now determine the variable name
t = var( n )_idname
! remember this parameter is a variable/pointer (and its tag)
if (insbflag = 1) start
params( params count )_param type = pointer
finish else start
params( params count )_param type = variable
finish
params( params count )_param value = n
params( params count )_param name = t
s = s.t
i = i + 3
-> esac
c('N'):
! A number is prefixed by an ASCII 'N'
n = 0
!errout;printstring("charno( parameters, i+1 ) = "); write(charno( parameters, i+1 ), 0); newline; undo
n = n + charno( parameters, i+1 ); n = n << 8
!errout;printstring("charno( parameters, i+2 ) = "); write(charno( parameters, i+2 ), 0); newline; undo
n = n + charno( parameters, i+2 ); n = n << 8
!errout;printstring("charno( parameters, i+3 ) = "); write(charno( parameters, i+3 ), 0); newline; undo
n = n + charno( parameters, i+3 ); n = n << 8
!errout;printstring("charno( parameters, i+4 ) = "); write(charno( parameters, i+4 ), 0); newline; undo
n = n + charno( parameters, i+4 )
!errout;printstring("N: n = "); write(n, 0); newline; undo
if (params( params count )_param type = name) start
! 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
params( params count )_param value = n
! convert number to text
if (n > 127) start
t = "16_".int2ascii( n, 16, 0 )
finish else start
t = itos( n, 0 )
finish
! now to add the associated number to the s string
s = s.t
finish else if (hash flag <> 0) and (params( params count )_param type = unknown) start
! hashflag indicates this is a genuine integer
hashFlag = 0
! remember this parameter is a number
params( params count )_param type = number
params( params count )_param value = n
params( params count )_param name = ""
if (n > 127) start
t = "16_".int2ascii( n, 16, 0 )
finish else start
t = itos( n, 0 )
finish
s = s.t
params( params count )_param name = t
finish else if (params( params count )_param type = mask) start
! Ah, we are between <> == mask
! So we need to update the mask
if (0 < n <= register limit) start
! ok, legal register mask range
k = 1<<(n - 1)
finish else if (0 < n <= 32) start
! oops, bad mask specifier for this CPU
k = 1<<(n - 1)
finish else start
! 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
finish
! add the register flag to the mask
params( params count )_param value = params( params count )_param value!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 <= register limit) start
s = s.regname(n)
finish else start
s = s."R??"
finish
finish else start
! 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) start
params( params count )_param type = pointer
finish else start
params( params count )_param type = register
finish
if (plusFlag = 1) start
! remember this "parameter" is a positives pointer offset
params( params count )_param offset = n
t = itos( n, 0)
finish else if (minusFlag = 1) start
! remember this "parameter" is a negative pointer offset
params( params count )_param offset = -n
!however, negative sign (and or #) already output
t = itos( n, 0)
!errout;printstring("Line 5955: params(params count=");write(params count,0);printstring(")_param offset = ");write(params(params count)_param offset,0);printstring(" (minusflag == -1, remember this parameter is a negative pointer offset)");newline;undo
finish else start
! remember this parameter is a register
params( params count )_param value = n
! Ensure we are referencing a valid register
! Adjust register limit for a specific CPU
if (0 < n <= register limit) start
t = regname(n)
finish else start
t = "R??"
finish
!errout;printstring("Line 5967: t = """);printstring(t);printsymbol('"');newline;undo
params( params count )_param name = t
finish
s = s.t
!errout;printstring("Line 5972: s = """);printstring(s);printsymbol('"');newline;undo
finish
i = i + 5
-> esac
c('#'):
! let this char through
! BUT remember # is assumed to prefix a positive number
hashFlag = 1
-> default
c(','):
! let this char through
! comma separates instruction parameters
! (or values between brackets)
{ ok, check to see if this is a parameter separator }
if ((inabFlag + inrbFlag + insbFlag) = 0) start
{ ok, we are not inside one of the "bracket" types }
! REMEMBER, the parameter type and value should have been
! determined previously
! note comma location in the s string
params(params count)_scomma = length(s) + 1
! note comma location in the parameters string
params(params count)_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
params count = params count + 1
! BUT set the param type appropriately
params( params count )_param type = unknown
params( params count )_param offset = 0
finish
-> default
c('+'):
! pass this char( only allowed between [] brackets
plusFlag = 1
minusFlag = 0; -> default
c('-'):
! pass this char( only allowed between [] brackets
plusFlag = 0
minusFlag = 1; -> default
c('('):
! pass this char (opening round brackets)
inrbFlag = 1; -> default
c(')'):
! pass this char (closing round brackets)
inrbFlag = 0; -> default
c('['):
! we are referencing an indirect variable
params( params count )_param type = pointer
! initialise the name,value and offset
params( params count )_param name = ""
params( params count )_param value = 0
params( params count )_param offset = 0
! pass this char (opening square brackets)
insbFlag = 1; -> default
c(']'):
! pass this char (closing square brackets)
plusFlag = 0
minusFlag = 0
insbFlag = 0; -> default
c('<'):
! We are starting a mask parameter
params( params count )_param type = mask
! initialise the value and name
params( params count )_param name = ""
params( params count )_param value = 0
params( params count )_param offset = 0
! pass this char (opening angle brackets)
inabFlag = 1; -> default
c('>'):
! pass this char (closing angle brackets)
inabFlag = 0; -> default
default:
c(*):
! pass these chars
! chars > 127 are already dealt with
! So, this deals with remaining chars
s = s.tostring( charno( parameters, i) )
i = i + 1
-> esac
esac:
repeat
finish else start
! Oh, this instruction has no parameters
params count = 0
finish
if (params count # 0) start
! now to identify each instruction parameter inside the s string
for i = 1,1,params count cycle
if (i = 1) then params(i)_start = 1 else params(i)_start = params(i-1)_scomma + 1
if (i = params count) then params(i)_end = length(s) else params(i)_end = params(i)_scomma - 1
params(i)_data = ""
for j = params(i)_start,1,params(i)_end cycle
params(i)_data = params(i)_data.toString( charno(s,j) )
repeat
repeat
finish
! 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,1,JMP cycle
if (instruction = opGenericName(i)) start ; ! string compare
opId = i
opIdx = opGenericId(opId)
if (opIdx # -1) start
opNameX = instruction
finish else start
opNameX = itos(opId,0)
finish
!%exit; ! added by gt to speed it up a little...
finish
repeat
! 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)
abort("MCODE has illegal/unknown instruction name") if (opId = -1)
if ((diagnose&mcode level A) # 0) start
selectoutput(listout)
printstring( "**** START MCODE ****" ); newline
if ((diagnose&mcode level D) # 0) start
printstring( " Raw Instruction text: '".instruction."'_".parameters ); newline
finish
printstring( "Translated Instruction: '".instruction."' ".s ); newline
printstring( " Instruction: '".instruction."' has ".itos( params count, 0)." parameter")
if (params count # 1) then printsymbol( 's' )
newline
printstring( " Instruction OpId: ".itos(opId,0)); newline
printstring( " 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,1,params count cycle
dump parameter( i, params(i)_param type, params(i)_param name, params(i)_param value, params(i)_param offset )
repeat
printstring( "*** end parameters ****" ); newline
comment Add an extra newline to split the above debug code from
comment the following code generation code
newline
printstring( "**** START CODE GEN **********" )
newline
finish
! 2) need to interpret parsed code
if (params count = 0) start
selectoutput(listout)
printstring( "**** Instructions with no parameters not yet implemented" ); newline
finish else if (params count = 1) start
if (opId # -1) start
if (params(1)_param type = variable) start
if ((diagnose&mcode level A) # 0) start
printstring( instruction." ".params(1)_param name)
newline
finish
Stack Var( params(1)_param value )
Operation(opIdx);
finish else if (params(1)_param type = pointer) start
selectoutput(listout)
printstring( "Opcode ".instruction." with one parameter can only operate on an address/register ".params(1)_param name ); newline
abort( "Opcode ".instruction." with one parameter can only operate on an address/register ".params(1)_param name )
finish else if (params(1)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring( instruction." ".params(1)_param name)
newline
finish
dumpur(opId, params(1)_param value)
finish else start
abort( "Opcode ".instruction." is attempting to operate on unexpected location ".params(1)_param name )
finish
finish else start
abort( "Attempting to apply unknown opcode ".instruction )
finish
finish else if (params count = 2) start
! 3) output the implied code fragment
if (opId = MOV) start
if (params(1)_param type = variable) start
if (params(2)_param type = variable) or (params(2)_param type = pointer) start
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
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ASSIGN var1,reg2 scenario"); newline
printstring( params(1)_param name." := ".params(2)_param name); newline
finish
Stack Var( params(1)_param value )
if (top_type = general) or (top_type = integer) or (top_type = byte) or (top_type = record) start
storeReg( top, params(2)_param value )
finish else start
abort( "Attempting to store reg ".params(2)_param name." in a non-integer variable" )
finish
pop rel
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have an ASSIGN var1,#const2 scenario"); newline
printstring( params(1)_param name." := #".itos(params(2)_param value,0)); newline
finish
Stack Var( params(1)_param value )
Push Const( params(2)_param value )
Assign(1);
finish else start
abort( "Attempting to store unexpected type in variable ".params(1)_param name )
finish
finish else if (params(1)_param type = pointer) start
if (params(2)_param type = variable) or (params(2)_param type = pointer) start
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
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a STORE [reg ((+,-) offset)?],reg2 scenario"); newline
printstring( params(1)_param name." := &".params(2)_param name); newline
finish
dumpmr(opId, params(1)_param value, params(1)_param offset, 0, params(2)_param value)
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a STORE [reg ((+,-) offset)?],const2 scenario"); newline
printstring( params(1)_param name." := &".params(2)_param name); newline
finish
selectoutput(listout)
printstring(" EXPERIMENTAL IMPLEMENTATION"); newline
dumpmi(opId, params(1)_param value, params(1)_param offset, 0, params(2)_param value)
printstring(" NOT YET IMPLEMENTED"); newline
finish else start
abort( "Attempting to store unexpected type in variable ".params(1)_param name )
finish
finish else if (params(1)_param type = register) start
if (params(2)_param type = variable) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a LOAD reg1,var2 scenario"); newline
printstring( params(1)_param name." := ".params(2)_param name); newline
finish
!errout;printstring("Stack Var( params(2)_param value=");write(params(2)_param value,0);printstring(" )");newline;undo
Stack Var( params(2)_param value )
!errout;printstring("LoadReg( top, params(1)_param value=");write(params(1)_param value,0);printstring(" )");newline;undo
LoadReg( top, params(1)_param value )
!errout;printstring("Should this be ""Stack Var( -params(2)_param offset )"" ???");newline;undo
pop rel
finish else if (params(2)_param type = pointer) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a LOAD reg1,[reg2 ((+,-) offset)?] scenario"); newline
if (params(2)_param offset = 0) start
printstring( params(1)_param name." := [".params(2)_param name."]"); newline
finish else start
printstring( params(1)_param name." := [".params(2)_param name.itos(params(2)_param offset,0)."]"); newline
finish
finish
dumprm(opId, params(1)_param value, params(2)_param value, params(2)_param offset, 0)
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a MOVE reg1,reg2 scenario"); newline
printstring( params(1)_param name." := ".params(2)_param name); newline
finish
dumprr(opId, params(1)_param value, params(2)_param value )
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a LOAD reg1,#const2 scenario"); newline
printstring( params(1)_param name." := #".itos(params(2)_param value,0)); newline
finish
Push Const( params(2)_param value )
LoadReg( top, params(1)_param value )
pop rel
finish else start
abort( "Attempting to store unexpected type in register ".params(1)_param name )
finish
finish else start
abort( "Attempting to ".instruction." into non-variable/register location" )
finish
finish else if (opIdx # -1) start
if (params(1)_param type = variable) start
if (params(2)_param type = variable) or (params(2)_param type = pointer) start
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
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." var1,reg2 scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." ".params(2)_param name)
finish
Stack Var( params(1)_param value )
dumpmr(opId, top_base!top_scope, top_disp, top_extdisp, top_base)
pop rel;
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." var1,#const2 scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." #".itos(params(2)_param value,0))
newline
finish
Stack Var( params(1)_param value )
Stack Var( params(1)_param value )
Push Const( params(2)_param value )
Operation(opIdx);
Assign(1);
finish else start
abort( "Opcode ".instruction." is attempting to store unexpected type in variable ".params(1)_param name )
finish
finish else if (params(1)_param type = pointer) start
if (params(2)_param type = variable) or (params(2)_param type = pointer) start
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
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." [reg1 ((+,-) offset)?],reg2 scenario"); newline
if (params(1)_param offset = 0) start
printstring( "[".params(1)_param name."] := " )
printstring( "[".params(1)_param name."] ".opNameX." ".params(2)_param name)
finish else start
printstring( "[".params(1)_param name.itos(params(1)_param offset,0)."] := " )
printstring( "[".params(1)_param name.itos(params(1)_param offset,0)."] ".opNameX." ".params(2)_param name)
finish
newline
finish
dumpmr(opId, params(1)_param value, params(1)_param offset, 0, params(2)_param value)
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." [reg1 ((+,-) offset)?],const2 scenario"); newline
if (params(1)_param offset = 0) start
printstring( "[".params(1)_param name."] := " )
printstring( "[".params(1)_param name."] ".opNameX." ".params(2)_param name)
finish else start
printstring( "[".params(1)_param name.itos(params(1)_param offset,0)."] := " )
printstring( "[".params(1)_param name.itos(params(1)_param offset,0)."] ".opNameX." ".params(2)_param name)
finish
newline
finish
selectoutput(listout)
printstring(" EXPERIMENTAL IMPLEMENTATION"); newline
dumpmi(opId, params(1)_param value, params(1)_param offset, 0, params(2)_param value)
printstring(" NOT YET IMPLEMENTED"); newline
finish else start
abort( "Attempting to store unexpected type in variable ".params(1)_param name )
finish
finish else if (params(1)_param type = register) start
if (params(2)_param type = variable) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." reg1,var2 scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." ".params(2)_param name)
newline
finish
Stack Var( params(2)_param value )
dumprv( opId, params(1)_param value, top)
pop rel;
finish else if (params(2)_param type = pointer) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." reg1,[reg2 (('+','-')offset)?] scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." ".params(2)_param name)
newline
finish
selectoutput(listout)
printstring(" EXPERIMENTAL IMPLEMENTATION"); newline
dumprm(opId, params(1)_param value, params(2)_param value, params(1)_param offset, 0 )
printstring(" NOT YET IMPLEMENTED"); newline
finish else if (params(2)_param type = register) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." reg1,reg2 scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." ".params(2)_param name)
newline
finish
dumprr(opId, params(1)_param value, params(2)_param value )
finish else if (params(2)_param type = number) start
if ((diagnose&mcode level A) # 0) start
printstring("We have a ".instruction." reg1,const2 scenario"); newline
printstring( params(1)_param name." := " )
printstring( params(1)_param name." ".opNameX." #".itos(params(2)_param value,0))
newline
finish
dumpri(opId, params(1)_param value, params(2)_param value )
finish else start
abort( "Opcode ".instruction." is attempting to store unexpected type in register ".params(1)_param name )
finish
finish else start
abort( "Opcode ".instruction." is attempting to store in unexpected location ".params(1)_param name )
finish
finish else start
abort( "Attempting to apply unknown opcode ".instruction )
finish
finish else start
abort("Opcode ".instruction." has unexpected number ".itos(params count,0)."of parameters.")
finish
if ((diagnose&mcode level A) # 0) start
selectoutput(listout)
newline
printstring( "**** END CODE GEN ********" ); newline
printstring( "**** END MCODE ****" ); newlines(2)
finish
end
! ******************************************
!--------------------------------------------------------------
! Code for ASSEMBLE starts here...
First Name = Names
First Label = Labs
Proc Var == Decvar
last skip = -1
old frame = frame
frame = 0
events = 0; evep = 0; evfrom = 0
if amode >= 0 start; ! NOT A RECORDFORMAT
level = level+1; abort("Level") if level > max level and spec = 0
worklist(level) = 0
if amode = 0 start; ! %begin block
if level = 1 start; ! Initial %begin ?
block name = program ip; ! For stack traceback readability
external id = program ep; ! linkage to program entry
otype = external; potype = otype
else
block name = "%begin block"
finish
static alloc = enter
frame = -(level * word size); ! 1 word for every display entry
finish
else
if amode = -1 start; ! normal record format
ProcVar_pbase = parms; ! where our members start
else
if amode = -2 then frame = oldframe; ! alternates start at the current offset
finish
max frame = frame; ! start counting space here
finish
! --- main compilation loop ---
cycle
sym = Pending
read symbol(Pending)
if sym < 33 or sym > 127 then start
selectoutput(0)
printsymbol('(')
write(sym, 1)
printsymbol(',')
write(Pending, 1)
printsymbol(')')
abort("Bad I Code")
finish
-> c(sym)
c('!'): Operation(ORx); continue
c('"'): CompareDouble; continue
c('#'): Jump Forward( ReadTag, NE ); continue
c('$'): ! Imp defines left to right evaluation of parameters, but to be safe we could do this:
begin
integer rt0,rt1,rt2,rt3
string(255)ga
rt0=ReadTag ; ga=Get Ascii( ',' ) ; rt1=ReadTagComma ; rt2=ReadTagComma ; rt3=ReadTag
Define Var( rt0,ga,rt1,rt2,rt3 );
!! Define Var( ReadTag, Get Ascii( ',' ), ReadTagComma, ReadTagComma, ReadTag );
end
continue
c('%'): Operation(XORx); continue
c('&'): Operation(ANDx); continue
c(''''): Input String Value( ReadString ); continue; ! Stack string constant
c('('): Jump Forward( ReadTag, LE ); continue
c(')'): Jump Forward( ReadTag, GE ); continue
c('*'): Operation(MULx); continue
c('+'): Operation(ADDx); continue
c('-'): Operation(SUBx); continue
c('.'): Operation(CONCx); continue
c('/'): Operation(DIVx); continue
c(':'): Define Compiler Label( ReadTag ); continue; ! Define compiler label
c(';'): End of Block; exit
c('<'): Jump Forward( ReadTag, LT ); continue
c('='): Jump Forward( ReadTag, EQ ); continue
c('>'): Jump Forward( ReadTag, GT ); continue
c('?'): Compare Values; continue; ! Compare values
c('@'): Stack Var( ReadTag ); continue; ! Stack variable descriptor
c('A'): Init( ReadTag ); continue; ! Initialise OWN variable
c('B'): Jump Backward( ReadTag ); continue; ! Backward Jump
c('C'): Compare Addresses; continue; ! Compare addresses
c('D'): Input Real Value( ReadReal ); continue; ! Stack real constant
c('E'): Compile Call(top); continue
c('F'): Jump Forward( ReadTag, Always ); continue; ! Forward Jump
c('G'): Get Alias Value( ReadString ); continue; ! Alias for item about to be declared
c('H'): Compile Begin; continue; ! Start of BEGIN block
c('I'): Abort("Pascal?"); !%continue; ! {ESCAPE for Pascal etc.}
c('J'): User Jump( ReadTag ); continue; ! Jump to user label
c('K'): Return( False ); continue; ! %false
c('L'): Define User Label( ReadTag ); continue; ! Define user label
c('M'): Return( Map ); continue; ! MAP result
c('N'): Push Const( ReadInteger ); continue; ! Stack integer constant
c('O'): Update Line( ReadTag ); continue; ! Set line number
c('P'): Plant; continue; ! Machine code literal
c('Q'): Operation(RDIVx); continue
c('R'): Return( Routine ); continue; ! RETURN
c('S'): assign(1); continue; ! Normal value assignment
c('T'): Return( True ); continue; ! %true
c('U'): Operation(NEGx); continue
c('V'): Return ( Fn ); continue; ! FN result
c('W'): Switch Jump( ReadTag ); continue; ! Jump to switch
c('X'): Operation(EXPx); continue
!'Y' - UNUSED
c('Z'): assign(0); continue; ! Assign address '=='
c('['): Operation(LSHx); continue
c('¬'): Operation(NOTx); continue
c(']'): Operation(RSHx); continue
c('^'): Set Record Format( ReadTag); continue; ! {Set Format}
c('_'): Switch Label( ReadTag); continue; ! Define switch label
c('a'): array ref(0); continue
c('b'): Constant Bounds; continue; ! Define constant bounded Dope Vector
!'c' NOT IMPLEMENTED
c('d'): Dimension( ReadTagComma, ReadTag ); continue; ! dimensions, count of variables - NB in params: =0 -> simple array, # 0 -> array-in-record
c('e'): Signal Event( ReadTag); continue; ! %signal event
c('f'): Compile For( ReadTag ); continue
c('g'): Dimension( ReadTagComma, ReadTag ); continue; ! (different to PSR) dimensions, count of variables - NB in params: =0 -> simple array, # 0 -> array-in-record
c('h'):
! compiler op(n)
! compiler op(ReadTag)
continue
c('i'): array ref(1); continue
c('j'): assign(2); continue; ! JAM transfer
c('k'): Jump Forward( ReadTag, FF ); continue; ! Branch on FALSE (= 0)
c('l'): Language Flags = ReadTag; continue; ! We currently only support standard IMP - who knows the future
c('m'): Monitor; continue; ! %monitor
c('n'): SelectField( ReadTag ); continue; ! Select member from record format
c('o'): EventTrap( ReadTagComma, ReadTag ); continue; ! %on %event block
c('p'): assign(-1); continue; ! Pass a parameter
c('q'): DoubleOp( SUBx); continue; !--
c('r'): resolve( ReadTag ); continue
c('s'): perm(stop, 0); continue; ! %stop
!!c('t'): Jump Forward( ReadTag, JNE ); %continue; ! Branch on TRUE (# 0)
c('t'): Jump Forward( ReadTag, TT ); continue; ! Branch on TRUE (# 0) GT temp fix applied until JDE confirms.
c('u'): DoubleOp( ADDx ); continue; !++
c('v'): Operation(ABSx); continue
c('w'): MachineCode(Get Ascii( ';' )); continue; ! JDM: allowed call to Machine code
c('x'): Operation(REXPx); continue
c('y'): Set CD( ReadTag, diagnose); continue; ! %diagnose n (what about pass3? how do we send to pass3)
c('z'): Set CD( ReadTag, control ); continue; ! %control n
c('{'): in params = -1;
! this is either a record format, a procedure, or a proc spec;
! - block type was set by decvar to tell us which
assemble(block type,labs,names)
continue; ! Start of formal parameters
c('}'): in params = 0; exit if Finish Params; continue; ! End of formal parameters
c('~'): exit if AlternateFormat( ReadByte ); continue; ! alternate record format
C(*): abort("Bad I Code"); !%continue; ! To catch the sinners!! (that is - an unimplemented iCode)
repeat
if amode >= 0 start; ! end of declarative block
while worklist(level) # 0 cycle
worklist(level) = ret gp tag(worklist(level))
repeat
level = level-1
else; ! end of record format defn
if amode = -2 start; ! end of alternative only
frame = max frame if max frame > frame; ! use the longest alternative
old frame = frame
else
frame = (frame+align)&(¬align); ! **** temporary ****
procvar_size = frame
finish
finish
frame = old frame
end; ! 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)
string(255) the source file name
select input( source )
the source file name = input name
! Initialise some arrays that are not declared as %own - this is to match pass2.c and the checksumming
worklist(i) = 0 for i = 1, 1, maxlevel
listbytes(i) = 0 for i = 1, 1, lstbufmax
contable(i) = 0 for i = 0, 1, cotsize
xsymbuff(i) = 0 for i = 0, 1, 255
currentstring(i) = 0 for i = 0, 1, 255
swtab(i) = 0 for i = 0, 1, maxswitch
for i = 0, 1, maxgp cycle
gptags(i)_info = 0; gptags(i)_addr = 0; gptags(i)_flags = 0; gptags(i)_link = 0
repeat
for i = 1, 1, maxstack cycle ; ! or maybe stp, for speed...
! %string (255) idname; ... lets handle strings later, when we're sure which are Imp and which are C strings, and which are pointers
stack(i)_type = 0;
stack(i)_form = 0;
stack(i)_aform = 0;
stack(i)_base = 0;
stack(i)_scope = 0;
stack(i)_dim = 0;
stack(i)_disp = 0;
stack(i)_format = 0;
stack(i)_size = 0;
stack(i)_pbase = 0;
stack(i)_extra = 0;
stack(i)_extdisp = 0;
stack(i)_varno = 0;
repeat
for i = 1, 1, maxlabs cycle
Labels(i)_id = 0;
Labels(i)_tag = 0;
repeat
for i = 0, 1, maxvars cycle
! ignore *idname for now
var(i)_type = 0;
var(i)_form = 0;
var(i)_level = 0;
var(i)_scope = 0;
var(i)_dim = 0;
var(i)_disp = 0;
var(i)_format = 0;
var(i)_size = 0;
var(i)_pbase = 0;
var(i)_extra = 0;
var(i)_extdisp = 0;
repeat
buffer(0) = 0;
buffer(1) = 0;
! %byteintegerarray datat(0:datat limit)
datat(i) = 0 for i = 0, 1, datatlimit
Pending = 0;
! JDM - ok, now we can really start
select input( icode )
select output( objout )
var(0) = 0; ! for %RECORD(*) . . . . .
parms = max vars
! Initialise the GP Tag ASL
for i=1,1,Max GP cycle
GP Tags(i)_link = i - 1
repeat
gp asl = Max GP
! Tell the linker our source file name
dumpsourcename( the source file name ); ! 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,1,lastperm cycle
j = externalref(permname(i))
repeat
read symbol(Pending); ! Prime SYM/NEXT pair
Spec = 0
decvar == begin
assemble(-3,0,0)
! We flush constants
flush cot
flush data
flush switch
checksum("at exit")
routine checksum(string(255) which)
{long} integer crc = 0
own integer sequence = 0
integer i, saved
sequence = sequence + 1
!%return;
saved = output stream
select output(0)
! print a checksum of 'interesting' memory locations. Can be done at any location
! in the code. Each checksum is accompanied by a sequence number. As long as the
! program behaves consistently, you can re-run it with the same inputs, and turn
! on more detailed debugging just before the checksums diverge from the Imp77 version.
long test = 16_89AB0123;
crc = crc32mem(crc, ADDR(test), 4);
crc = crc32mem(crc, ADDR(Pending), 4);
crc = crc32mem(crc, ADDR(stp), 4);
for i = 1, 1, maxstack cycle ; ! or maybe stp, for speed...
! char *idname; ... lets handle strings later, when we're sure which are Imp and which are C strings.
crc = crc32mem(crc, ADDR(stack(i)_type), 1);
crc = crc32mem(crc, ADDR(stack(i)_form), 1);
crc = crc32mem(crc, ADDR(stack(i)_aform), 1);
crc = crc32mem(crc, ADDR(stack(i)_base), 1);
crc = crc32mem(crc, ADDR(stack(i)_scope), 1);
crc = crc32mem(crc, ADDR(stack(i)_dim), 1);
crc = crc32mem(crc, ADDR(stack(i)_disp), 4);
crc = crc32mem(crc, ADDR(stack(i)_format), 4);
crc = crc32mem(crc, ADDR(stack(i)_size), 4);
crc = crc32mem(crc, ADDR(stack(i)_pbase), 4);
crc = crc32mem(crc, ADDR(stack(i)_extra), 4);
crc = crc32mem(crc, ADDR(stack(i)_extdisp), 4);
crc = crc32mem(crc, ADDR(stack(i)_varno), 4);
repeat
! %recordformat LabelFm(%integer id, tag)
! %record(LabelFm)%array Labels(1:Max Labs)
for i = 1, 1, maxlabs cycle
crc = crc32mem(crc, ADDR(Labels(i)_id), 4);
crc = crc32mem(crc, ADDR(Labels(i)_tag), 4);
repeat
! /* static */ int worklist[maxlevel + 1]; // re-based at 0 for efficiency imptoc: EXPLICIT INIT
crc = crc32mem(crc, ADDR(worklist(i)), 4) for i = 1,1,maxlevel;
! %recordformat varfm( %string(255) idname, %byteinteger type, form, level, scope, dim, %integer disp, format, size, pbase, extra, extdisp )
! %record(varfm)%array var(0:max vars)
!!crc = crc32mem(crc, ADDR(var(0)), (maxvars+1)*sizeof(var(0)));
for i = 0, 1, maxvars cycle
! ignore *idname for now
crc = crc32mem(crc, ADDR(var(i)_type), 1)
crc = crc32mem(crc, ADDR(var(i)_form), 1)
crc = crc32mem(crc, ADDR(var(i)_level), 1)
crc = crc32mem(crc, ADDR(var(i)_scope), 1)
crc = crc32mem(crc, ADDR(var(i)_dim), 1)
crc = crc32mem(crc, ADDR(var(i)_disp), 4)
crc = crc32mem(crc, ADDR(var(i)_format), 4)
crc = crc32mem(crc, ADDR(var(i)_size), 4)
crc = crc32mem(crc, ADDR(var(i)_pbase), 4)
crc = crc32mem(crc, ADDR(var(i)_extra), 4)
crc = crc32mem(crc, ADDR(var(i)_extdisp), 4)
repeat
! auto /* static */ int activity[ 16 /* fr7 */ + 1] = { 0, 0, 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; // zero-based array
crc = crc32mem(crc, ADDR(activity(0)), (16+1)*sizeof(activity(0)));
!crc = crc32mem(crc, &maxgp, sizeof(maxgp));
! gptag gptags[maxgp + 1]; // zero-based array 121 els
!crc = crc32mem(crc, &gptags[0], sizeof(gptag)*121);
crc = crc32mem(crc, ADDR(gptags(i)), sizeof(gptags(0))) for i = 0, 1, maxgp
! int swtab[maxswitch + 1]; // zero-based array
crc = crc32mem(crc, ADDR(swtab(0)), (maxswitch+1)*sizeof(swtab(0)));
! unsigned char currentstring[255 + 1]; // current string literal // zero-based array
crc = crc32mem(crc, ADDR(currentstring(0)), 256);
! unsigned char xsymbuff[255 - 0 + 1]; // current external string name // zero-based array
crc = crc32mem(crc, ADDR(xsymbuff(0)), 256);
! static unsigned char objectbytes[ objbufmax + 1 ]; // zero-based array // initialised to all 0
crc = crc32mem(crc, ADDR(objectbytes(0)), objbufmax+1);
! static unsigned char listbytes[ lstbufmax + 1 ]; // initialised to all 0 // zero-based array
crc = crc32mem(crc, ADDR(listbytes(0)), lstbufmax+1);
! unsigned char buffer[1 + 1]; // zero-based array
crc = crc32mem(crc, ADDR(buffer(0)), 1);
crc = crc32mem(crc, ADDR(buffer(1)), 1);
! static unsigned char contable[ 2000 /* cotsize */ - 0 + 1]; // zero-based array // initialise to all 0
crc = crc32mem(crc, ADDR(contable(0)), 2001);
!! %byteintegerarray datat(0:datat limit)
! unsigned char datat[datatlimit - 0 + 1]; // zero-based array
crc = crc32mem(crc, ADDR(datat(i)), 1) for i = 0, 1, datatlimit
if which = "at exit" start
printstring("Imp executable post-execution checksum "); write(crc,0);newline
finish else start
printstring(which); printsymbol(' '); write(crc,0); newline
finish
select output(saved)
end
endofprogram