! 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: ! ! For debug purposes, the elements are all written as ascii ! characters, where is a single letter, 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 %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 %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 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 + ! 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 %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::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