! Intel 8086 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
begin
!SIZE CONSTANTS
constinteger max vars = 600
constinteger max stack = 16
constinteger max labs = 50
constinteger max level = 16
constinteger Max GP = 100
! SOME WEE ENVIRONMENTAL THINGS
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
!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 16 bit register
constinteger anyg = 26 ; ! A "General Purpose" byte accessible register (AX, BX, CX, DX)
constinteger anyp = 27 ; ! A 16 bit pointing register (BX, SI, DI)
constinteger anyf = 28 ; ! Generally means the top of the 8087 stack
!DATA FORMS
! EXTERNAL
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(0:6) = 0,2,4,0,0,1,8
! GENERIC STORE ALIGNMENT - ASSUME 8086
constinteger align = 1
constinteger wordsize = 2; ! 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
! Define type codes known externally (to pass 3 and user):
constbyteintegerarray gen map(general:lreal) =
0, 1, 2, 3, 4, 6, 8
! 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 lastperm=signal
! 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"
! COMPILER OPERATIONS (not to be confused with OpCodes)
constinteger op add = 1
constinteger op sub = 2
constinteger op mul = 3
constinteger op div = 4
constinteger op conc = 5
constinteger op and = 6
constinteger op or = 7
constinteger op xor = 8
constinteger op lsh = 9
constinteger op rsh = 10
constinteger op rem = 11
constinteger op exp = 12
constinteger op rexp = 13
constinteger op rdiv = 14
constinteger op not = 15
constinteger op neg = 16
constinteger op abs = 17
constinteger unaries = 15
! opcode indexes...
! simple (no operand) ones first
constinteger NOP = 0
constinteger CWD = 1
constinteger RET = 2
constinteger SAHF = 3
! simple unary math functions
constinteger DEC = 4
constinteger INC = 5
constinteger NEG = 6
constinteger NOT = 7
! simple unary moves
constinteger POP = 8
constinteger PUSH = 9
! two operand moves
constinteger LEA = 10
constinteger MOV = 11
constinteger XCHG = 12
! simple two operand math functions
constinteger ADC = 13
constinteger ADD = 14
constinteger AND = 15
constinteger CMP = 16
constinteger OR = 17
constinteger SUB = 18
constinteger XOR = 19
! slightly more complicated two operand math
constinteger SHL = 20
constinteger SHR = 21
constinteger IDIV = 22
constinteger IMUL = 23
! calls and jumps
constinteger CALL = 24
constinteger JE = 25
constinteger JNE = 26
constinteger JG = 27
constinteger JGE = 28
constinteger JL = 29
constinteger JLE = 30
constinteger JA = 31
constinteger JAE = 32
constinteger JB = 33
constinteger JBE = 34
constinteger JMP = 35
! 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 = 36
constinteger FLDD = 37
constinteger FLDQ = 38
constinteger FSTI = 39
constinteger FSTD = 40
constinteger FSTQ = 41
constinteger FADD = 42
constinteger FSUB = 43
constinteger FSUBR = 44
constinteger FMUL = 45
constinteger FDIV = 46
constinteger FDIVR = 47
constinteger FCMP = 48
constinteger FCHS = 49
constinteger FABS = 50
! Special floating point things
constinteger FSTSW = 51
constinteger FLDZ = 52
constinteger FLDPI = 53
! 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
! Standard IMPish data structures
! Variables are declared here
recordformat varfm(byteinteger type, form, level, scope, dim, c
integer disp, format, size, pbase, extra)
record(varfm)array var(0:max vars)
record(varfm)name decvar
record(varfm) begin
! The compiler is stack based
recordformat stackfm(byteinteger type, form, aform, base, scope, dim, c
integer disp, format, size, pbase, extra, c
integer 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)
! 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 nextcad = 0; ! notional code address (not real - pass3 shuffles stuff)
owninteger level = 0; ! current contextual level
integer sym, next sym; ! 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 decl; ! LAST-DEFINED DESCRIPTOR
integer otype, owntype, ownform; ! Information about OWNs currently being declared
integer spec, frozen, potype; ! More about current declaration
integer dim; ! Dimensions
integer i, j; ! used in the initialisation loops only
owninteger Fp Result Loc = -1; ! Place to store Real and LReal function results
constinteger max dataseg = 12000; ! Size in bytes of data segment table
byteintegerarray datat(0:max dataseg)
owninteger datatp = 0; ! pointer to next data segment byte
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 = ""
ownstring(255) internal id = ""
byteintegername cslen
byteintegerarray current string(0:255); ! current string literal
integer xlen
byteintegerarray xsymbuff(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)
write(v_varno,3);
print string(" : Typ="); write(v_type,1)
print string(" Frm="); write(v_form,1)
print string(" Bse="); write(v_base,1);
print string(" Dsp="); write(v_disp,4)
print string(" Siz="); write(v_size,1)
print string(" Xtr="); write(v_extra,1)
print string(" Fmt="); write(v_format,1)
print string(" Dim="); write(v_dim,1)
print string(" Pba="); write(v_pbase,1)
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
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 <<
routine ret gp tag(integer index)
gp tags(index)_link = gp asl
gp asl = index
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 REFEXT = 12; ! M - external name relative offset code word
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
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;
own byte integer array objectbytes(0:7);
! And corresponding bytes for the listing (not always the same for fudged opcodes)
own integer listptr = 0;
own byte integer array listbytes(0:7);
! 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);
objectptr = 0; ! reset the output pipe
finish
end
! puts a normal code byte into the listing and code pipes
routine putbyte(integer b)
listbytes(listptr) = b;
listptr = listptr + 1;
objectbytes(objectptr) = b;
objectptr = objectptr + 1;
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 8086 address modes...
! DS:[BX+SI]
! DS:[BX+DI]
! SS:[BP+SI]
! SS:[BP+DI]
! DS:[SI];
! DS:[DI];
! DS: [offset16]
! DS: [BX]
! DS:[BX + SI + offset8]
! DS:[BX + DI + offset8]
! SS:[BP + SI + offset8]
! SS:[BP + DI + offset8]
! DS:[SI + offset8]
! DS:[DI + offset8]
! SS:[BP + offset8]
! DS:[BX + offset8]
! DS:[BX + SI + offset16]
! DS:[BX + DI + offset16]
! SS:[BP + SI + offset16]
! SS:[BP + DI + offset16]
! DS:[SI + offset16]
! DS:[DI + offset16]
! SS:[BP + offset16]
! DS:[BX + offset16]
! 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
1, ;! dataseg offset code word
2, ;! const seg offset code word
13, ;! BSS relative code word
3, ;! display seg offset code word
12, ;! external name relative offset code word
20 ;! switch table offset code word
! plant code for a relocated (DATA/BSS/DISPLAY/EXTERNAL) code word
routine relocateoffset(integer reloc, integer offset)
integer tag;
flushcode if reloc # 0; ! so that only the offset is going into the queue
putbyte(offset & 255);
putbyte(offset >> 8);
if reloc # 0 start
tag = reltag(reloc);
writeifrecord(tag, 2, objectbytes);
objectptr = 0; ! clear the queue
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 mod, rm, reloc;
reloc = base>>4;
base = base & 15;
if base = 0 start; ! no register, just a displacement
! mod = 000, rm = 110
putbyte((reg1 << 3) ! 6);
relocateoffset(reloc, disp);
else
if disp = 0 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 = BP start
rm = 6;
else
if base = BX start
rm = 7;
else
if base = DI start
rm = 5;
else
if base = SI start
rm = 4;
else
abort("Internal address mode error");
finish
finish
finish
finish
putbyte((mod << 6)!(reg1 << 3)!rm);
if mod = 1 start
putbyte(disp);
else
if mod = 2 then relocateoffset(reloc, disp)
finish
finish
end
const string(2) array regname(AX:DI) =
"AX", "CX", "DX", "BX", "SP", "BP", "SI", "DI"
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(4) array opname(NOP:JMP) =
"NOP", "CWD", "RET", "SAHF",
"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_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, ;! 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)
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:
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)
switch ops(DEC:JMP)
->ops(opn)
ops(DEC):
putbyte(16_FF);
modrmmem(1, base, disp);
->break;
ops(INC):
putbyte(16_FF);
modrmmem(0, base, disp);
->break;
ops(NEG):
putbyte(16_F7);
modrmmem(3, base, disp);
->break;
ops(NOT):
putbyte(16_F7);
modrmmem(2, base, disp);
->break;
ops(POP):
putbyte(16_8F);
modrmmem(0, base, disp);
->break;
ops(PUSH):
putbyte(16_FF);
modrmmem(6, base, disp);
->break;
ops(IDIV):
putbyte(16_F7);
modrmmem(7, base, disp);
->break;
ops(IMUL):
putbyte(16_F7);
modrmmem(5, base, disp);
->break;
ops(JMP):
putbyte(16_FF);
modrmmem(4, base, disp);
ops(CALL):
putbyte(16_FF);
modrmmem(2, base, disp);
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 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)
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 reg)
if opn = SHL start; ! special "shift by CL"
putbyte(16_D3);
modrmmem(4, base, disp);
else
if opn = SHR start
putbyte(16_D3);
modrmmem(5, base, disp);
else; ! normal stuff
putbyte(opvalue(opn));
modrmmem(reg - AX, base, disp);
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 reg)
if opn = SHL start; ! special "shift by CL"
putbyte(16_D2);
modrmmem(4, base, disp);
else
if opn = SHR start
putbyte(16_D2);
modrmmem(5, base, disp);
else; ! normal stuff
putbyte(op8value(opn));
modrmmem(reg - AL, base, disp);
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)
! 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)
else
displayhint(reg) = 0;
putbyte(opvalue(opn)+2);
modrmmem(reg - AX, base, disp);
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)
putbyte(op8value(opn)+2);
modrmmem(reg - AL, base, disp);
listpreamble;
printstring(opname(opn))
space
printstring(reg8name(reg));
printsymbol(',')
printmemref(base, disp);
newline
flushcode;
end
! Plant a 16 bit 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, 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 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);
->break
else
->ops(opn)
finish
ops(MOV):
putbyte(16_B8 + reg - AX);
relocateoffset(reloc, immed);
->break;
ops(ADD): subop = 0; ->addsub
ops(ADC): subop = 2; ->addsub
ops(CMP): subop = 7; ->addsub
ops(SUB): subop = 5
addsub:
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);
finish
->break;
ops(AND): subop = 4; ->logical
ops(OR): subop = 1; ->logical
ops(XOR): subop = 6
logical:
putbyte(16_81);
modrmreg(subop, reg - AX);
relocateoffset(reloc, immed);
->break;
ops(SHL):
putbyte(16_D1);
modrmreg(4, reg - AX);
->break;
ops(SHR):
putbyte(16_D1);
modrmreg(5, reg - AX);
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
! Since many math operations don't involve relocated addresses
! we provide a chep version of dumprioffset
routine dumpri(integer opn, integer reg, integer immed)
dumprioffset(opn, reg, 0, immed)
end
! Memory (16 bit) immediate operations - can be MOV, Math, or Shift
routine dumpmi(integer opn, integer base, disp, integer immed)
integer subop;
switch ops(MOV:SHR)
->ops(opn)
ops(MOV):
putbyte(16_C7)
modrmmem(0, base, disp)
putbyte(immed & 255)
putbyte(immed >> 8)
->break;
ops(ADD): subop = 0; ->addsub
ops(ADC): subop = 2; ->addsub
ops(CMP): subop = 7; ->addsub
ops(SUB): subop = 5
addsub:
if issmall(immed) # 0 start
putbyte(16_83);
modrmmem(subop, base, disp)
putbyte(immed & 255);
else
putbyte(16_81);
modrmmem(subop, base, disp)
putbyte(immed & 255);
putbyte(immed >> 8);
finish
->break;
ops(AND): subop = 4; ->logical
ops(OR): subop = 1; ->logical
ops(XOR): subop = 6
logical:
putbyte(16_81);
modrmmem(subop, base, disp)
putbyte(immed & 255);
putbyte(immed >> 8);
->break;
ops(SHL):
putbyte(16_D1);
modrmmem(4, base, disp)
->break;
ops(SHR):
putbyte(16_D1);
modrmmem(5, base, disp)
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, integer immed)
integer subop;
switch ops(MOV:SHR)
->ops(opn)
ops(MOV):
putbyte(16_C6)
modrmmem(0, base, disp)
putbyte(immed & 255)
->break;
ops(ADD): subop = 0; ->op80
ops(ADC): subop = 2; ->op80
ops(CMP): subop = 7; ->op80
ops(SUB): subop = 5; ->op80
ops(AND): subop = 4; ->op80
ops(OR): subop = 1; ->op80
ops(XOR): subop = 6
op80:
putbyte(16_80);
modrmmem(subop, base, disp)
putbyte(immed & 255);
->break;
ops(SHL):
putbyte(16_D0);
modrmmem(4, base, disp)
->break;
ops(SHR):
putbyte(16_D0);
modrmmem(5, base, disp)
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)
else
if v_form = constant start
dumprioffset(opn, reg, v_scope, v_disp)
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)
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);
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)
else
if v_form = constant start
dumppushi(v_scope, v_disp)
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_DF, 16_D9, 16_DD, 16_DF,
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 regsiter is implicitly the stack top
routine dumpfloprm(integer opn, integer base, integer disp)
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);
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)
integer jtype, count;
! 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
printsymbol('L');
write(labelid,1)
newline
objectptr = 0; ! zap the current contents of the pipe
count = 0;
if opn = JMP start
jtype = IF JUMP;
else
if opn = CALL start
jtype = IF CALL;
else
jtype = IF JCOND;
objectbytes(0) = (opn - JE);
count = 1;
finish
finish
objectbytes(count) = (labelid & 255);
objectbytes(count+1) = (labelid >> 8);
writeifrecord(jtype, count+2, objectbytes);
! 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;
printstring("CALL EXTERN")
write(labelid, 1);
newline
writeifrecord(IF REFEXT, 2, objectbytes);
objectptr = 0; ! 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
objectbytes(0) = labelid & 255;
objectbytes(1) = labelid >> 8;
writeifrecord(IF LABEL, 2, objectbytes);
displayhint(BX) = 0
displayhint(SI) = 0
displayhint(DI) = 0
end
routine dumpstaticalloc(integer which)
! we pretend to dump "83 ec 00 SUB SP,0000" but we actually plant a special pass 2 directive
putbyte(16_83);
putbyte(16_ec);
putbyte(16_00);
listpreamble;
printstring("SUB SP,00");
newline
objectptr = 0; ! zap the current contents of the pipe
objectbytes(0) = which & 255;
objectbytes(1) = which >> 8;
writeifrecord(IF FIXUP, 2, objectbytes);
end
! Pass 3 goes back and plants the correct preamble code for
! the static allocation based on this directive
routine dumpstaticfill(integer which, integer size)
objectptr = 0; ! zap the current contents of the pipe
objectbytes(0) = which & 255;
objectbytes(1) = which >> 8;
objectbytes(2) = size & 255;
objectbytes(3) = size >> 8;
writeifrecord(IF SETFIX, 4, objectbytes);
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);
objectptr = 0; ! clear the pipe
nextcad = tmp cad; ! restore the real CAD
end
! tell the object file maker what source line we are on
routine dumplinenumber(integer line)
byteintegerarray buffer(0:1);
own integer lastcad = 0; ! code address last time we did this
if nextcad # lastcad start
buffer(0) = (line & 255);
buffer(1) = (line >> 8);
writeifrecord(IF LINE, 2, buffer);
lastcad = nextcad;
finish
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
! 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
! 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
!------------------------------------------------------
! 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
CONST SEGMENT WORD PUBLIC 'CONST'
")
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
_TEXT SEGMENT WORD PUBLIC 'CODE'
")
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 = cotsize 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-1 cycle
cw = contable(i)!(contable(i+1)<<8)
if cw = w then result = i + cotoffset
i = i + 2
repeat
! value wasn't there - first make sure there is space
if cotp > cotsize-2 then flushcot
! now round off the COT
cotp = (cotp + 1) & (¬1)
contable(cotp) = w & 255
contable(cotp+1) = w >> 8
cotp = cotp + 2
result = (cotp - 2) + cotoffset
end
! return the offset in the const segment of a double word
! with value dl:dh
integerfn getcot2(integer dl, dh)
integer i, cwl, cwh
i = 0
cwl = contable(i)!(contable(i+1)<<8)
while i < cotp-3 cycle
cwh = contable(i+2)!(contable(i+3)<<8)
if cwl = dl and cwh = dh then result = i + cotoffset
i = i + 2
cwl = cwh
repeat
! value wasn't there - first make sure there is space
if cotp > cotsize-4 then flushcot
! now round off the COT
cotp = (cotp + 1) & (¬1)
contable(cotp) = dl & 255
contable(cotp+1) = dl >> 8
contable(cotp+2) = dh & 255
contable(cotp+3) = dh >> 8
cotp = cotp + 4
result = (cotp - 4) + 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)
cw1 = contable(i+2)!(contable(i+3)<<8)
cw2 = contable(i+4)!(contable(i+5)<<8)
while i < cotp-3 cycle
cw3 = contable(i+6)!(contable(i+7)<<8)
if cw0 = q0 and cw1 = q1 and cw2 = q2 and cw3 = q3 then result = i + cotoffset
i = i + 2
cw0 = cw1
cw1 = cw2
cw2 = cw3
repeat
! value wasn't there - first make sure there is space
if cotp > cotsize-8 then flushcot
! now round off the COT
cotp = (cotp + 1) & (¬1)
contable(cotp) = q0 & 255
contable(cotp+1) = q0 >> 8
contable(cotp+2) = q1 & 255
contable(cotp+3) = q1 >> 8
contable(cotp+4) = q2 & 255
contable(cotp+5) = q2 >> 8
contable(cotp+6) = q3 & 255
contable(cotp+7) = q3 >> 8
cotp = cotp + 8
result = (cotp - 8) + cotoffset
end
owninteger null string = -1
! get an index into the constant table for the string literal
! in the array s
integerfn getcots(byteintegerarrayname s)
integer i, first, len, match;
len = s(0) + 1; ! number of bytes to search for
! We optimise the Null String "" in comparisons, so we remember
! the location here
if len = 0 start
null string = getcotb(0)
result = null string
finish
first = 0; ! offset to search in contable
while first + len - 1 < cotp cycle; ! so long as there are that many bytes left
match = 1
for i = 0, 1, len-1 cycle
if s(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
if (cotp + len) >= cotsize then flushcot
first = cotp
i = 0;
while len > 0 cycle
contable(cotp) = s(i)
cotp = cotp + 1
i = i + 1
len = len - 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
!------------------------------------------------------
! >> GBYTE <<
! Simple byte in data segment
routine gbyte(integer n)
Abort("Data Seg Overflow") if datatp > max dataseg
datat(datatp) = n & 255;
datatp = datatp + 1
end
! >> GPUT <<
! Put a word into data segment
routine gput(integer n)
gbyte(n & 255)
gbyte(n >> 8);
end
! >> GFIX <<
! round off the datasegment pointer for alignment
routine gfix(integer align)
gbyte(0) while datatp & align # 0
end
routine flush data
integer i
! We output a position hint to the diagnostic stream
selectoutput(listout)
printstring(" ENDS
DATA SEGMENT WORD PUBLIC 'DATA'
")
i = 0
while i < datatp cycle
dumpcdword((datat(i+1) << 8) ! datat(i), 0)
i = i + 2;
repeat
! and send another hint
selectoutput(listout)
printstring(" DATA ENDS
")
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
_SWTAB SEGMENT WORD PUBLIC '_SWTAB'
")
i = 0
while i < swtp cycle
dumpcdword(swtab(i), 2)
i = i + 1
repeat
! and send another hint
selectoutput(listout)
printstring(" _SWTAB ENDS
")
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
! >> READ TAG <<
integerfn read tag
integer s1, s2
s1 = next sym
readsymbol(s2)
readsymbol(next sym)
result = s1<<8!s2
end
! >> GET D <<
! 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
routine get d
integer n
longreal p
n = read tag; read symbol(next sym); ! char count, skip comma
rvalue = 0
! Start with the bit ahead of the decimal point
cycle
sym = next sym; read symbol(next sym)
exit if sym = '.'
n = n-1
-> power if sym = '@'
rvalue = rvalue*10+(sym-'0')
-> SIGN if n = 0
repeat
p = 1
cycle
n = n-1; -> SIGN if n = 0
sym = next sym; read symbol(next sym)
-> POWER if sym = '@'
p = p/10
rvalue = rvalue + (sym-'0')*p
repeat
POWER:
n = read tag
! somewhat clunky so that we can be portable to a system that
! doesn't do exponents
while n > 0 cycle
rvalue = rvalue * 10
n = n - 1
repeat
while n < 0 cycle
rvalue = rvalue / 10
n = n + 1
repeat
SIGN: ! sign of whole value
if next sym = 'U' start
read symbol(next sym)
rvalue = -rvalue
finish
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) & (¬1); ! 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 = gp tags(cell)_addr;
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
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")
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; ->out1
finish
sw(a in s):
sw(av in s):
! change (X in S) to (X in REC)
v_form = v_form + 3; v_extra = t; -> OUT1
sw(v in r): v_form = v in s; v_disp = t
v_type = type
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)
else
type = integer
t = getwork(2)
dumpmr(MOV, BP,t, 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
! >> FPU REG <<
! Returns the next register on the FPU stack
integerfn fpu reg
result = FR0 + FPU Stack
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, DISPLAY, lev*2)
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 bytes 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)
dumpextcall(n)
if space # 0 then dumpri(ADD, SP, space)
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, fp; ! Actual parameter & formal parameter ptrs, used to copy parms to parm area
record(stackfm)name lhs, rhs; ! General stack pointers
record(stackfm) temp; ! A stack record for shuffling and copying
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 First label; ! First label at this level
integer old frame; ! Previous level's static allocation
integer i, j, k, n, t
integer opr, val, dv
routinespec compile to string(record(stackfm)name v)
routinespec load(record(stackfm)name v, integer reg)
routinespec assign(integer assop)
routinespec array ref(integer mode)
routinespec operate(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
! >> DEFINE VAR <<
routine define var
integer type, form, tf, size, format, s, new, round, dimension
integer dv; ! dope vector offset
owninteger prim no = 0
internal id = ""; new = 0; round = align
! Get the var index
decl = read tag
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") if decl >= parms
decvar == var(decl)
if decl > names start
names = decl; new = 1
decvar = 0
finish
finish
! Now get the variable name
cycle
sym = next sym; read symbol(next sym); exit if sym = ','
if length(internal id) # 255 start
internal id = internal id.to string(sym)
finish
repeat
! Now read the type and form word
tf = read tag; read symbol(next sym)
type = tf>>4; form = tf&15
! And get the size/format word
size = read tag; read symbol(next sym)
! 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)
else
if type = real start; ! REAL
type = lreal if size = 4; ! LONG REAL
size = vsize(type)
else
if type = record start; ! record
format = size
decvar_format = format
size = var(format)_size if format <= names
else
if type = string start; ! string
round = 0
decvar_size = size
size = size + 1
else
size = vsize(type)
finish
finish
finish
finish
decvar_size = size if type # string
decvar_type = type; decvar_form = form
! Now read the Scope word
otype = read tag
spec = (otype>>3)&1; dimension = otype>>8&255; otype = otype&7
if otype # 0 start; ! Set external linkage name if appropriate
if otype >= external start
if length(alias) # 0 start
external id = alias
else
if otype = system start
external id = system prefix.internal id
else
external id = "_".internal id
finish
finish
otype = external if otype <= dynamic; !external, system, dynamic
finish
finish
alias = ""
if 7 <= form and form <= 10 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_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
return
finish
otype = 0; size = 2; data size = 2; ! procedure parameter
else; ! This is not a procedure declaration
data size = size
if form # 1 start
Round = Align
if type = general start; ! General %name
decvar_extra = in params; ! FOR LABELS
size = 4
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 = 2 if form = name array
else
if form = array name or form = name array name start
decvar_dim = dimension
size = 4; round = align; ! array header
else
size = 2; ! integer (etc) %name
finish
finish
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 = 1; ! use actual size for plain strings
if form = 2 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 = 2 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
fill external(DATA, decvar_disp, external id) if otype = external
finish
else
decvar_level = 0; decvar_scope = EXT
decvar_disp = external ref(external id)
finish
return
finish
if form = 3 start; !%label
decvar_disp = new tag
return
finish
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
return
finish
if form = record format start
if in params # 0 start
frame = decvar_size if decvar_size > frame
else
block type = -1; spec = -1
finish
return
finish
! 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
else; ! parameter or record
if block type > 0 start; ! procedure parameters
frame = (frame + size + 1) & (¬1); ! parameters are always word aligned
decvar_disp = frame; ! offset will be adjusted at '}'
else; ! 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
! >> PUSH 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 push var(integer var no)
record(varfm)name w
constbyteintegerarray fmap(0:15) = c
0, 4, 6, 10, 4, 0,
! 0, v in s, a in s, pgm label, recordformat, 0,
6, 0, 1, 4, 1, 4, 6, 4, 6, 0
! switch, 0, v in r, v in s, v in r, v in s, a in s, v in s, a in s, 0
abort("Push 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
top_scope = w_scope
top_type = w_type
! AFORM contains the real original declared form, while
! FORM contains the on-the-stack subset of possible forms
top_aform = w_form
top_form = fmap(w_form)
top_dim = w_dim
top_disp = 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 Const")
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_type = integer
top_form = constant
monitor(top, "push const") if diagnose&1 # 0
end
!-----------------------------------------------------------------------
!STRING PROCESSING
!-----------------------------------------------------------------------
! >> DUMP STRING <<
! writes the latest received string (in Current String) to
! either const or data segment (depending on SIZE). Returns
! the offset in that segment of the string. The size of space
! to reserve is in SIZE. In the special case where SIZE is zero
! this is a fixed constant string and can be re-used in the
! constant table, otherwise we put it in the data segment
integerfn dump string(integer size)
integer j, p
if size = 0 start; ! Fixed constant string
result = getcots(current string)
finish
! check for overflow
if cslen+1 > size start
! String constant too long - warn and truncate
warn(5); current string(0) = size-1
finish
p = datatp
for j = 0,1,size-1 cycle
gbyte(current string(j))
repeat
result = p
end
! >> GET STRING <<
! Read a string literal from the iCode stream
routine get string
integer l
l = next sym; !length
cslen = 0
while l > 0 cycle
l = l-1
read symbol(next sym)
cslen = (cslen+1)&255; current string(cslen) = next sym
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
readsymbol(next sym)
if next sym # 'A' and next sym # '$' start
otype = con; ! anonymous %const
push const(dump string(0)); top_type = string
top_base = 0; top_scope = COT; top_form = VinS; top_format = cslen+1
else
push const(0); ! explicit string initialisation coming next
finish
end
! >> REAL CONSTANT <<
! Put the current rvalue in the constant table, return the offset
integerfn real constant
integer w1, w2, w3, w4
! Warning - this is horribly non-portable, and relies on this
! being a native compiler. For cross-compiling, think again!
! It's also a wee bit messy 'cos we've redefined the word INTEGER
! so we can't use the built-in map!
w1 = byteinteger(addr(rvalue)) ! byteinteger(addr(rvalue)+1)<<8
w2 = byteinteger(addr(rvalue)+2) ! byteinteger(addr(rvalue)+3)<<8
w3 = byteinteger(addr(rvalue)+4) ! byteinteger(addr(rvalue)+5)<<8
w4 = byteinteger(addr(rvalue)+6) ! byteinteger(addr(rvalue)+7)<<8
result = getcot4(w1, w2, w3, w4)
end; ! real constant
!-------------------------------------------------------
!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
dump jump(op, l_tag & 16_7FFF)
if op = JMP then uncond jump = nextcad
end; ! jump to
!-------------------------------------------------------
! 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
form = v_form - 3; ! X in REC => X in S
type = v_type
disp = v_disp
! 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
load(v, anyp)
v_type = type; v_form = form
v_disp = disp; 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) =
-1, -2, -3, -4, 5, -5, 4, 8, -6, 7,
! -1, -2, -3, -4, av in s, -5, v in s, av in rec, -6, v in rec,
-7, -8, -9, -10, -11 , -12
! -7, -8, -9, -10, -11 {PGM LABEL}, -12 {record format}
! 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 = AVinS start
if v_base = 0 then f = constant else f = VinR
else
if (f = VinREC or f = AVinREC) start; ! eliminate redundant LOAD
if f = VinREC then f = AinS else f = VinS
v_disp = v_extra
finish
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) =
4, 4, -1, -2, 6, 4, -3, 9, 7
! 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)
load(v,anyp)
v_type = t; v_form = VinS
finish
f = var map(v_form); abort("VMap") if f < 0
v_form = f
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, r
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
load(v, any)
finish
finish
return
finish
! It is possible to end up with an in-store form, but the
! base register isn't one that can be used in an address...
if v_base # 0 and v_base < BX start
r = PT Reg; claim(r)
dumprr(MOV, r, v_base); release(v_base)
v_base = r
finish
return if form = V in S
if form = A in S start
v_form = V in S; v_type = integer
load(v,anyp)
v_type = type; v_form = V in S; v_disp = 0
finish
end; ! address
! >> LOAD <<
! Load variable V into register R
! Along the way any register the variable owned is released, and
! the new register is claimed.
routine Load(record(stackfm)name v, integer r)
switch f(0:9)
integer ptr, op
monitor(v, "LOAD") if diagnose&2 # 0
if r = anyf then ->reals
! 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)
else
if v_base # 0 and v_base < BX and v_form >= V in S start
ptr = pt reg
dumprr(MOV, ptr, v_base)
claim(ptr); release(v_base)
v_base = ptr
finish
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, 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
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(constant):
ldconst:
if v_disp = 0 and v_scope = 0 start
dumprr(XOR, r, r)
else
dumprioffset(MOV, r, v_scope, v_disp)
finish
setup: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)
-> setup
f(av in r):
f(a in r):
Abort("Unexpected Stack Form")
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)
release(v_base); claim(ptr)
v_base = ptr
v_disp = 0
v_scope = 0
! fall through to normal V in S
f(v in s):
if v_type = integer start
dumprm(MOV, r, v_base!v_scope, v_disp)
else
if v_type = byte start
dumprm8(MOV, r+16, v_base!v_scope, v_disp)
dumprr8(XOR, r+20, r+20)
v_type = integer
else; ! reals
abort("Load Real")
finish
finish
release(v_base)
->setup
f(av in s):
if v_base # 0 start
dumprm(LEA, r, v_base!v_scope, v_disp)
release(v_base)
v_type = integer
->setup
finish
! else
->ldconst
f(v in rec):
f(av in rec):
f(a in rec):
reduce(v)
->f(v_form)
! Equivalents for real numbers...
reals:; ! 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 load(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(2)
dumpmr(MOV, BP, v_disp, 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)
-> set up real
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)
release(v_base)
set up real:
v_base = r
claim(r)
v_disp = 0;
v_form = v in r
v_type = real
end
! >> OPERATE <<
! perform the operation OP on the top two elements of the stack.
! (single element for unary operators)
routine operate(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) =
14, 18, 23, 22, 0, 15, 17, 19, 20, 21, 22, 0, 0, 0, 7, 6, 0
! add, sub, mul, div, conc,and,or, xor, lsh, rsh, rem, exp, rexp, rdiv, not, neg, abs
constintegerarray flopmap(1:17) =
42, 43, 45, 46, 0, 0, 0, 0, 0, 0, 0, 0, 0, 46, 0, 49, 50
! fadd, fsub, fmul, fdiv, 0, 0, 0, 0, 0, 0, rem, exp, rexp, fdiv, 0, fchs, fabs
constintegerarray indec(-1:1) = 4, 0, 5; ! 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 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 next sym = 'S' or next sym = '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(op not):
oper(op neg):
! we optimise for e.g. fred = -fred as one instruction
if assign pending # 0 then start
read symbol(next sym)
address(rhs)
if rhs_type = byte start
dumpum8(opmap(op), rhs_base!rhs_scope, rhs_disp)
else
dumpum(opmap(op), rhs_base!rhs_scope, rhs_disp)
finish
pop rel
pop rel
return
finish
load(rhs, any)
dumpur(opmap(op), rhs_base)
return
! 8086 has no "abs" instructions, so we do a test and jump
oper(op abs):
load(rhs, any)
dumpri(CMP, rhs_base, 0)
work = new tag
dumpjump(JGE, work)
dumpur(NEG, rhs_base)
dumplabel(work)
return
oper(op add):
if lhs_form = constant then swap
! and fall through to minus
oper(op sub):
! 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 and c
(lhs_type = integer or control & check capacity = 0 or Next Sym = 'j') then start
readsymbol(next sym) ; ! 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 = op sub 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)
else
dumpum(indec(value), lhs_base!lhs_scope, lhs_disp)
finish
else
if lhs_type = byte start
dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
else
dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
finish
finish
finish
else; ! RHS not a constant
load(rhs, any)
if lhs_type = byte start
dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
else
dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, 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 = op sub 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
load(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 = op add and rhs_form = v in r then swap; ! commutative, so flip it
load(lhs, any)
if rhs_type = byte start
load(rhs, any)
else
address(rhs)
finish
dumprv(opmap(op), lhs_base, rhs)
finish
pop rel; ! the RHS
return
oper(op and):
oper(op or):
oper(op xor):
! 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(next sym); ! 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, rhs_disp)
else
dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_disp)
finish
else; ! RHS not a constant
load(rhs, any)
if lhs_type = byte start
dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, rhs_base+16)
else
dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, 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
load(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
load(lhs, any)
if rhs_type = byte and op = op and start; ! AND needs all the bits to make sense
load(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)
else
dumprv(opmap(op), lhs_base, rhs)
finish
finish
pop rel; ! the RHS
return
oper(op mul):
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 = op lsh
-> 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:
load(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)
finish
pop rel
return
oper(op div):
oper(op rem):
load(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)
finish
pop rel
if op = op div then start
lhs_base = AX
else
lhs_base = DX
release(AX)
claim(DX)
finish
return
oper(op lsh):
oper(op rsh):
shift it:
if assign pending # 0 and c
(op = op rsh or lhs_type = integer or control & check capacity = 0 or Next Sym = 'j') then start
readsymbol(next sym); ! we will do the assignment ourselves
address(lhs); ! make LHS accessible
! Note that in-register shifting it is actually quicker for small
! constant shifts to plant multiple "shift by one" instructions than
! it is to load up CL with the shift count. That is NOT true for
! in-store shifts, since there's a fetch and store for every bit shift
! Hence the test for disp = 1 below
if rhs_form = constant and rhs_disp = 1 start
if lhs_type = byte start
dumpmi8(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
else
dumpmi(opmap(op), lhs_base!lhs_scope, lhs_disp, 1)
finish
else; ! RHS not a one
! 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
! "load(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)
else
load(rhs,CX)
finish
if lhs_type = byte start
dumpmr8(opmap(op), lhs_base!lhs_scope, lhs_disp, CL)
else
dumpmr(opmap(op), lhs_base!lhs_scope, lhs_disp, 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
if value <= 4 then start; ! plant individual shift 1 instructions
load(lhs, any)
while value > 0 cycle
dumpri(opmap(op), lhs_base, 1)
value = value - 1
repeat
else
load(rhs, CX)
load(lhs, any)
dumprr(opmap(op), lhs_base, CX)
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
! "load(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)
release(rhs_base)
rhs_base = CX
claim(CX)
else
load(rhs,CX)
finish
load(lhs, any)
dumprr(opmap(op), lhs_base, CX);
finish
pop rel
return
oper(op exp):
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
load(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
load(lhs, any)
dumpur(PUSH, lhs_base)
release(lhs_base)
perm(iexp, 4)
lhs_base = AX; claim(AX)
lhs_form = V in R
return
oper(op rexp):
oper(op rdiv):
abort("Oper unexpected op")
!-----------------------------------------------
! Fold constant expressions at compile time
fold(op neg): value = -rhs_disp; -> set unary
fold(op not): value = ¬rhs_disp; -> set unary
fold(op abs): value = rhs_disp; if value < 0 then value = -value; -> set value
fold(op add): value = lhs_disp + rhs_disp; -> set value
fold(op sub): value = lhs_disp - rhs_disp; -> set value
fold(op or): value = lhs_disp ! rhs_disp; -> set value
fold(op and): value = lhs_disp & rhs_disp; -> set value
fold(op xor): value = lhs_disp !! rhs_disp; -> set value
fold(op lsh): value = lhs_disp << rhs_disp; -> set value
fold(op mul): value = lhs_disp * rhs_disp; -> set value
fold(op rsh): value = lhs_disp >> rhs_disp; -> set value
fold(op exp): 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(op rem):
fold(op div): value = rhs_disp;
warn(1) and value = 1 if value = 0
value = lhs_disp // value
if op = op div then -> set value
value = lhs_disp - (rhs_disp * value)
-> set value
fold(op rexp): abort("No reals yet")
fold(op rdiv): abort("No reals yet")
set value:
pop stack
set unary:
top_disp = value
return
fold(op conc): abort("Fold Conc")
!--------------------------------------------------------------------
! String operations - the only one is concatenate...
oper(op conc):
if assign pending # 0 start; ! It's S = S.T
amap(lhs)
load(lhs, any)
dumpur(PUSH, lhs_base)
amap(rhs)
load(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
pop rel
dumppushi(0, lhs_size)
if Next Sym = 'S' then perm(sconc, 6) else perm(sjconc, 6)
! and finally, skip the pending assignment, and drop the LHS
readsymbol(Next Sym)
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
load(top, any)
dumpur(PUSH, top_base)
pop rel
amap(lhs)
load(lhs, any)
dumpur(PUSH, lhs_base)
release(lhs_base)
dumppushi(0, 255)
perm(smove, 6)
! 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)
load(top, any)
dumpur(PUSH, top_base)
poprel
amap(rhs)
load(rhs, any)
dumpur(PUSH, rhs_base)
pop rel
dumppushi(0, lhs_size)
perm(sconc, 6)
return
Reals:
if op < Unaries then load(lhs, anyf)
if op # op rexp then load(rhs, anyf)
->roper(op)
roper(op neg):
roper(op abs):
dumpfloprr(flopmap(op), rhs_base, rhs_base)
return
roper(op add):
roper(op mul):
! Commutative, so we don't care
if lhs_base > rhs_base then swap
dumpfloprr(flopmap(op), lhs_base, rhs_base)
pop rel
return
roper(op sub):
roper(op div):
roper(op rdiv):
! 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(op rexp):
! This is implemented as a PERM routine
load(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)
release(lhs_base)
perm(fexp, 10)
! Since rexp is actually a standard C routine, the result will
! be in store, pointed to by AX...
lhs_base = AX; claim(AX)
lhs_form = V in S; lhs_disp = 0; lhs_scope = 0
lhs_type = lreal
load(lhs, anyf)
return
roper(op not):
roper(op and):
roper(op or):
roper(op xor):
roper(op rem):
roper(op lsh):
roper(op rsh):
roper(op exp):
abort("Unsupported Real Operation")
end; ! operate
! >> 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, t, 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
load(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
load(rhs, anyf)
pt = ptreg
dumpri(SUB, SP, s)
dumprr(MOV, pt, SP)
dumpfloprm(op, pt, 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, rhs_disp)
else
load(rhs, any)
dumpmr(MOV, lhs_base!lhs_scope, lhs_disp, 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, 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)
release(rhs_base)
rhs_base = pt; rhs_form = V in R; rhs_type = Integer
claim(pt)
else
load(rhs, any)
! ABD - should add a capacity check here
finish
dumpmr8(MOV, lhs_base!lhs_scope, lhs_disp, rhs_base+16)
finish
else
load(rhs, anyf)
if lhs_type = real start
op = FSTD
else; ! long real
op = FSTQ
finish
dumpfloprm(op, lhs_base!lhs_scope, lhs_disp)
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
push 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 * 2; 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 + 2
finish
lh_disp = lh_disp+2
store(lh, temp)
release(temp_base)
lh_disp = lh_disp-2
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 + 2
amap(temp)
else
temp = 0
temp_type = integer
temp_disp = (rh_size << 4) + genmap(t)
finish
amap(rh)
store(lh, rh)
lh_disp = lh_disp + 2
store(lh, temp)
release(temp_base)
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)
load(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)
load(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+1) & (¬1)
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)
load(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)
load(rh, any)
dumpur(PUSH, rh_base)
pop rel
pop rel
dumppushi(0, lh_size)
if assop = 2 then perm(sjam, 6) else perm(smove, 6)
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
load(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 = 2
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)
operate(op mul)
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
load(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 + 2; ! Dope Vector address follows A(0)
dumpvpush(top)
pop rel
perm(aref, (av_dim * 2) + 2); ! DV word, plus a word for every subscript
push const(0)
top_form = V in R; top_base = AX; claim(AX)
finish
load(top, anyp); ! make sure index is in a pointer register
operate(op add)
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); ! simple arrays have compile-time DV's in the COT
perm(aref, 4)
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
load(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
load(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)
abort("Compare Records")
end
! >> COMPARE REALS <<
routine compare reals(record(stackfm)name l,r)
load(l, anyf)
load(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)
load(l, any)
dumpur(PUSH, l_base)
amap(r)
load(r, any)
dumpur(PUSH, r_base)
perm(scomp, 4)
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))
return
finish
load(l,any)
if r_type = byte start
load(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?
load(top, any)
dumpur(PUSH, top_base)
pop rel
amap(top); ! B
load(top, any)
dumpur(PUSH, top_base)
pop rel
if flag&2 = 0 then push const(0) else amap(top); ! A missing?
load(top, any)
dumpur(PUSH, top_base)
pop rel
amap(top); ! S
load(top, any)
dumpur(PUSH, top_base)
pop rel
perm(sresln, 8)
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
dumprm(MOV, BX, DISPLAY,level*2);
dumpur(PUSH, BX);
dumpur(PUSH, BP);
dumprr(MOV, BP,SP);
dumpmr(MOV, DISPLAY, level*2, BP);
cad = nextcad;
dumpstaticalloc(cad); ! plants code to subtract static allocation (if any) from SP
result = cad;
end
! >> DUMP RETURN <<
routine dump return
return if uncond jump = next cad; ! can't get here ?
dumprr(MOV, SP, BP);
dumpur(POP, BP);
dumpur(POP, BX);
dumpmr(MOV, DISPLAY, level*2, BX);
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 = COT; v_disp = getcots(current string)
else
tmp = getwork(2)
load(v,anyg); ! Must be a byte-addressable register
dumpri(AND, v_base, 255)
dumpri(OR, v_base, 16_0100)
dumprr8(XCHG, v_base+16, v_base+20)
dumpmr(MOV, BP, tmp, v_base)
release(v_base)
v_base = BP; 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):; ! REM
operate(op rem); return
b(2):; ! FLOAT
load(top, anyf)
return
b(3):; ! TO STRING
compile to string(top)
return
b(4):; ! ADDR
amap(top)
return
b(11):; ! LENGTH
push const(0); ! length is charno zero
b(12):; ! CHARNO
amap(stack(stp-1))
operate(op add); !LHS&RHS reversed in operate??
-> map it
b(7):; ! STRING
b(5):b(6):; ! INTEGER, BYTE
b(8):; ! RECORD
b(9):b(10):; ! REAL, LONG REAL
map it:
vmap(top); top_type = new type(t)
top_size = v size(top_Type)
return
b(13):; ! type of(..)
b(14):; ! size of(..)
if top_type # general start; ! type explicitly specified
if t = 14 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 + 2; ! reference property-word
top_form = V in S; top_type = integer
if t = 14 start; ! type of
push const(15); operate(op and)
else; ! size of
push const(4); operate(op rsh)
finish
finish
return
b(15):; ! INT(real)
load(top, anyf)
release(top_base)
p = getwork(2)
dumpfloprm(FSTI, BP, p)
top_type = integer
top_form = V in S
top_base = BP
top_disp = p
return
finish
! -- 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)
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); ! 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
v_base = AX; ! Result is always in AX
v_disp = 0; ! Clear this for MAP results
claim(AX)
if (v_type = real or v_type = lreal) and v_aform = 8 start
! Floating result will be in the "FAC" location, pointed at by AX
! In other words, it comes out like a %map. Unfortunately the
! FAC location is global, so we need to copy it back out of there
! before somebody steps on it
v_form = V in S
load(v, anyf)
finish
finish
finish
end; ! call
! >> COMPILE FOR <<
routine compile for
record(stackfm)name cv, iv, inc, fv
integer lab, 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
load(v,any); r = v_base
t = getwork(2)
dumpmr(MOV, BP,t, 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)
lab = read tag
stab(fv,integer)
stab(inc,integer)
if cv_form # v in s or (cv_base # 0 and activity(cv_base) >= 0) start
n = cv_type
amap(cv)
stab(cv, n)
cv_form = a in s
finish
push copy(cv)
push copy(iv)
push copy(inc);
operate(op sub)
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
operate(op add)
assign(1)
end; ! for
!--------------------------------------------------------------
! Code for ASSEMBLE starts here...
First Name = Names
First Label = Labs
Proc Var == Decvar
last skip = -1
old frame = frame
frame = 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 ?
external id = program ep; ! linkage to program entry
otype = external; potype = otype
finish
static alloc = enter
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 ---
next: sym = nextsym; read symbol(nextsym)
if sym < 33 or sym > 127 then start
selectoutput(0)
printsymbol('('); write(sym, 1); printsymbol(','); write(nextsym, 1); printsymbol(')')
abort("Bad I Code")
finish
-> c(sym)
c('l'): if read tag # 0 then abort("Language")
->next; ! We only support standard IMP
c('O'):; ! Set line number
abort("Stack?") if stp # 0
abort("Claimed") if claimed # 0
current line = read tag
! 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
->next
c('$'): define var; ->next; ! Define VAR
c('b'):; ! Define constant bounded Dope Vector
vub = top_disp; pop stack
vlb = top_disp; pop stack
->next
! 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
gput(byteinteger(addr(rv32))!byteinteger(addr(rv32)+1)<<8)
gput(byteinteger(addr(rv32)+2)!byteinteger(addr(rv32)+3)<<8)
-> done
ot(string): i = dump string(data size); ! need result for const strings
if decvar_scope = COT then decvar_disp = i
-> done
ot(record): for i = 1,1,data size cycle
gbyte(0)
repeat
-> done
ot(byte): gbyte(ownval); -> done
ot(lreal): gput(byteinteger(addr(rvalue))!byteinteger(addr(rvalue)+1)<<8)
gput(byteinteger(addr(rvalue)+2)!byteinteger(addr(rvalue)+3)<<8)
gput(byteinteger(addr(rvalue)+4)!byteinteger(addr(rvalue)+5)<<8)
gput(byteinteger(addr(rvalue)+6)!byteinteger(addr(rvalue)+7)<<8)
done:
end
c('A'):; ! Initialise OWN variable
i = read tag; ! Number of values to assign
if stp # 0 start; ! Value supplied?
own val = top_disp
pop stack
if own type = real or own type = lreal start
rvalue = own val; ! copy integer supplied into floater
finish
else; ! initialise to default pattern
ownval = 0
cslen = 0; ! in case it's a string
finish
if own form = array or own form = name array start
adump for j = 1,1,i
else
if otype = 0 start ; ! %const .... %name
Abort("Constant Name");
else
! constant strings are treated as literals - everything else is "DATA"
if otype = con and own type = string start
decvar_scope = COT
else
decvar_scope = DATA
finish
decvar_level = 0; decvar_disp = datatp
adump
finish
finish
->next
c(''''): get string; ->next; ! Stack string constant
c('G'): get string; ! Alias for item about to be declared
alias = ""
for j = 1, 1, cslen cycle
alias = alias.tostring(current string(j))
repeat
pop stack
->next
c('N'):; ! Stack integer constant
! pass1 is 32 bit, but we are only 16 bit
j = read tag; ! discard the low half
push const(read tag); ->next
c('D'):; ! Stack real constant
get d; ! suck the value into rvalue
push const(0) and ->next if rvalue = 0
->next if next sym = 'A'
otype = con; ! anonymous %const
j = real constant; ! N.B. ** %fn + side-effect **
push const(0)
top_type = lreal; top_scope = COT; top_disp = j; top_form = v in s
->next
c('n'):; ! Select member from record format
! 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
i = read tag
push var(var(top_format)_pbase - i); ! 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 = lhs_disp + top_disp
lhs_form = lhs_form - v in s + top_form
else
if lhs_form = a in rec start
lhs_form = VinRec; lhs_type = integer
load(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
->next
c('@'):; ! Stack variable descriptor
push var(read tag)
->next
c('E'):compile call(top); ! Call procedure
->next
c('M'):; ! MAP result
amap(top)
load(top, AX)
pop rel
dump return
->next
c('V'):; ! FN result
if procvar_type = integer start
load(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
load(top, anyf)
pop rel
if fp result loc = -1 start; ! clunky allocation coming up
gfix(align)
fp result loc = datatp
gput(0); gput(0); gput(0); gput(0)
finish
if procvar_type = real start
dumpfloprm(FSTD, DATA, fp result loc)
else
dumpfloprm(FSTQ, DATA, fp result loc)
finish
dumprioffset(MOV, AX, DATA, fp result loc)
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 = 6; ! At the offset of the last parameter
lhs_form = a in s
assign(1)
finish
finish
c('R'):; ! RETURN
dump return
->next
c('K'):; ! false
k = 0; -> true false
c('T'):; ! true
k = -1
true false:
dumpri(MOV, AX, k)
dump return
->next
c('a'): array ref(0); ->next
c('i'): array ref(1); ->next
c('.'): operate(op conc); ->next
c('+'): operate(op add); ->next
c('¬'): operate(op not); ->next
c('U'): operate(op neg); ->next
c('-'): operate(op sub); ->next
c('!'): operate(op or); ->next
c('%'): operate(op xor); ->next
c('&'): operate(op and); ->next
c('['): operate(op lsh); ->next
c(']'): operate(op rsh); ->next
c('*'): operate(op mul); ->next
c('/'): operate(op div); ->next
c('Q'): operate(op rdiv); ->next
c('X'): operate(op exp); ->next
c('x'): operate(op rexp); ->next
c('v'): operate(op abs); ->next
c('j'): assign(2); ->next; ! JAM transfer
c('S'): assign(1); ->next; ! Normal value assignment
c('Z'): assign(0); ->next; ! Assign address '=='
c('p'): assign(-1); ->next; ! Pass a parameter
c('u'): opr = op add; ->uq common; !++
c('q'): opr = op sub; !--
uq common:
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)
operate(op mul)
operate(k)
vmap(top); top_type = t
->next
c('k'): dumpri(CMP, AX, 0); ! Branch on FALSE (= 0) ! Branch =
c('='): opr = JE; -> cond
c('t'): dumpri(CMP, AX, 0); ! Branch on TRUE (# 0)
c('#'): opr = JNE; -> cond
c('<'): if invert # 0 then opr = JG else opr = JL; -> cond
c('>'): if invert # 0 then opr = JL else opr = JG; -> cond
c('('): if invert # 0 then opr = JGE else opr = JLE; -> cond
c(')'): if invert # 0 then opr = JLE else opr = JGE; -> cond
cond:
! move the > and < operators to unsigned versions if needed
if compare unsign # 0 and opr >= JG then opr = opr + 4
compare unsign = 0
val = read tag
jump to(val, opr, 1); invert = 0
->next
c('C'):; ! Compare addresses
amap(top); amap(stack(stp-1)); ! fall through to values
c('?'):; ! Compare values
LHS == stack(stp-1)
RHS == top
compare(lhs,rhs)
pop rel
pop rel
->next
c('"'):; ! Compare values, double sided
LHS == stack(stp-1)
RHS == top
load(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
->next
c('r'): resolve(read tag); ->next
c('_'):; ! Define switch label
uncond jump = 0
v == var(read tag)
j = top_disp; pop stack
t = new tag
dumplabel(t);
swtab(v_disp+j) = t;
->next
c('W'):; ! Jump to switch
v == var(read tag)
push const(1); operate(op lsh); ! subscript X 2
load(top, anyp)
dumpum(JMP, SWT!top_base, v_disp * 2); ! swtab is word-size, hence * 2
pop rel
uncond jump = next cad
->next
c('B'):; ! Backward Jump
val = read tag
jump to(val, JMP, 0);
->next
c('F'):; ! Forward Jump
val = read tag
if val = 0 then start
if last skip # next cad then start
skip proc = new tag
dumpjump(JMP, skip proc)
finish
->next
finish
jump to(val, JMP, 1)
->next
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
c('J'):; ! Jump to user label
dumpjump(JMP, user label(read tag))
->next
c('L'):; ! Define user label
dump label(user label(read tag))
->next
c(':'):; ! Define compiler label
j = read tag
if j = 0 start
dump label(skipproc)
last skip = next cad
Uncond Jump = 0
-> next
finish
define label(j); ->next
c('f'):; ! FOR loop header
compile for; ->next
c('w'):; ! Machine code
abort("Machine Code")
! ->next
c('P'):; ! Machine code literal
abort("Machine Literal")
! cput(top_disp)
! pop stack
! ->next
c('y'):; ! diagnose n
j = read tag
if (j>>14)&3 = 2 start; ! it's for pass 2
diagnose = j & 16_3FFF
else
!***** should pass onto next pass ******
finish
->next
c('z'):; ! control n
control = read tag; ->next
c('m'):; ! monitor
j = -1; -> SIGNAL EVENT
c('s'):; ! stop
j = 0; -> SIGNAL EVENT
c('e'):; ! signal event
j = read tag
SIGNAL EVENT:
push const(0) while stp < 2
push const(j)
load(top, any); dumpur(PUSH, top_base); pop rel
load(top, any); dumpur(PUSH, top_base); pop rel
load(top, any); dumpur(PUSH, top_base); pop rel
perm(signal, 6)
uncond jump = next cad
->next
c('o'):; ! on event block
->next
c('h'):; ! compiler op(n)
! compiler op(tag)
->next
c('g'):; !array formats
c('d'):
! in params: =0 -> simple array, # 0 -> array-in-record
! First get dimensions
dim = read tag; abort("Array Dim") unless 0 < dim < 3
! Now get number of (previously declared) array variables we are defining
read symbol(next sym); n = read tag
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 * 4)+4))&(¬1); ! space for :Dim:<bound pairs>:DataSize:
dv = frame
! First store the dimension
dumpmi(MOV, BP, dv, dim)
! And the data size is also constant
dumpmi(MOV, BP, dv + (dim*4) + 2, 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*2), lhs_disp)
else
load(lhs, any)
dumpmr(MOV, BP, dv + (i*2), 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)
dumpur(PUSH, AX)
perm(adef, 2)
! 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)
operate(op add)
push const(data size)
operate(op mul)
push copy(stack(stp-1)); ! suck up the lower bound
push const(data size)
operate(op mul)
! top is now the lower bound, next is the upper, and a bogus copy of lb is next
load(top, any); ! Make sure this is in a register
lhs == top; ! Point to it
pop stack; ! and drop (without release) this copy
load(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); ! 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 j = 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 - 4; ! 2-word header
decvar_disp = frame
if decvar_form = array or decvar_form = namearray c
then decvar_form = decvar_form + 1; ! force arrayname
dumprr(SUB, t, rhs_base);
dumpmr(MOV, BP, frame, t); ! store a(0) address
dumpmr(MOV, BP, frame+2, 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
dumprr(MOV,SP,t)
release(lhs_base)
release(rhs_base)
release(dv)
finish
->next
c('^'):; ! {Set Format}
top_type = record
top_format = read tag
->next
c('I'): Abort("Pascal?");! {ESCAPE for Pascal etc.}
c('~'):; ! alternate record format
sym = next sym; read symbol(next sym)
if sym = 'A' start; ! alt start
decvar == procvar
assemble(-2,labs,names)
->next
finish
if sym = 'B' then -> out; ! alt end
abort("Alt Record") if sym # 'C'; ! faulty intermediate code
! Compile the next alternate - update limit and set frame back to where we started
max frame = frame if frame > max frame
frame = old frame
->next
c('{'):; ! Start of formal parameters
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)
->next
c('}'):; ! End of formal parameters
in params = 0
-> OUT if amode < 0; ! end of %record %format defn.
-> OUT 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 + 1) & (¬1); ! Even up the stack size
if procvar_type = string and procvar_form = 8 start
frame = frame + 2; ! 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 + 6; ! leave space for return linkage
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
-> OUT if amode = 2; ! this was just a spec
frame = 0
dumplabel(procvar_disp)
static alloc = enter
->next
c('H'):; ! Start of BEGIN block
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)
finish
assemble(0,labs,names)
if level # 0 start
dump label(skip proc)
last skip = next cad
Uncond Jump = 0
finish
->next
! To catch the sinners!!
C(*):
abort("Bad I Code")
c(';'):
if amode >= 0 start; ! No return code for %endoffile
dump return
dumpstaticfill(staticalloc, frame);
finish
OUT:
if amode >= 0 start; ! end of declarative block
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 ---------
select input(icode)
select output(objout)
var(0) = 0; ! for %RECORD(*) . . . . .
parms = max vars
cslen == current string(0)
! 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("TEST.IMP"); ! ABD - a bit bogus at the moment!
! 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(next sym); ! Prime SYM/NEXT pair
Spec = 0
decvar == begin
assemble(-3,0,0)
! We flush constants
flush cot
flush data
flush switch
ENDOFPROGRAM