!! New pass2 for pdp11 imp ! Missing: Reals ! Procedures as parameters ! Jam transfer ! Machine code !Control bits %const %integer no eis= 256; !Set if EIS option missing %const %integer stack check= 512 ! %external %routine pass2 %external %routine %spec poctal(%integer n) %external %string %function %spec i to s %alias "S#ITOS"(%integer i) %external %routine %spec move %alias "S#MOVE"(%integer length,from,to) !EMAS %external %integer %map %spec comreg %alias "S#COMREGMAP"(%integer n) !EMAS: %own %integer fptr,fend,fptrinit; !EMAS: !SIZE CONSTANTS %const %integer max vars= 700, max label = 150, max depth = 10, max stack = 30, max envir = 7, max for = 10 %const %integer max uses= 4*3*max envir !ABORTS ! 0 - CONSISTENCY CHECK FAILS ! 1 - CLAIM BAD REGISTER ! 2 - RELEASE BAD REGISTER ! 3 - REGISTER NOT CLAIMED ! 4 - FORGET BAD REGISTER ! 5 - TOO MANY LABELS ! 6 - CANNOT GET A REGISTER ! 7 - ILLEGAL SOURCE/DEST ! 8 - BAD BASE REGISTER ! 9 - NO FREE DESCRIPTORS ! 10 - DESCRIPTOR NOT CLAIMED ! 11 - HAZARD FAILS - SPURIOUS USE ! 12 - HAZARD FAILS - ILLEGAL FORM ! 13 - STACK OVERFLOW ! 14 - STACK UNDERFLOW ! 15 - TOO MANY NAMES ! 16 - RESULT MISSING ! 17 - TOO MANY LEVELS ! 18 - TOO MANY NESTED FOR LOOPS ! 19 - LOAD FAILS ! 20 - DESCRIPTOR NOT RELEASED ! 21 - AMAP FAILS ! 22 - REGISTER NOT RELEASED ! 23 - BOUNDS INSIDE-OUT ! 24 - ILLEGAL REAL OPERATION !FILE DEFINITION %const %integer icode= 1; !INTERMEDIATE CODE %const %integer object=2,direct=3,report=0,trace=0 !EMAS: %constinteger OBJECT = 1, DIRECT = 2, TRACE = 3, REPORT = 0 %const %integer LAST MCODE= 147 %const %string (6) %array MC TEXT(0:LAST MCODE)= %c "NOP", "CLR", "CLRB", "DEC", "DECB", "INC", "INCB", "NEG", "NEGB", "TST", "TSTB", "COM", "COMB", "ASR", "ASRB", "ASL", "ASLB", "ASH", "ASHC", "ADC", "ADCB", "SBC", "SBCB", "SXT", "ROL", "ROLB", "ROR", "RORB", "SWAB", "FADD", "FSUB", "FMUL", "FDIV", "MOV", "MOVB", "ADD", "SUB", "CMP", "CMPB", "MUL", "DIV", "XOR", "BIS", "BISB", "BIT", "BITB", "BIC", "BICB", "BR", "BEQ", "BNE", "BMI", "BPL", "BCS", "BCC", "BVS", "BVC", "BLT", "BGE", "BLE", "BGT", "BHI", "BLOS", "BLO", "BHIS", "JSR", "MARK", "RTS", "SPL", "JMP", "SOB", "EMT", "TRAP", "BPT", "IOT", "RTI", "RTT", "HALT", "WAIT", "RESET", "MTPI", "MTPD", "MFPI", "MTPD", "MTPS", "MFPS", "CLC", "CLV", "CLZ", "CLN", "SEC", "SEV", "SEZ", "SEN", "SCC", "CCC", "XFC", "MED", "LDUB", "MNS", "MPP", "MAS", "LDF", "LDD", "STF", "STD", "ADDF", "ADDD", "SUBF", "SUBD", "NEGF", "NEGD", "MULF", "MULD", "DIVF", "DIVD", "CMPF", "CMPD", "MODF", "MODD", "LDCDF", "LDCFD", "STCFD", "STCDF", "LDCIF", "LDCID", "LDCLF", "LDCLD", "STCFI", "STCFL", "STCDI", "STCDL", "LDEXP", "STEXP", "CLRF", "CLRD", "ABSF", "ABSD", "TSTF", "TSTD", "SETF", "SETD", "SETI", "SETL", "LDFPS", "STFPS", "STST", "CFCC" %const %integer %array MC CODE(0:LAST MCODE)= %c k'000240', k'005000', k'105000', k'005300', k'105300', k'005200', k'105200', k'005400', k'105400', k'005700', k'105700', k'005100', k'105100', k'006200', k'106200', k'006300', k'106300', k'072000', k'073000', k'005500', k'105500', k'005600', k'105600', k'006700', k'006100', k'106100', k'006000', k'106000', k'000300', k'075000', k'075010', k'075020', k'075030', k'010000', k'110000', k'060000', k'160000', k'020000', k'120000', k'070000', k'071000', k'074000', k'050000', k'150000', k'030000', k'130000', k'040000', k'140000', k'000400', k'001400', k'001000', k'100400', k'100000', k'103400', k'103000', k'102400', k'102000', k'002400', k'002000', k'003400', k'003000', k'101000', k'101400', k'103400', k'103000', k'004000', k'006400', k'000200', k'000230', k'000100', k'077000', k'104000', k'104400', k'000003', k'000004', k'000002', k'000006', k'000000', k'000001', k'000005', k'006600', k'106600', k'006500', k'106500', k'106400', k'106700', k'000241', k'000242', k'000244', k'000250', k'000261', k'000262', k'000264', k'000270', k'000277', k'000257', k'076700', k'076600', k'170003', k'170004', k'170005', k'170007', k'172400', k'172400', k'174000', k'174000', k'172000', k'172000', k'173000', k'173000', k'170700', k'170700', k'171000', k'171000', k'174400', k'174400', k'173400', k'173400', k'171400', k'171400', k'177400', k'177400', k'176000', k'176000', k'177000', k'177000', k'177000', k'177000', k'175400', k'175400', k'175400', k'175400', k'176400', k'175000', k'170400', k'170400', k'170600', k'170600', k'170500', k'170500', k'170001', k'170011', k'170002', k'170012', k'170100', k'170200', k'170300', k'170000' %const %byte %integer %array MC TYPE(0:LAST MCODE)= %c 0, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 9, 9, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 13, 13, 13, 13, 13, 13, 9, 9, 9, 13, 13, 13, 13, 13, 13, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 2, 5, 1, 6, 12, 3, 3, 0, 0, 0, 0, 0, 0, 0, 6, 6, 6, 6, 6, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 4, 0, 0, 0, 0, 11, 11, 10, 10, 11, 11, 11, 11, 6, 6, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 10, 10, 11, 11, 11, 11, 10, 10, 10, 10, 11, 10, 6, 6, 6, 6, 6, 6, 0, 0, 0, 0, 6, 6, 6, 0 !REGISTER DEFINITION %const %integer integer reg= 0, real reg = 4 %const %integer fpbit= x'1000' %const %integer r0= 1, f0 = r0+real reg, r1 = 2, f1 = r1+real reg, r2 = 3, f2 = r2+real reg, r3 = 4, f3 = r3+real reg, lnb = 9, ds = 10, sp = 11, pc = 12 %const %integer param= 13 %const %integer primitive= 14 %const %integer %array actual(0:pc)= 0, 0,1,2,3, 0+fpbit,1+fpbit,2+fpbit,3+fpbit, 4,5,6,7 %const %integer act lnb= 4, act ds = 5, act sp = 6, act pc = 7 ! 17-21 ARE THE PROCEDURE BASE LEVELS %const %integer any= 32, anyf = 64 !MODES %const %integer reg= 0, defer = 1, autoi = 2, immediate = 2, autoi defer = 3, absolute = 3, autod = 4, autod defer = 5, index = 6, relative = 6, index defer = 7, relative defer = 7 !DATA TYPES %const %integer integers= 1, real = 2, string = 3, records = 4, byte = 5, general = 6 !OWN INFO %const %integer own= 1, con = 2, external= 3, system = 4, dynamic = 5, primrt = 6, permrt = 7 %const %integer define= 0, redefine = 1 !Relocation flags %const %integer mod code bit= 1, mod gla bit = 2, mod rel bit = 4, label bit = 8 !OBJECT FILE DIRECTIVES %const %integer procedure head= 1 %const %integer procedure end= 2 %const %integer absolute code= 3 %const %integer absolute gla= 4 %const %integer plug code= 5 %const %integer plug gla= 6 %const %integer branch code= 7<<4 ! label bit %const %integer label code= 8<<4 ! label bit %const %integer procedure return= 9 %const %integer line flag= 10 %const %integer mod code= 11 %const %integer mod gla= 12 %const %integer mod rel= 13 %const %integer mod ext= 14 %const %integer MCODE BRANCH= 15<<4 ! LABEL BIT %const %integer MCODE sob= 16<<4 ! LABEL BIT ! Relocation word: External index<12> label<1> mod rel<1> mod gla<1> mod%c code<1> !STACK FLAGS %const %integer in temp= x'01'; !IN TEMP STRING !DIRECTIVE FILE COMMANDS ! PROCEDURE HEAD - COMMON;%c ;!{<>} ! PROCEDURE END - COMMON;%c ;!{<> <> <>} ; !{<> <>} %const %integer label definition= 3, label reference = 4, return code = 5, load data = 6, external used = 7 !EXTERNAL FORMS %const %integer recordformat= 4 %const %integer switch= 6 !INTERNAL FORMS %const %integer constant= 0, v in r = 1, a in s = 2, v in s = 3, avin s = 4, rec mod = 3, a in rec = 5, v in rec = 6, avin rec = 7 %const %byte %integer %array stored(0:7)= 0,vins,ainrec,vinrec,avinrec,0(3) !PERM ROUTINES %const %integer safe bit= 256; !Routine corrupts nothing %own %byte %integer %array perm used(1:31) %const %integer signal= 1, checksp = 2, iexp = 5, smove = 6, spmove = 7, concat = 8, scomp = 9, resolution= 10, pcall = 11, adec = 12, aref = 13, setdope = 14, multi dec = 15, freadch = 16, resflop = 17 !EIS routines %const %integer eis mul= 18+safe bit, eis div = 19+safe bit, eis ash = 20+safe bit !OPERATIONS (UNARY NEGATIVE) %const %integer swob= -3, not = -2, neg = -1, add = 1, sub = 2, and = 3, or = 4, xor = 5, mul = 6, div = 7, remy = 8, lsh = 9, rsh = 10, exp = 11, conc = 12, bic = 13, sha = 14, indexing = 15, multi = 16 %const %byte %integer %array comm(-3:15)= 0(3), 0, 1, 0, 1(4), 0(9) %const %byte %integer %array trans(-3:15)= 2,2,2,0,0,0,1,1,1, 1,1,2,2,2,2,2,15,15,15 %const %integer %array null op(-3:15)= %c 0, 0, 0, 0, 0, 0, -1, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0 %const %integer jump= 0 !OPCODES ! OPCODE FLAGS ! &1 = R-OP RELEASES%c REGISTER ! &2 = MOV OR MOVB ! &4 = FORGET DESTINATION ! &8 = RELEASE DEST REG !TWO OPERAND %const %integer mov= k'010007', movb = k'110007' %const %integer cmp= k'020010', cmpb = k'120010' %const %integer addw= k'060004' %const %integer subw= k'160004' %const %integer bit= k'030010', bitb = k'130010' %const %integer bicw= k'040004', bicb = k'140004' %const %integer bis= k'050004', bisb = k'150004' !ONE OPERAND %const %integer clr= k'005004', clrb = k'105004' %const %integer com= k'005104' %const %integer inc= k'005204', incb = k'105204' %const %integer dec= k'005304' %const %integer negw= k'005404' %const %integer tst= k'005710', tstb = k'105710' %const %integer ror= k'006004' %const %integer rol= k'006104' %const %integer asr= k'006204' %const %integer asl= k'006304' %const %integer jmp= k'000100' %const %integer swab= k'000304' %const %integer sxt= k'006704' !REGISTER OPS %const %integer jsr= k'004000' %const %integer rtpc= k'000207' %const %integer mulw= k'070014' %const %integer divw= k'071014' %const %integer sob= k'077000' %const %integer ash= k'072014' %const %integer xorw= k'074005' !Floating point instructions (11-60) %const %integer ldf= k'172412', stf = k'174002' %const %integer ldcif= k'177004', stcfi= k'175404' %const %integer addf= k'172004', subf = k'173004' %const %integer mulf= k'171004', divf = k'174404' %const %integer clrf= k'170404', absf = k'170604' %const %integer cmpf= k'173410', tstf = k'170510' %const %integer negf= k'170704', cfcc = k'170000' !MEASUREMENT INFORMATION %own %integer use limit= 1000; !1 MAXIMUM USES PER REGISTER %own %integer max envirs= max envir; !2 MAXIMUM ENVIRONMENTS %own %integer array opt= 1; !3 !CONDITION CODE OPS %const %integer true= k'000261'; !SEC %const %integer false= k'000241'; !CLC %const %integer %array opcode(-3:14)= %c swab, com, negw, 0, addw, subw, bicw, bis, xorw, mulw, divw, 0, asl, ror, 0, 0, bicw, 0 %const %integer %array rcode(-3:14)= 0,0,0,0,addf,subf,0(3),mulf,divf,0(7) %const %byte %integer %array amapped(constant:av in rec)= 0, 0, v in s, av in s, 0, v in rec, av in rec, 0 %recordformat stackfm(%integer disp, extra, format, oper, reloc, length, %c %byteinteger type, form, base, flags, %c %record(stackfm)%name link) !NOTIMP80 %recordspec STACKFM_LINK(STACKFM) %record (stackfm) %array stak(1:max stack) %record (stackfm) %name desc asl %record (stackfm) %name lhs,rhs %own %record (stackfm) cons %own %record (stackfm) null %own %record (stackfm) %array vr(r0:pc) %own %record (stackfm) at ds,to ds; !FOR (SP) OPERANDS %recordformat stackedfm(%record(stackfm)%name v) !NOTIMP80 %recordspec STACKEDFM_V(STACKFM) %record (stackedfm) %array stacked(1:max depth) %recordformat dfm(%record(stackfm)%name d, %record(dfm)%name link) !NOTIMP80 !NOTIMP80 %recordspec DFM_D(STACKFM); %recordspec dfm_link(dfm) %record (dfm) %array dlist(1:max stack) %own %record (dfm) %name dasl %own %record (dfm) using %own %record (dfm) null d %record %format labelfm(%integer id,tag) %record (labelfm) %array labels(1:max label) %record (labelfm) null label %record %format forfm(%integer cdisp,ldisp,label,reloc,flags) %own %record (forfm) %array forinf(1:max for) %own %integer forp,for lab %own %record (forfm) %name fr %own %integer known reg,known flag= 0; !KNOWLEDGE GAINED FROM COMPARE %record (stackfm) known v %own %integer %array used(0:pc); !ADDRESS REG LAST USED %own %integer %array activity(0:pc); !EXTENT OF REG USAGE %record %format usefm(%integer disp,reloc, %half %integer index,link, %byte %integer bt,form) ! %recordformat USE2(%halfinteger DISP, RELOC, SCALE,%c %byteinteger BT, FORM) ! %recordformat USEFM(USE1 %or USE2) %own %integer %array usage(r0:pc) %own %integer %array usage info(r0:pc) %record (usefm) %array uses(1:max uses) %integer use asl,uses left %record %format envfm(%integer label, %byte %integer %array e(r0:f3)) %own %record (envfm) %array envir(0:max envir) %own %record (envfm) null env %record %format varfm(%half %integer free,form, %byte %integer base,type, %integer disp,reloc,format) ! FORMAT = -DATA SIZE OR INDEX INTO%c var FOR RECORDS FORMAT ! PARAM = INDEX INTO var FOR%c PARAMETER LIST ! VAR FLAGS - in top of form %const %integer array bit= x'10', indirect = x'20', procedure = x'40', pending = x'80' %record (varfm) %array var(0:max vars) %own %record (varfm) %name decvar %own %record (varfm) %name fp,ap; !FORMAL & ACTUAL PARAMETERS %own %record (varfm) begin; !DUMMY FOR BEGIN BLOCKS %own %integer parameter list= 0 %own %integer gtype= 0 %own %integer spec= 0 %own %integer decl; !LAST DESCRIPTOR DEFINED %own %integer ca= 0; !CURRENT CODE ADDRESS %own %integer ga= 0; !CURRENT GLA ADDRESS %own %integer frame; !CURRENT FRAME DISPLACEMENT %own %integer round= 0 %own %integer new frame; !BLOCK ENTRY FRAME SIZE %integer alt aligned; !FOR ALIGNING RECORD ALTERNATES %own %integer uncond jump; !ADDRESS OF LAST UC. JUMP %own %integer jtag; !LAST JUMP TAG %own %integer dtag; !LAST TAG DEFINED %own %integer assign reg= 0 %own %integer active regs= 0 %own %integer current line= 0 %own %integer local; !LOCAL BASE REGISTER %own %integer parms; !PARAMETER AREA LIMIT %own %integer stp= 0; !INTERNAL STACK POINTER %own %integer envp= 0; !ENVIRONMENT POINTER %own %integer sym; !CURRENT CONTROL CH %own %integer dim; !ARRAY DIMENSION %own %integer vub,vlb; !VECTOR LOWER & UPPER BOUNDS %own %integer data size; !SIZE OF CURRENT DATA ITEM %own %integer control= stack check; !CONTROL INFORMATION %own %integer diag= 0; !DIAGNOSTIC FLAGS %own %integer byte inhibit= 0; !DON`T MASK OFF BYTES %own %integer test= 0; !CONDITION TEST FOLLOWING %own %integer invert= 0; !INVERTED CONDITION FLAG %own %integer unsigned= 0; !FLAG FOR UNSIGNED BRANCHES %own %integer swopped= 0; !CONDITION OPERANDS SWOPPED FLAG %own %integer cc ca; !CONDITION CODE INFO %own %record (stackfm) cc lhs %own %record (stackfm) cc rhs %own %integer otype; !CURRENT 'own' DECLARATOR %own %integer potype; !PROCEDURE OTYPE %own %integer owntype,ownflags,ownval; !OWN INFO %integer j,k,l %integer max frame,frame base; ! SHIFTED UP FROM ASSEMBLE TO FIX BUG %own %integer len,opr %own %integer aparm %own %integer xtag= 1 %own %integer null string= -1; !ADDRESS OF NULL IN GLA %own %integer snl= -1 %own %string (255) text %own %string (15) external name,var name,alias %routine %spec release(%integer reg) %routinespec remember(%integer reg, %record(stackfm)%name v) %routine %spec forget(%integer reg) %routinespec forget dest(%record(stackfm)%name v) %routine %spec forget everything %routine %spec stack c(%integer val) %routine %spec perm(%integer n) !=========== initialisation =========== at ds_type = 254; at ds_form = v in s at ds_base = ds; at ds_disp = 0 to ds = at ds; to ds_type = integers parms = max vars+1 var(0) = 0 %cycle j = r0,1,pc vr(j)_base = j; vr(j)_form = v in r; vr(j)_type = integers %repeat vr(f0)_type = real vr(f1)_type = real vr(f2)_type = real vr(f3)_type = real forget everything activity(0) = -1 activity(lnb) = -1; activity(ds) = -1 activity(sp) = -1; activity(pc) = -1 %cycle j = 1,1,max stack-1 stak(j)_link == stak(j+1) dlist(j)_link == dlist(j+1) %repeat stak(max stack)_link == null; dlist(max stack)_link == null d desc asl == stak(1); dasl == dlist(1) using_link == null d uses left = max uses use asl = max uses %cycle j = max uses,-1,1 uses(j)_link = j-1 %repeat decvar == begin !======================================================= !ERROR CHECKING %routine display(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) write(v_type,2); write(v_form,2) write(v_base,3); space; poctal(v_disp) write(v_extra,3) write(v_format,3) write(v_flags,3); space; poctal(v_reloc) %if v_oper#0 %start printstring(" &") write(v_oper,-2); printch(':') display(v_link) %finish %end %routine abort(%integer code) selectoutput(0) printstring("* abort"); write(code,1) printstring(" at line"); write(current line,1) newline %monitor; %stop %end %routine warning(%string (63) s) selectoutput(0) printstring("? warning: "); printstring(s) printstring(" at line"); write(current line,1) newline selectoutput(object) %end %routine monitor(%record(stackfm)%name v, %string(15) s) !NOTIMP80 %recordspec V(STACKFM) selectoutput(trace) printstring(s); printch(':') spaces(10-length(s)) display(v) newline selectoutput(object) %end !CODE AND GLA PLANTING PROCEDURES %routine put(%integer value) printch(value>>8); printch(value&255) %end %routine relocate(%integer flag) %if flag&label bit#0 %start printch(mod code) %if flag=label code printch(flag>>4) %return %finish printch(mod code) %if flag&mod code bit#0 printch(mod gla) %if flag&mod gla bit#0 printch(mod rel) %if flag&mod rel bit#0 flag = flag>>4 %if flag#0 %start printch(mod ext); put(flag) %finish printch(absolute code) %end %routine pdump(%integer code type,value) !All code is output through this%c routine. !It is responsible for dumping%c line-number information !as it can ensure that line nos are%c only generated !when code is produced. %own %integer last line= 0 %if current line#last line %start printch(line flag); put(current line) last line = current line %finish relocate(code type) put(value); ca = ca+2 %end %routine cword(%integer value) pdump(0,value) %end %routine gword(%integer value) printch(absolute gla); put(value) ga = ga+2 %end %routine gbyte(%integer byte value) %own %integer hold= 0 %if ga&1=0 %start hold = byte value&255 %finish %else %start printch(absolute gla) put(hold+byte value<<8); !BYTES ARE BACKWARDS!!! %finish ga = ga+1 %end %routine gfix gbyte(0) %if ga&1#0 %end %routine g patch(%integer what,where) printch(plug gla); put(what); put(where) %end %routine set(%record(stackfm)%name v, %integername mode, base, reloc) !NOTIMP80 %recordspec V(STACKFM) %const %byte %integer %array modes(0:4)= immediate, reg, index defer, index, immediate base = v_base abort(7) %if v_form>v in s %and (v_form#avins %or base#0) mode = modes(v_form) reloc = v_reloc %if v_disp=0 %and reloc=0 %and mode=index %start mode = defer %finish %else %start base = pc %if base=0 %and mode=immediate %finish %if base=0 %and mode>=index %start base = pc reloc = reloc!mod rel bit %finish release(base) %unless mode=reg %if base=ds %start abort(7) %unless mode=defer mode = auto i %if v_type#254 %finish abort(8) %unless 0=index %or base=7 %start pdump(reloc,dest_disp) %finish %if op&4#0 %start; !FORGET DEST %if mode=reg %then forget(dest_base) %else forget dest(dest) %finish cc rhs = dest; cc ca = ca cc lhs_base = 255 %end %routine op2(%integer op, %record(stackfm)%name srce, dest) !NOTIMP80 !NOTIMP80 %recordspec SRCE(STACKFM); %recordspec dest(stackfm) %integer smode,sbase,sreloc,dmode,dbase,dreloc %if srce_form=constant %start %if srce_disp=0 %start %if op=mov %or op=movb %start; !CAN USE CLR(B) %if op=mov %then op = clr %else op = clrb op1(op,dest); %return %finish %finish %else %start; %if imod(srce_disp)=1 %start %if op=addw %or op=subw %start; !CAN USE INC(DEC) op = addw+subw-op %if srce_disp<0 %if op=addw %then op = inc %else op = dec op1(op,dest); %return %finish %finish; %finish %finish set(srce,smode,sbase,sreloc) set(dest,dmode,dbase,dreloc) cword(op&x'FFF0'+((smode<<3+sbase)<<3+dmode)<<3+dbase) release(srce_base) %if smode=reg release(dest_base) %if dmode=reg %and op&8#0 %if smode>=index %or sbase=7 %start pdump(sreloc,srce_disp) %finish %if dmode>=index %or dbase=7 %start pdump(dreloc,dest_disp) %finish %if op&4#0 %start; !FORGET DESTINATION %if dmode=reg %start forget(dest_base) %finish %else %start forget dest(dest) %finish %finish %if op&2#0 %and smode=reg %and srce_base<=r3 %start; !MOV, MOVB %if dmode=reg %start remember(-dest_base,srce) %finish %else %start remember(srce_base,dest) %finish %finish %if op&2#0 %then cc lhs = srce %else cc lhs_base = 255 cc rhs = dest; cc ca = ca %end %routine rop(%integer op, register, %record(stackfm)%name dest) !All EIS calls come here in terms of%c the option's opcodes !e.g. MUL, DIV.... They are mapped%c into:- ! MOV DEST,(DS)+ ! MOV R,(DS) ! JSR PC,ROUTINE ! MOV (DS),R' !NOTIMP80 %recordspec DEST(STACKFM) %integer mode,base,reloc,r,rt,s %integer %fn mult(%integer reg,n) !tries to multiply REG by the%c constant N %integer work,first,rr %result = 0 %if n>>1=0; !0 or 1 work = r0 %if activity(r0)#0 %start work = r2 %result = 0 %if activity(r2)#0 %finish forget(work) work = work-1 %if n<0 %start n = -n cword(k'005400'+reg); !neg reg %finish rr = reg<<6+work first = 1 %cycle %if n&1#0 %start %if first#0 %start first = 0; cword(k'010000'+rr); !mov_reg,work %finish %else %start %if n=1 %then cword(k'060000'+work<<6+reg) %else %c cword(k'060000'+rr) !add work,reg or add reg,work %finish %finish n = n>>1 %result = -1 %if n=0 cword(k'006300'+reg); !asl reg %repeat %end forget(register) %unless op=xorw %if op#xorw %and control&no eis#0 %start r = register-1 s = r %if op=mulw %start %return %if dest_form=constant %and mult(r,dest_disp)#0 rt = eis mul %finish %else %start; %if op=divw %start rt = eis div; s = r+1 %finish %else %start rt = eis ash %finish; %finish op2(mov,dest,tods) cword(k'010025'+s<<6); !MOV S,(DS)+ perm(rt) cword(k'014500'+r) cword(k'014500'+s) %if s#r %finish %else %start set(dest,mode,base,reloc) cword(op&x'FFF0'+(actual(register)<<3+mode)<<3+base) release(dest_base) %if mode=reg %and op&8#0 %if mode>=index %or base=7 %start pdump(reloc,dest_disp) %finish cc lhs_base = 255 %if op=xorw %then cc rhs = dest %else cc rhs = vr(register) cc ca = ca %finish release(register) %if op&1#0 %end %routine fop(%integer op, register, %record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer mode,base,reloc %if op=ldcif %and v_form=constant %and v_disp=0 %start op1(clrf,vr(register)) %return %finish set(v,mode,base,reloc) cword(op&x'FFF0'+(actual(register)<<3+mode)<<3+base) pdump(reloc,v_disp) %if mode>=index %or base=act pc %if op=stf %start %if mode=reg %then forget(v_base) %else forget dest(v) cc lhs = v %finish %else %start cc lhs_base = 255 forget(register) %if op&4#0 %finish cc rhs = v cc ca = ca release(v_base) %if mode=reg %and op&8#0 release(register) %if op=stf %or op=cmpf %if op&2#0 %start %if op=ldf %then remember(-register,v) %else remember(register,v) %finish %end !SUNDRY PROCEDURES %integerfn same(%record(stackfm)%name v1, v2) !NOTIMP80 !NOTIMP80 %recordspec V1(STACKFM); %recordspec v2(stackfm) %result = 0 %if v1_disp#v2_disp %or v1_base#v2_base %result = 0 %if v1_type#v2_type %or v1_form#v2_form %result = 0 %if v1_extra#v2_extra %or v1_reloc#v2_reloc %result = 1 %end %integerfn zero(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %result = 0 %if v_disp#0 %or v_form#constant %result = 0 %if v_oper#0 %or v_type#integers %result = 1 %end %integerfn const(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %result = 0 %if v_form#constant %or v_type#integers %or v_oper#0 %result = 1 %end !EMAS: %integerfn TAG !EMAS: !INPUT OCTAL CONSTANT !EMAS: %integer N, S !EMAS: N = 0 !EMAS: %cycle !EMAS: S = NEXTSYMBOL-'0' !EMAS: %result = N %unless 0 <= S <= 7 !EMAS: N = N<<3+S !EMAS: SKIPSYMBOL !EMAS: %repeat !EMAS: %end %integer %fn tag; !EMAS: %integer n; !EMAS n = halfinteger(fptr&(~1))&x'ffff'; !EMAS: BG 22/9/86 fptr = fptr+2 %result = n %end; !EMAS: %integer %fn new tag %own %integer tag= 0 tag = tag+1; %result = tag %end %routine define tag(%integer ref) dtag = ref selectoutput(direct) printch(label definition); put(ref); put(ca) selectoutput(object) %end %routine define reference(%integer ref,type) selectoutput(direct) printch(label reference) put(ref); put(ca); printch(type) selectoutput(object) %end %routine setx(%integer type,entry) %integer j selectoutput(direct) printch(load data) printch(type); put(entry) printch(length(external name)) %cycle j = 1,1,length(external name) printch(charno(external name,j)) %repeat selectoutput(object) xtag = xtag+1 %end %routine show used(%integer ext) selectoutput(direct) printch(external used); put(ext) selectoutput(object) %end %ROUTINE FORCE USED ( %RECORD(varfm) %NAME V ) !NOTIMP80 %recordspec v(varfm) %if V_TYPE&128#0 %start; ! Spec needed V_TYPE = V_TYPE-128 SHOW USED(V_RELOC>>4) %finish %end %integer %fn power(%integer value) %integer p,mask mask = x'FFFE' %cycle p = 0,1,12 %result = p %if value&mask=0 mask = mask<<1+1 %repeat %result = -1 %end %routine dump string(%integer max) %integer j,n n = length(text) %if max=0 %start; !DUMP AS MUCH AS NEEDED %return %if n=0; !NULL STRING max = n; !ACTUAL LENGTH %finish %else %start; !DUMP UP TO MAX max = max-1 warning("string too long") %and n = max %if n>max %finish gbyte(n) %if n>0 %start %cycle j = 1,1,n gbyte(charno(text,j)) %repeat %finish %while n=fend; !EMAS %end; !EMAS %routine get string(%string %name text) %integer s,size,j !EMAS: TEXT = "" !EMAS: SIZE = TAG !EMAS: SKIPSYMBOL !EMAS: %if SIZE # 0 %start !EMAS: %cycle J = 1, 1, SIZE !EMAS: READSYMBOL(S) !EMAS: TEXT = TEXT.TOSTRING(S) !EMAS: %repeat !EMAS: %finish size = byteinteger(fptr); !EMAS: move(size+1,fptr,addr(text)); !EMAS: fptr = fptr+size+1; !EMAS %return %if sym='G'; !ALIAS !EMAS: S = NEXTSYMBOL s = byteinteger(fptr); ! EMAS: %if size=0 %start %if null string=0 %start null string = ga; gbyte(0) %finish stack c(null string) %finish %else %start stack c(ga) dump string(0) %unless s='$' %or s='A' %finish rhs_reloc = mod gla bit rhs_form = v in s rhs_type = string rhs_length = size+1 %end !DESCRIPTOR PROCESSING %integer %fn descriptor %record (dfm) %name d %record (stackfm) %name v v == desc asl; abort(9) %if addr(v)=addr(null) d == d asl; abort(9) %if addr(d)=addr(nulld) desc asl == v_link; v = 0 d asl == d_link d_link == using_link using_link == d d_d == v stp = stp+1; abort(13) %if stp>max depth stacked(stp)_v == v %result = addr(v) %end %routine drop(%record(stackfm)%name d) !NOTIMP80 %recordspec D(STACKFM) %record (dfm) %name this,last last == using %cycle this == last_link abort(10) %if addr(this)=addr(null d) %exit %if addr(this_d)=addr(d) last == this %repeat last_link == this_link this_link == dasl dasl == this d_link == desc asl desc asl == d %end %routine stack v(%record(varfm)%name v) !NOTIMP80 %recordspec V(VARFM) lhs == record(descriptor) lhs_base = v_base; lhs_disp = v_disp lhs_type = v_type; lhs_form <- v_form&15 lhs_format = v_format %if lhs_format<0 %then lhs_length = var(-lhs_format)_format %else %c lhs_length = v_format lhs_extra = integer(addr(v_free)); !_PARAM lhs_reloc = v_reloc lhs_flags = v_form&x'00F0' lhs_link == null monitor(lhs,"stack v") %if diag&1#0 %end %routine stack s(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) rhs == record(descriptor); rhs = v monitor(rhs,"stack s") %if diag&1#0 %end %routine stack c(%integer value) rhs == record(descriptor) rhs_disp = value; rhs_type = integers; rhs_form = constant monitor(rhs,"stack c") %if diag&1#0 %end %routine stack x(%integer base,disp,form,extra) rhs == record(descriptor) rhs_base = base; rhs_disp = disp rhs_type = integers; rhs_form = form rhs_extra = extra rhs_link == null monitor(rhs,"stack x") %if diag&1#0 %end %routine set lhs lhs == stacked(stp)_v monitor(lhs,"set lhs") %if diag&1#0 %end %routine set both abort(14) %if stp<2 lhs == stacked(stp-1)_v rhs == stacked(stp)_v %if diag&1#0 %start monitor(lhs,"both lhs") monitor(rhs,"both rhs") %finish %end %routine pop lhs abort(14) %if stp<=0 stp = stp-1 lhs == stacked(stp+1)_v monitor(lhs,"pop lhs") %if diag&1#0 %end %routine pop drop abort(14) %if stp<=0 stp = stp-1 lhs == stacked(stp+1)_v; drop(lhs) monitor(lhs,"pop drop") %if diag&1#0 %end !REGISTER PROCESSING %routine claim(%integer reg) %return %if reg>=16 %return %if reg=0 %or activity(reg)<0; !LOCKED activity(reg) = activity(reg)+1 active regs = active regs+1 used(reg) = ca %end %routine release(%integer reg) %return %if reg>=16 %return %if reg=0 %or activity(reg)<0; !LOCKED activity(reg) = activity(reg)-1 active regs = active regs-1 abort(3) %if active regs<0 %end %routine release and drop(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) release(v_base) drop(v) %end %integer %fn new use %integer n uses left = uses left-1; abort(321) %if uses left<0 n = use asl use asl = uses(n)_link %result = n %end %integer %fn copy(%integer head) %integer top,n %record (usefm) %name new top = 0 %cycle %result = top %if head=0 %or uses left<2 n = new use; new == uses(n) new = uses(head) head = new_link new_link = top; top = n %if new_index#0 %start n = new use uses(n) = uses(new_index) new_index = n %finish %repeat %end %routine return use(%integer index) uses(index)_link = use asl use asl = index uses left = uses left+1 index = uses(index)_index %if index#0 %start; !RETURN ARRAY INFO uses(index)_link = use asl use asl = index uses left = uses left+1 %finish %end %routine return use list(%integer head) %integer next %while head#0 %cycle next = uses(head)_link return use(head) head = next %repeat %end %routine forget(%integer reg) %integer this,next %integer %name ur usage info(reg) = 0 this = usage(reg); usage(reg) = 0 %while this#0 %cycle next = uses(this)_link return use(this) this = next %repeat %cycle reg = r0,1,f3 ur == usage(reg) this = ur; ur = 0 %while this#0 %cycle next = uses(this)_link %if uses(this)_bt&15=reg %or (uses(this)_index#0 %and %c uses(uses(this)_index)_bt&15=reg) %start return use(this) %finish %else %start uses(this)_link = ur; ur = this %finish this = next %repeat %repeat %end %routine forget dest(%record(stackfm)%name d) !NOTIMP80 %recordspec D(STACKFM) %integer base,low,high,reloc,reg,next,un %record (usefm) %name u,ux %integer %name up base = d_base; reloc = d_reloc low = d_disp; high = low+d_length high = low+2 %if high<=low %cycle reg = r0,1,f3 up == usage(reg) next = up up = 0 %while next#0 %cycle un = next u == uses(un) next = u_link %if low<=u_dispc1 %finish %while next#0 %cycle u == uses(next) next = u_link %if u_index#0 %start ux == uses(u_index) printstring(" array") write(u_disp,3) printch('(') write(actual(u_bt&15),0) printch(')') printstring(" index ") write(ux_disp,3) printch('(') write(ux_bt&15-1,0) printch(')') printstring(" scale") write(integer(addr(ux_index)),1) %finish %else %start write(u_disp,3) printch('(') write(actual(u_bt&15),0) printch(')') %finish newline %repeat c1: %repeat newline selectoutput(object) %end %routine remember(%integer reg, %record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer un,uxn %record (usefm) %name u,ux %record (stackfm) %name vx %return %unless r0<=imod(reg)<=f3 monitor(v,"remember") %if diag&1#0 %if reg<0 %start; !PRE-EMPT OTHER KNOWLEDGE reg = -reg forget(reg) %if v_form=v in r %start usage info(reg) = usage info(v_base) usage(reg) = copy(usage(v_base)) %return %finish %finish %return %if reg=v_base; ! AVOID REMEMBER R3=R3+2 ETC. %return %if uses left=0 %or usage info(reg)>=use limit usage info(reg) = usage info(reg)+1 uxn = 0 %if v_oper#0 %start %return %if v_oper#indexing %or uses left<2 vx == v_link uxn = new use; ux == uses(uxn) integer(addr(ux_index)) = v_length ux_bt = vx_base+vx_type<<4 ux_form = vx_form ux_disp = vx_disp ux_reloc = vx_reloc %finish un = new use; u == uses(un) u_link = usage(reg); usage(reg) = un u_index = uxn; !POINTER TO ANY ARRAY INFO u_bt = v_base+v_type<<4 u_form = v_form u_disp = v_disp u_reloc = v_reloc %end !ENVIRONMENT CONTROL %integer %fn environment(%integer label) %integer j %result = addr(null env) %if label<=0 %cycle j = max envirs,-1,0 %result = addr(envir(j)) %if envir(j)_label=label %repeat %result = addr(null env) %end %routine remember environment(%integer label) %integer reg %record (envfm) %name e %return %if label<=0 e == record(environment(label)) %cycle reg = r0,1,f3 return use list(e_e(reg)) %repeat e = 0 envp = envp+1; envp = 0 %if envp>max envirs e == envir(envp) e_label = label %cycle reg = r0,1,f3 return use list(e_e(reg)) e_e(reg) = copy(usage(reg)) %repeat %end %routine merge environment(%integer label) %record (envfm) %name e %integer reg %routine merge(%integer current, %byte %integer %name new) %integer p,next,n %record (usefm) %name u,nu,ux next = new; new = 0 %while next#0 %cycle p = next u == uses(p); next = u_link u_link = 0 n = current %cycle %if n=0 %start; !NO MATCH return use(p); %exit %finish nu == uses(n) %if nu_disp=u_disp %and nu_bt=u_bt %and nu_reloc=u_reloc %and %c nu_form=u_form %start %if nu_index=0=u_index %start; !MATCHED u_link = new; new = p %exit %finish %else %start; %if nu_index#0 %and u_index#0 %start nu == uses(nu_index) ux == uses(u_index) %if nu_disp=ux_disp %and nu_bt=ux_bt %and %c integer(addr(nu_index))=integer(addr(ux_index)) %c %and nu_reloc=ux_reloc %and nu_form=ux_form %start u_link = new; new = p %exit %finish %finish; %finish %finish n = nu_link %repeat %repeat %end e == record(environment(label)) %if addr(e)=addr(null env) %start forget everything %finish %else %start %cycle reg = r0,1,f3 merge(usage(reg),e_e(reg)) %repeat %finish %end %routine count usage(%integer reg) %integer n,p n = 0 p = usage(reg) %while p#0 %cycle n = n+1 p = uses(p)_link %repeat usage info(reg) = n %end %routine restore environment(%integer label) %integer reg %record (envfm) %name e forget everything e == record(environment(label)) %if addr(e)#addr(null env) %start %cycle reg = r0,1,f3 usage(reg) = e_e(reg) count usage(reg) %repeat e = 0 %finish %end %routine forget everything %integer reg %cycle reg = r0,1,f3 used(reg) = 0 forget(reg) %repeat ccca = -1; cc lhs_base = 255; cc rhs_base = 255 uncond jump = -1 %end %routine hazard(%integer reg) %record (dfm) %name p %integer new,count,n %routine mod(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer %fn in store(%integer reg) !TRY TO USE AN EXISTING VALUE IN STORE %record (usefm) %name u %result = 0 %if usage(reg)=0; !UNKNOWN u == uses(usage(reg)) %result = 0 %if u_index#0 %or integers#u_bt>>4#real v_form = u_form v_base = u_bt&15 v_disp = u_disp v_reloc = u_reloc claim(v_base) %result = 1 %end count = count-1 monitor(v,"Hazard") %if diag&16#0 %if v_form=v in r %and n=1 %and in store(reg)#0 %start n = 0; %return %finish %if v_reloc#0 %start; !SUSPEND RELOCATION v_flags = v_flags!pending; !TO PREVENT RELOCATING TEMP !CLEARED IN address %finish %if v_form=v in r %then v_disp = new %else v_extra = new v_form = stored(v_form); abort(12) %if v_form=0 v_form = a in s %if v_type=string %and v_form=v in s v_base = local %end count = activity(reg); %return %if count<=0; !FREE OR LOCKED n = count activity(reg) = 0; active regs = active regs-n new = (frame+1)&(\1) p == using_link %cycle %exit %if addr(p)=addr(null d) mod(p_d) %if p_d_base=reg p == p_link %repeat abort(11) %if count#0 %return %if n=0 frame = new+2 cword(mov&x'FFF0'+actual(reg)<<6+act lnb+k'60'); cword(new) %end %routine hazard all %return %if active regs=0 hazard(r0); hazard(r1); hazard(r2); hazard(r3) %return %if active regs=0 hazard(f0); hazard(f1); hazard(f2); hazard(f3) %end %integer %fn register(%integer which) %integer reg,mininfo,minact,minreg,minused,r %integer info,freeused,freereg minact = 1000; freeused = ca+1; freereg = 0 minreg = 0; mininfo = 1000 %cycle r = r3,-1,r0 reg = r+which %if activity(reg)=0 %start %if used(reg)0 %start info = usage info(reg); !NUMBER OF DISTINCT USES %if activity(reg)=minact %start %if info16+5 decvar_disp = new tag %if decvar_disp=0 %if level#16 %start selectoutput(direct) printch(procedure head); put(decvar_disp) selectoutput(object) printch(procedure head); put(decvar_disp) setx(2,decvar_disp) %if potype#0 perm(checksp) %if control&stack check#0 %finish %finish %else %start; %if amode=-1 %start integer(addr(gvar_free)) = parms; !_PARAM %finish; %finish !========================================================================== %routine MACHINE CODE %integer %array EXTRAS,RELOCS(1:2) %integer EXTRAP %integer SYM,INDEX,TYPE,CODE %string (6) OP STRING EXTRAP = 0 OP STRING = "" %on 10 %start %return %finish %routine MC ERROR(%string (31) TEXT) SELECT OUTPUT(0) PRINT STRING("* M/C code error """) PRINT STRING(TEXT) PRINT STRING(""" at line ") WRITE(CURRENT LINE,0) NEWLINE SELECT OUTPUT(OBJECT) readch(SYM) %while SYM#';' %signal 10 %end %integer %function FIND(%string (6) S) %integer I %for I = 0,1,LAST MCODE %cycle %result = I %if MC TEXT(I)=S %repeat MC ERROR("Unknown Opcode") %end %integer %function LITERAL(%integer MAX) %integer I,SIGN I = 0 SIGN = 0 %if MAX=0 %and (SYM='-' %or SYM='+') %start %if SYM='-' %then SIGN = 1 READCH(SYM) %finish MC ERROR("Literal expected") %unless '0'<=SYM<='7' %while '0'<=SYM<='7' %cycle I = I<<3!(SYM-'0') readch(SYM) %repeat I = -I %if SIGN#0 %result = I %if MAX=0 MC ERROR("Literal range?") %unless I<=MAX %result = I %end %routine EXTRA(%integer I) EXTRAP = EXTRAP+1 EXTRAS(EXTRAP) = I RELOCS(EXTRAP) = 0 %end %integer %function OPERAND %integer INDIRECT,REG,MODE,LIT %integer REL %record (VARFM) %name V INDIRECT = 0; REG = 0; MODE = 0; REL = 0 %routine SET INDEX MC ERROR("Expected a '('") %unless SYM='(' readch(SYM); ! over the '(' REG = LITERAL(7) MODE = 1 MC ERROR("Where is the ')' then ?") %unless SYM=')' readch(SYM); ! over the ')' %end %routine ADD CHAIN %integer SIGN,M %while SYM='+' %or SYM='-' %cycle SIGN = SYM; readch(SYM) M = LITERAL(0) M = -M %if SIGN='-' LIT = LIT+M %repeat EXTRA(LIT) %end %if SYM='@' %start INDIRECT = 1 readch(SYM) %finish %if SYM='#' %start MODE = 2; REG = 7 readch(SYM) %if SYM=' ' %start V == VAR(TAG) FORCE USED(V) readch(SYM) REL = V_RELOC LIT = V_DISP MC ERROR("# valid only on statics") %if REL=0 %if REL=LABEL CODE %then EXTRA(LIT) %else ADD CHAIN RELOCS(EXTRAP) = REL %finish %else %start LIT = LITERAL(0) ADD CHAIN %finish %finish %else %if SYM='(' %start SET INDEX %if SYM='+' %start MODE = 2 readch(SYM) %finish %finish %else %if SYM='-' %start readch(SYM) %if SYM='(' %start; ! Auto-decrement SET INDEX MODE = 4 %finish %else %start; ! negative displacement LIT = -LITERAL(0) ADD CHAIN SET INDEX MODE = 6 %finish %finish %else %if '0'<=SYM<='7' %start LIT = LITERAL(0) %if SYM='(' %start EXTRA(LIT) SET INDEX MODE = 6 %finish %else %start MC ERROR("Register?") %unless 0<=LIT<=7 REG = LIT %finish %finish %else %if SYM=' ' %start; ! Tag upcoming V == VAR(TAG) FORCE USED(V) readch(SYM) REL = V_RELOC LIT = V_DISP REG = 7; MODE = 3 %if REL=LABEL CODE %start EXTRA(LIT) %finish %else %if REL#0 %start ADD CHAIN %finish %else %if V_BASE=LOCAL %start REG = ACT LNB; MODE = 6 ADD CHAIN %finish %else %start MC ERROR("Cant get at operand") %finish RELOCS(EXTRAP) = REL %finish %else %start MC ERROR("Operand format?") %finish %if INDIRECT#0 %start MC ERROR("Indirection failure") %unless MODE&1=0 MODE = MODE+1 %finish %result = MODE<<3!REG %end %routine CODE UP %record (VARFM) %name LAB %integer OP1,OP2 %const %integer %array LIT SIZE(0:13)= %c 0,7,63,255,0,7,0,0,7,7,3,3,0,0 %integer LITS %switch MC(0:13) LITS = LIT SIZE(TYPE) %routine COMMA MC ERROR("Comma expected") %unless SYM=',' readch(SYM) %end ->MC(TYPE) MC(1): ! constant(7) MC(2): ! constant(63) MC(3): ! constant(255) MC(4): ! constant(any) MC(5): ! register CODE = CODE!LITERAL(LITS) %return MC(13): ! source, destination CODE = CODE!OPERAND<<6 COMMA MC(6): ! operand CODE = CODE!OPERAND %return MC(12): ! reg,branch CODE = CODE!LITERAL(7)<<6 COMMA MC(7): ! branch MC ERROR("Tag expected") %unless SYM=' ' LAB == VAR(TAG) readch(SYM) MC ERROR("Label tag?") %unless LAB_RELOC=LABEL CODE PDUMP(MCODE SOB,CODE) %if TYPE=12 PDUMP(MCODE BRANCH,CODE) %if TYPE=7 PUT(LAB_DISP) %return MC(8): ! reg,dest MC(10): ! freg,dest CODE = CODE!LITERAL(LITS)<<6 COMMA CODE = CODE!OPERAND %return MC(9): ! source,reg MC(11): ! source,freg CODE = CODE!OPERAND COMMA CODE = CODE!LITERAL(LITS)<<6 %return MC(0): ! no args %end readch(SYM) %while SYM#'_' %cycle OP STRING = OP STRING.TO STRING(SYM) %unless LENGTH(OPSTRING)=6 readch(SYM) %repeat readch(SYM); ! on past the '_' INDEX = FIND(OP STRING) TYPE = MC TYPE(INDEX) CODE = MC CODE(INDEX) CODE UP MC ERROR("Extra Operands") %if SYM#';' CWORD(CODE) %unless TYPE=12 %or TYPE=7 PDUMP(RELOCS(SYM),EXTRAS(SYM)) %for SYM = 1,1,EXTRAP %end !* !* %routine define var %integer type,form,size,format,x,flags %integer new,tf,sym %own %integer prim no= -1 %record (varfm) %name v %const %byte %integer %array formmap(0:15)= %c 0, v in s, a in s, vins, 0, 0,0, 0, 0, 0, 0, v in s, a in s, v in s, a in s, 0 %const %byte %integer %array flagmap(0:15)= 0, 0, indirect, 0(4), procedure(2), procedure+indirect, procedure, array bit, 0, array bit+indirect, indirect, 0 new = 0; round = 1; size = 2 decl = tag %if decl=0 %start; !RECORD ELEMENT parms = parms-1; abort(15) %if parms<=names decvar == var(parms); decvar = 0 %finish %else %start abort(15) %if decl>=parms decvar == var(decl) %if decl>names %start names = decl; new = 1 decvar = 0 %finish %finish var name = "" %cycle readch(sym); %exit %if sym=',' var name = var name.tostring(sym) %if length(var name)#14 %repeat tf = tag; type = tf>>4; form = tf&15; !EMAS SKIPSYMBOL fptr = fptr+1; !EMAS x = tag; !EMAS: SKIPSYMBOL fptr = fptr+1; !EMAS %if type=integers %start %if x=2 %start %if form#8 %and (parameter list=0 %or amode<0 %or form#1) %start !NOT A FUNCTION OR A PARAMETER type = byte; round = 0; size = 1 %finish %finish %finish %else %start; %if type=real %start size = 4 %finish %else %start; %if type=records %start var(x) = 0 %if x>names; !FORWARD REF TO FORMAT size = -x %finish %else %start; %if type=string %start x = 255 %if x=0 size = x+1 round = 0 %finish; %finish; %finish; %finish decvar_format = size %if size<0 %start; ! RECORDS v == var(-size) size = v_format round = v_base; ! RECORD ALIGNMENT %finish otype = tag spec = otype>>3&1; otype = otype&7 decvar_type = type; decvar_form = formmap(form) flags = flagmap(form) %if alias#"" %start external name = alias; alias = "" %finish %else %start external name = var name %if otype=system %start otype = external external name = "$".var name %finish %finish %if form=3 %start; !LABEL jump to(-decl,0,-1) decvar_disp = jtag; decvar_reloc = label code decvar_type = integers %return %finish %if form=recordformat %start; !RECORDFORMAT gtype = -1 ->done %finish %if flags&procedure#0 %start %if parameter list=0 %start; !NOT A PARAMETER potype = otype gtype = spec decvar_type = decvar_type!16 %if flags&indirect#0 ->done %if new=0; !SPEC GIVEN decvar_base = level!128; decvar_reloc = label code %if otype#0 %and spec#0 %start; !EXTERNAL SPEC %if otype=primrt %start primno = primno+1; decvar_disp = primno decvar_base = primitive ->done %finish decvar_base = 128 decvar_reloc = xtag<<4 decvar_type = decvar_type!128 setx(4,xtag) %finish %else %start decvar_disp = newtag %finish ->done %finish decvar_reloc = 0 otype = 0; size = 4 %finish %else %start; !NOT A PROCEDURE %if form#1 %and form#11 %start; !NOT SIMPLE OR ARRAY %if type=0 %start; !GENERAL NAME decvar_type = general; size = 4 %finish %else %start size = 2 %finish round = 1 %finish %finish data size = size %if otype#0 %start; !OWN/EXTERNAL DATA owntype = type; ownflags = flags %if spec=0 %start gfix %if flags&indirect#0 %or (type#byte %and type#string) decvar_disp = ga; decvar_reloc = mod gla bit %if otype=2 %start; !CONST SOMETHING %if decvar_form=ains %start; !CONSTARRAYNAME decvar_form = v in s flags = flags&(\array bit) ownflags = flags otype = -1 %finish %finish decvar_disp = decvar_disp-vlb*data size %if flags&arraybit#0 setx(3,decvar_disp) %if 3<=otype<=5 %finish %else %start decvar_disp = 0; decvar_reloc = xtag<<4 setx(13,xtag); !13=USED<8>!SPEC<4>!DATA<1> %finish owntype = integers %and data size = 2 %if flags&indirect#0 ->done %finish %if form=switch %start gfix decvar_reloc = mod gla bit; decvar_disp = ga integer(addr(decvar_free)) = ga-vlb*2; !_PARAM %cycle sym = vlb,1,vub gword(0) %repeat ->done %finish decvar_base = local aligned = aligned!round %if flags&array bit=0 %start frame = (frame+round)&(\round) decvar_disp = frame frame = frame+size %finish done: decvar_form = decvar_form!flags %if diag&128#0 %start selectoutput(trace) printstring(external name); printstring(": ") write(decvar_type,1); write(integer(addr(decvar_free)),1) write(decvar_base,3); write(decvar_disp,5) write(decvar_format,4); write(decvar_reloc,2) newline selectoutput(object) %finish %end %routine amap(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer f f = amapped(v_form) abort(21) %if f=0 %if v_disp=0 %and v_reloc=0 %start %if f=av in s %start %if v_reloc=0 %start %if v_base=0 %then f = constant %else f = v in r %finish %finish %else %start; %if f=av in rec %start f = v in s v_disp = v_extra; v_extra = 0 %finish; %finish %finish f = constant %if f=av in s %and v_base=0 %and v_reloc=0 v_type = integers; v_form = f %end %routine vmap(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer n %const %byte %integer %array map(0:7)= %c v in s, v in s, v in s, a in s, v in s, v in rec, a in rec, v in rec load(v,any) %if v_form=a in s %or v_form=a in rec %if v_oper#0 %start %if v_oper=add %and const(v_link)#0 %start n = v_link_disp; drop(v_link) v_oper = 0 %if v_form=a in s %or v_form=av in s %start v_disp = v_disp+n %finish %else %start load(v,any); v_disp = n %finish %finish %else %start load(v,any) %finish %finish v_form = map(v_form) %end %routine address(%record(stackfm)%name v, %integer mode) !NOTIMP80 %recordspec V(STACKFM) !convert V into a form in which it%c may be used as an operand !mode = 0 - value required (rhs) ! = 1 - address required (lhs) ! =-1 - value required, but leave%c av in s alone !All register usage optimisations%c flow through here !Note: Arrays enter with +-constant%c offset from the index ! in v_extra: any record%c reduction has already been done. ! See ARRAY REF. %integer reg,next,r,which,assign any,z %integer type,form,base,disp,reloc,oper,scale,flags %record (usefm) %name u,ux %record (stackfm) opt1,opt2 %record (stackfm) temp %record (stackfm) %name vx monitor(v,"address") %if diag&32#0 %if v_form>=a in rec %start; !RECORDS temp = 0 temp_type = integers temp_form = v in s %if v_flags&pending#0 %start; !SEE hazard v_flags = v_flags-pending %finish %else %start temp_reloc = v_reloc v_reloc = 0 %finish temp_base = v_base temp_disp = v_extra; v_extra = 0 load(temp,any); !PICK UP RECORD BASE v_form = v_form-rec mod v_base = temp_base %finish load base(v) oper = v_oper %if oper#0 %start %if oper#indexing %start %if v_type=real %or v_link_type=real %start load(v,anyf) %finish %else load(v,any) %return %finish vx == v_link load base(vx); !***new*** opt1 = v; opt2 = vx; opt1_link == opt2 v_oper = 0 %finish flags = v_flags; v_length = 2 %if flags&indirect#0 base = v_base; disp = v_disp; scale = v_length type = v_type; form = v_form; reloc = v_reloc which = integer reg; which = real reg %if type=real %if type=real %then assign any = anyf %else assign any = any assign reg = assign any %if mode>0 %cycle r = r0,1,r3; !EXAMINE THE AVAILABLE REGISTERS reg = r+which next = usage(reg) c1: %while next#0 %cycle u == uses(next); next = u_link %if oper#0 %start; !ARRAY INDEX ->c1 %if u_index=0; !NOT INDEXED ux == uses(u_index) ->c1 %unless u_bt&15=base %and u_form=form %and %c integer(addr(ux_index))=scale ->c1 %unless u_form#a in s %or u_disp=disp !THE ARRAYS ARE COMPATIBLE - CHECK%c THE INDEX ->c1 %unless ux_bt=vx_base+vx_type<<4 %and ux_disp=vx_disp ->c1 %unless ux_form=vx_form %and ux_reloc=vx_reloc !MATCHED -- UPDATE v release and drop(vx) release(v_base); claim(reg) v_base = reg %if v_form=a in s %start v_disp = 0; !USE ARRAY DISP ONLY FOR ARRAYS v_reloc = 0; !REMOVE RELOCATION %finish v_disp = v_disp+v_extra; v_extra = 0 v_form = v in s v_form = a in s %if flags&indirect#0 address(v,mode); ; !{TRY TO IMPROVE IT} %return %finish ->c1 %unless u_disp=disp %and u_bt&15=base ->c1 %unless u_reloc=reloc %and u_index=0 %if u_form=form %and u_bt>>4=type %start %if mode>0 %start assign reg = assign any+reg %finish %else %start release(base); claim(reg) v_base = reg; v_disp = 0; v_reloc = 0 v_type = integers %if v_type=byte v_form = v in r v_extra = 0 %return %finish %finish %if u_form=amapped(form) %and u_bt>>4=integers %start !THE ADDRESS IS IN THE REG release(base) claim(reg) v_base = reg; v_disp = 0; v_reloc = 0; v_extra = 0 v_form = v in s address(v,mode) %if mode<=0; !TRY AGAIN %return %finish %repeat %repeat !CANNOT OPTIMISE IT %if oper#0 %start; !CALCULATE ARRAY INDEX !CODE SEQUENCE FOR ARRAYS IS: ! *mov_INDEX,r1 PICK UP%c THE INDEX ! *asl_r1 SCALE IT%c (2 BYTES/ELEMENT) ! *add_array base,r1 ADD IN%c THE BASE FOR THE ARRAY ! THE ARRAY IS NOW ADDRESSED AS%c array disp(r1) !FOR ARRAYNAMES THE CODE IS: ! *mov_index,r1 PICK UP%c THE INDEX ! *asl_r1 SCALE IT ! *add_andisp(anbase), r1 ADD IN%c addr(a(0)) ! THE ARRAY IS NOW ADDRESSED AS%c 0(r1) stack s(vx); !STACK THE INDEX z = vx_disp z = 1 %if vx_form#constant drop(vx) stack c(scale); !AND THE SCALING FACTOR operate(mul); !MULTIPLY THEM stack s(v); !STACK THE ARRAY v_base = 0; !TO FOOL HAZARD amap(rhs) reloc = 0 %if rhs_form=v in s %and z#0 operate(add); !ADD IN ADDR(A(0)) stack c(v_extra); operate(add); !ADD ANY EXTRA DISPLACEMENT !nOTE: CONST+REG->AV IN S pop lhs; vmap(lhs) lhs_reloc = reloc remember(lhs_base,opt1) %if array opt#0 %and lhs_base#opt1_base lhs_format = v_format v = lhs; v_extra = 0 vmap(v) %if flags&indirect#0 v_type = type drop(lhs) %return %finish load(v,any) %if v_form=av in s %and v_base#0 %and mode>=0 local use = local use!(1<<(local-16)) %if v_base=lnb %end %routine left(%record(stackfm)%name v, w, %integer reg) !NOTIMP80 !NOTIMP80 %recordspec V(STACKFM); %recordspec w(stackfm) %switch spec(0:15) load(v,reg) %if w_form=constant %start cons_disp = w_disp&15 ->spec(cons_disp) spec(2): claim(v_base); op2(addw,v,v) spec(1): claim(v_base); op2(addw,v,v); %return spec(8): spec(9): spec(10): op1(swab,v); op1(clrb,v) cons_disp = cons_disp-8 ->spec(cons_disp) spec(15): op1(ror,v); op1(clr,v); op1(ror,v) spec(0): %return spec(3): spec(4): spec(5): spec(6): spec(7): spec(11): spec(12): spec(13): spec(14): rop(ash,v_base,cons); %return %finish load(w,any) %if w_form=av in s %or w_type=byte rop(ash,v_base,w) %end %routine right(%record(stackfm)%name v, w, %integer reg) !NOTIMP80 !NOTIMP80 %recordspec V(STACKFM); %recordspec w(stackfm) %switch spec(0:15) %integer disp load(v,reg) %if w_form=constant %start disp = w_disp&15 ->spec(disp) spec(1): spec(2): spec(3): spec(4): cword(k'000241'); op1(ror,v) rest: %cycle disp = disp-1; %return %if disp=0 op1(asr,v) %repeat spec(8): spec(9): spec(10): spec(11): spec(12): op1(clrb,v); op1(swab,v); disp = disp-7; ->rest spec(5): spec(6): spec(7): spec(13): spec(14): cons_disp = -disp rop(ash,v_base,cons) cons_disp = \(k'177777'>>disp) op2(bicw,cons,v) spec(0): %return spec(15): op1(rol,v); op1(clr,v); op1(rol,v); %return %finish load(w,any) test zero(w) cword(k'003404'); !BLE .+4 cword(k'000241'); op1(ror,v) op1(dec,w); cword(k'003374'); !BGT .-4 %end %routine load base(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %record (stackfm) b %integer n %return %if v_base<16 n = v_base-16 v_base = lnb %and %return %if v_base=local local use = local use!(1<=0 b = 0 b_type = integers; b_form = v in s b_base = lnb; b_disp = (n-1)*2 load(b,any) v_base = b_base %end %routine load(%record(stackfm)%name v, %integer reg) !NOTIMP80 %recordspec V(STACKFM) %integer oper,key,r,x %record (stackfm) %name w,wx %record (stackfm) ts %routine swop %record (stackfm) hold hold = v; v = w; w = hold %end %switch iop(swob:sha),f(constant:avins) monitor(v,"load".itos(reg)) %if diag&1#0 oper = v_oper; v_oper = 0 ->reals %if reg&anyf#0 %or f0<=reg<=f3 %or v_type=real %if oper#0 %start w == v_link; ->reals %if w_type=real; address(v,-1) %if oper>0 %start address(w,0) %unless %c (w_form=av in s %and (oper=add %or oper=sub)) %or oper=conc %finish %if comm(oper)#0 %start; !COMMUTATIVE %if (w_form=v in r %and activity(v_base)<0) %or w_base=reg %or %c (w_type=byte %and v_type#byte %and v_base#reg) %start swop %finish %finish %if w_base=reg %and reg#any %start v_oper = oper; v_link == w load(v,any); load(v,reg) %return %finish key = opcode(oper) ->iop(oper) %finish amap(v) %if v_type=string %and v_form#v in r address(v,-1) %if reg=any %start %return %if v_form=v in r %and activity(v_base)=1 %if v_form=av in s %and v_base<16 %and activity(v_base)=1 %start reg = v_base %finish %else %start reg = reg-any reg = register(integer reg) %if reg=0 %finish %finish %if v_base=reg %start %return %if v_form=v in r %finish %else %start hazard(reg) %finish ->f(v_form) f(constant): f(a in s): f(v in s):%if v_type=byte %start %if byte inhibit#0 %start; !AND FOLLOWING op2(movb,v,vr(reg)) %finish %else %start; %if v_base#reg %start op1(clr,vr(reg)) op2(bisb,v,vr(reg)) %finish %else %start %if v_form=ains %or (v_base#0 %and v_base#lnb) %start oper = movb %finish %else %start oper = mov; !FASTER THAM MOVB %finish op2(oper,v,vr(reg)) %if v_disp&1#0 %and oper=mov %start op1(clrb,vr(reg)) op1(swob,vr(reg)) %finish %else %start cons_disp = \255; op2(bicw,cons,vr(reg)) %finish %finish; %finish v_type = integers %finish %else %start f(v in r): op2(mov,v,vr(reg)) %finish cout: claim(reg) out: remember(-reg,v) v_base = reg; v_disp = 0; v_form = v in r; v_extra = 0 v_reloc = 0 %return f(avin s):%if v_base=0 %start op2(mov,v,vr(reg)) ->cout %finish w == record(descriptor); stp = stp-1 w = v; w_base = 0; w_form = constant; oper = 0 v_reloc = 0; v_form = v in r; v_disp = 0 key = addw; !AND...... !*********%c ************************************** iop(or): iop(sub): iop(add):load(v,reg) load(w,any) %if w_type=byte %if w_form=av in s %start %if oper=or %start load(w,any) %finish %else %start op2(key,vr(w_base),v) %and release(w_base) %if w_base#0 w_base = 0; w_form = constant %finish %finish op2(key,w,v) drop(w) %return %unless oper=0; !AV IN S v_disp = w_disp; v_reloc = w_reloc; v_form = av in s ->out iop(and):swop %if w_form=constant %if v_form=constant %start %if w_type=byte %start v_disp = v_disp&255; byte inhibit = 1 %finish load(w,reg) byte inhibit = 0 %if v_disp=x'FF00' %start v = w op1(clrb,v); drop(w); %return %finish v_disp = \v_disp %finish %else %start load(w,reg) load(v,any) op1(com,v) %finish iop(bic):swop load(v,reg) load(w,any) %if w_type=byte %or w_form=av in s op2(bicw,w,v) drop(w); %return iop(neg): iop(not): iop(swob):load(v,reg) op1(key,v); %return iop(xor):load(v,reg); load(w,any) %if control&noeis=0 %start rop(xorw,w_base,v) %finish %else %start ts = w; claim(w_base) load(ts,any) op2(bicw,v,ts); claim(v_base) op2(bicw,w,v) op2(bis,ts,v) %finish drop(w); %return iop(sha):load(v,reg) key = w_disp %if key=-1 %or key=-2 %start op1(asr,v) op1(asr,v) %if key=2 %finish %else %start rop(ash,v_base,w) %finish drop(w); %return iop(lsh):left(v,w,reg); drop(w); %return iop(rsh):right(v,w,reg); drop(w); %return iop(mul):%if reg=r1 %or reg=r3 %start r = reg %finish %else %start; %if reg=any %and v_form=v in r %start %if v_base=r0 %or v_base=r1 %then r = r1 %else r = r3 %finish %else %start %if activity(r1)<=activity(r3) %then r = r1 %else r = r3 %finish; %finish load(v,r) address(w,0); rop(mulw,r,w); forget(r) load(v,reg) %if reg#r %and reg#any drop(w); %return iop(div): iop(remy):%if reg=any %start %if v_form=v in r %and (v_base=r1 %or v_base=r3) %start r = v_base %finish %else %start %if activity(r1)<=activity(r3) %then r = r1 %else r = r3 load(v,r) %finish %finish %else %start r = reg r = r+1 %if r=r0 %or r=r2 load(v,r) %finish test zero(v); claim(r) hazard(r-1); claim(r-1) v_base = r-1 %if no eis&control=0 %then op1(sxt,v) forget(r-1) address(w,0) rop(divw,r-1,w); forget(r) v_base = r %if oper#div release(r+r-1-v_base) load(v,reg) %if v_base#reg %and reg#any drop(w); %return iop(exp):push(v); push(w) perm(iexp) v_form = v in r; v_extra = 0 v_base = r1; v_disp = 0; claim(r1) load(v,reg) %if reg#r1 %and reg#any drop(w); %return iop(conc):%if v_flags&in temp=0 %start; !NEEDS A TEMP ts = 0 ts_type = string; ts_form = v in s ts_base = local; ts_disp = temp string(256) load(ts,r2) load(v,r1); release(r1) release(r2); perm(smove); claim(r2) %finish %else %start load(v,r2) %finish %cycle wx == w; w == w_link oper = wx_oper; wx_oper = 0 lrd(wx,r1) release(r2); perm(concat); claim(r2) %exit %if oper=0 %repeat v = 0 v_base = r2; v_form = v in s v_disp = 0; v_type = string load(v,reg) %if reg&any=0 %return reals: %if oper#0 %start w == v_link load(v,reg) %if oper<0 %start op1(negf,v); %return %finish %if w_type=real %then address(w,0) %else load(w,anyf) key = rcode(oper); abort(24) %if key=0 fop(key,v_base,w) drop(w) %return %finish %if v_type#real %start %if v_type=byte %then load(v,any) %else address(v,0) key = ldcif %finish %else %start address(v,0) key = ldf %finish %if reg&anyf#0 %start %return %if v_form=v in r %and v_type=real reg = reg-anyf reg = register(real reg) %if reg=0 %finish %else %start hazard(reg) %unless v_base=reg %finish fop(key,reg,v) v_base = reg; v_disp = 0; v_type = real; v_form = v in r claim(reg) %end %routine lrd(%record(stackfm)%name v, %integer reg) !NOTIMP80 %recordspec V(STACKFM) load(v,reg) release and drop(v) %end %routine c load(%integer value,reg) stack c(value) pop lhs lrd(lhs,reg) %end %routine operate(%integer oper) %record (stackfm) %name lhs,rhs,with %integer lvar,rvar,wvar %integer op,key,mask,n %routine swop wvar = lvar; lvar = rvar; rvar = wvar with == lhs; lhs == rhs; rhs == with stacked(stp)_v == lhs %end %routine constant operation(%integer op, %integer %name l, %integer r) %switch cop(swob:bic) ->cop(op) cop(conc): cop(bic): !SHOULD NEVER BE GENERATED ON%c CONSTANTS cop(swob): cop(neg): cop(not): abort(13) cop(add): l = l+r; %return cop(sub): l = l-r; %return cop(and): l = l&r; %return cop(or): l = l!r; %return cop(xor): l = l!!r; %return cop(mul): l = l*r; %return cop(lsh): l = l<>r; %return cop(exp): abort(15) %if r<0 l = l\\r; %return cop(div): abort(14) %if r=0 l = l//r; %return cop(remy): abort(14) %if r=0 l = l-l//r*r %end %if oper<0 %start; !UNARY lhs == stacked(stp)_v %if const(lhs)#0 %start %if oper=neg %start lhs_disp = -lhs_disp %finish %else %start; %if oper=not %start lhs_disp = \lhs_disp %finish %else %start; !SWAB(CONST) abort(0); !JUST FOR BOOTSTRAPPING %finish; %finish %finish %else %start %if lhs_oper#0 %start; !UNARY(A OPER B) lhs_oper = 0 %if lhs_oper=oper; !E.G. -(-A) %if (lhs_oper=not %or lhs_oper=neg) %and oper#swob %start !-(\A) OR \(-A) stack c(1); operate(-oper); %return %finish load(lhs,any) %finish lhs_oper = oper; lhs_link == null %finish %return %finish stp = stp-1; !POP ONE OPERAND lhs == stacked(stp)_v rhs == stacked(stp+1)_v %if oper=conc %start lhs == lhs_link %while lhs_oper#0 lhs_oper = conc; lhs_link == rhs %return %finish %if const(lhs)#0 %then lvar = 0 %else lvar = -1 %if const(rhs)#0 %then rvar = 0 %else %start rvar = -1 address(rhs,-1) %unless oper=indexing %finish swop %if lvar=0 %and comm(oper)#0; !GET: VAR OPER CONST %if oper=sub %and rvar=0 %start; !A-CONST -> A+(-CONST) oper = add; rhs_disp = -rhs_disp %finish %if lhs_oper#0 %start op = lhs_oper wvar = -1 %if op<0 %start %if op=not %and oper=and %start; !BIC = \A&B lhs_oper = 0; operate(bic); %return %finish %if oper=add %and (op=neg %or (op=not %and rvar#0)) %start !(-A)+B -> B-A rhs_disp = rhs_disp-1 %if op=not !(\A)+CONST -> (CONST-1)-A %if rvar#0 %and rhs_disp=0 %start; !0-?? lhs_oper = neg; drop(rhs) %finish %else %start lhs_oper = 0 swop lhs_oper = sub; lhs_link == rhs %finish %return %finish %finish %else %start with == lhs_link wvar = 0 %if const(with)#0 %finish %if wvar!rvar=0 %start; !(A OP CONST) OPER CONST key = trans(op)!trans(oper) %if key=0 %or (key=1 %and oper=op) %start constant operation(oper,with_disp,rhs_disp) drop(rhs) %if with_disp=null op(op) %start; !E.G. A*1 lhs_oper = 0; drop(with) %finish %else %start; %if with_disp=-1 %and (op=mul %or %c op=xor) %start !A*(-1) -> -A, A!!(-1) -> \A %if op=mul %then lhs_oper = neg %else lhs_oper = not drop(with) %finish; %finish %return %finish %if op=rsh %and oper=and %start mask = (-1)>>with_disp n = rhs_disp&mask %if n=mask %start; !CLEARED BY SHIFT drop(rhs); %return %finish with_disp = -with_disp rhs_disp = n; lhs_oper = sha lhs_oper = swob %and drop(with) %if with_disp=-8 %and n<=255 %finish %finish load(lhs,any) %finish %if lvar!rvar=0 %and oper<15 %start; !CONST OPER CONST constant operation(oper,lhs_disp,rhs_disp) drop(rhs); %return %finish %if rhs_oper#0 %start %if rhs_oper=neg %and (oper=add %or oper=sub) %start !A+(-B) -> A-B oper = add+sub-oper rhs_oper = 0 %finish %else %start; %if rhs_oper=not %and oper=and %start !A&(\B) -> \B&A -> BIC(B, A) swop; oper = bic %finish %else %start load(rhs,any) %finish; %finish %finish %if rvar=0 %start %if rhs_disp=null op(oper) %and oper#indexing %start drop(rhs); %return %finish %if oper=mul %start; !A*CONST key = power(rhs_disp) %if key>=0 %start; !CAN USE SHIFT rhs_disp = key; oper = lsh %finish %else %start; %if rhs_disp=-1 %start !A*(-1) -> -A drop(rhs); lhs_oper = neg; %return %finish; %finish %finish %else %start; %if oper=xor %and rhs_disp=-1 %start !A!!(-1) -> \A drop(rhs); lhs_oper = not; %return %finish %else %start; %if oper=add %start; !A+CONST lhs_form = av in s %if lhs_form=v in r %if lhs_form=av in s %or lhs_form=av in rec %start lhs_disp = lhs_disp+rhs_disp drop(rhs); %return %finish %finish; %finish; %finish %finish %if oper=add %and rhs_form=av in s %start load(lhs,any) %if lhs_form#av in s %or lhs_reloc#0 lhs_reloc = rhs_reloc n = lhs_disp+rhs_disp %if lhs_base=0 %start lhs_base = rhs_base; drop(rhs) %finish %else %start; %if rhs_base=0 %start drop(rhs) %finish %else %start lhs_form = v in r; rhs_form = v in r lhs_oper = add; lhs_link == rhs load(lhs,any) %finish; %finish lhs_form = av in s; lhs_disp = n %finish %else %start lhs_oper = oper; lhs_link == rhs %finish %end; !OF OPERATE %integer %fn temp string(%integer size) size = 256 %if size=0 %while stemp=size %repeat smax = smax+1 %if smax#3 stemp = smax lstring(smax) = size dstring(smax) = frame; frame = (frame+size+1)&(\1) %result = dstring(smax) %end %routine move string(%record(stackfm)%name from, to) !NOTIMP80 !NOTIMP80 %recordspec FROM(STACKFM); %recordspec%c to(stackfm) load(from,r1) load(to,r2) release(r1); release(r2) perm(smove) %end %integerfn safe(%record(stackfm)%name target, chain) !NOTIMP80 !NOTIMP80 %recordspec TARGET(STACKFM); %recordspec%c chain(stackfm) %result = 1 %if target_flags&in temp#0 %cycle %result = 0 %if same(target,chain)#0 %result = 1 %if chain_oper=0 chain == chain_link %repeat %end %routine push(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer base load(v,any) %if v_oper#0 amap(v) %if v_type=string address(v,-1) %if v_form=av in s %and (v_reloc=0 %or v_base#0) %start !mov_disp,(ds): add_base,(ds)+ base = v_base v_base = 0; v_form = constant %if v_reloc=0 %if base#0 %start op2(mov,v,at ds) v_base = base; v_form = v in r; v_reloc = 0 op2(addw,v,to ds) %finish %else %start op2(mov,v,to ds) %finish v_form = av in s %finish %else %start %if v_type=byte %start op2(movb,v,to ds) op1(clrb,to ds) %finish %else %start %if v_type=real %start load(v,anyf) fop(stf,v_base,to ds) %finish %else %start op2(mov,v,to ds) %finish %finish %finish %end %routine assign(%integer assop) ! ASSOP = -1 - PARAMETER ! = 0 - == ! = 1 - = ! = 2 - <- %switch op(swob:sha) %record (stackfm) %name ass lhs,ass rhs %record (stackfm) %name with,proc %record (stackfm) temp %integer oper,opc,p,b,t,n %routine swop %record (stackfm) t t = ass rhs; ass rhs = with; with = t %end %routine store(%record(stackfm)%name rhs, lhs) !NOTIMP80 !NOTIMP80 %recordspec RHS(STACKFM); %recordspec%c lhs(stackfm) %integer b,oper push(rhs) %and %return %if lhs_base=ds b = rhs_base; b = 1 %if rhs_form#v in s address(rhs,0) %if rhs_type=byte %and lhs_type#byte %and lhs_form=vins %start %if rhs_form=vins %and rhs_disp&1=0 %and (b=0 %or b>=16) %start oper = mov %finish %else oper = movb op2(oper,rhs,lhs) claim(lhs_base); lhs_disp = lhs_disp+1 op1(clrb,lhs) %finish %else %start load(rhs,any) %if (rhs_type=byte %and lhs_type#byte) %if lhs_type=byte %then oper = movb %else oper = mov op2(oper,rhs,lhs) %finish %end set both ass lhs == lhs; ass rhs == rhs %if assop<0 %start; !PARAMETER %if ass lhs_base=primitive %start temp = ass lhs; ass lhs = ass rhs; ass rhs = temp %return %finish proc == ass lhs proc_extra = proc_extra-1 v == var(proc_extra) stack v(v); ass lhs == lhs assop = 0 %if ass lhs_form#v in s %finish stp = stp-2 %if ass lhs_type=general %start ass lhs_form = v in s address(ass lhs,1) %if ass rhs_type=general %start temp = ass rhs claim(temp_base); temp_disp = temp_disp+2 amap(temp) %finish %else %start temp = 0 temp_type = integers temp_disp = ass rhs_type+ass rhs_length<<3; ! USED TO BE X<<13%c + Y amap(ass rhs) %finish amap(ass rhs) store(ass rhs,ass lhs) ass lhs_disp = ass lhs_disp+2 %if ass lhs_disp#ds store(temp,ass lhs) ->out %finish %if ass lhs_flags&procedure#0 %start; !PROC PARAMETER %if ass rhs_base&128#0 %start; !ASS RHS A NORMAL PROC cword(k'010425'); !MOV_LNB,(DS)+ cword(k'012725'); !MOV_#EP,(DS)+ pdump(ass rhs_reloc,ass rhs_disp) %finish %else %start; !ASS RHS A PARAMETER ass rhs_form = v in s address(ass rhs,0) ass lhs_form = v in s op2(mov,ass rhs,ass lhs) ass rhs_disp = ass rhs_disp+2; claim(ass rhs_base) op2(mov,ass rhs,ass lhs) %finish ->out %finish %if assop=0 %start; !== amap(ass lhs); amap(ass rhs) %finish %if ass rhs_oper=0 %and same(ass lhs,ass rhs)#0 %start release(ass lhs_base); release(ass rhs_base); ->out %finish %if ass lhs_type=records %start n = var(-ass lhs_format)_format amap(ass lhs); load(ass lhs,any) %unless ass lhs_base=ds forget(ass lhs_base) %if const(ass rhs)#0 %start p = k'105020'+actual(ass lhs_base) %finish %else %start p = var(-ass rhs_format)_format n = p %if n=0 %or (p#0 %and p8 %start oper = register(integer reg) cload(n,oper) cword(p) %if control&no eis=0 %start cword(sob+actual(oper)<<6+2) %finish %else %start cword(k'005300'+actual(oper)); !DEC R cword(k'003000'+(-3)&255); !BGT .-3 %finish forget(oper) %finish %else %start %cycle n = n-1,-1,0 cword(p) %repeat %finish %return %finish %if ass lhs_base=param %start p = ass lhs_disp load(ass rhs,p) %if ass rhs_oper#0 drop(ass lhs) ass rhs_link == proc_link; ass rhs_oper = p proc_link == ass rhs %return %finish %if ass lhs_type=real %start address(ass lhs,1) load(ass rhs,assign reg) fop(stf,ass rhs_base,ass lhs) ->out %finish oper = ass rhs_oper %if oper#0 %start ass rhs_oper = 0 with == ass rhs_link %if oper#conc %start address(ass lhs,1) address(ass rhs,0) address(with,0) %if oper>0 %finish opc = opcode(oper) ->op(oper) %finish address(ass lhs,1) %if ass lhs_type=string %start %if ass lhs_base=ds %start; !PARAMETER spar: load(ass rhs,r1); release(r1) perm(spmove); cword((ass lhs_length+1)&(\1)) %finish %else %start; %if ass rhs_length=1 %start !NULL ass lhs_type = byte; ass rhs_type = integers ass rhs_disp = 0; ass rhs_form = constant ass rhs_reloc = 0 ->stuff %finish %else %start move string(ass rhs,ass lhs) %finish; %finish drop(ass rhs); drop(ass lhs) %return %finish stuff: store(ass rhs,ass lhs) out: drop(ass rhs); drop(ass lhs); %return wout: release(ass rhs_base); drop(with); ->out op(exp): load it: op(mul): op(div): op(remy): ass rhs_oper = oper; load(ass rhs,any) !!!!! FORGET DEST(ASS LHS) %if ass lhs_type=byte %then opc = movb %else opc = mov op2(opc,ass rhs,ass lhs) ->out op(conc):ass rhs_oper = conc %and ->spar %if ass lhs_base=ds %if safe(ass lhs,with)#0 %start %if same(ass lhs,ass rhs)#0 %start; ! S = S.????? release(ass rhs_base) %finish %else %start move string(ass rhs,ass lhs) claim(r2) %finish ass lhs_link == with ass lhs_oper = conc ass lhs_flags = ass lhs_flags!in temp load(ass lhs,any); release(ass lhs_base) %finish %else %start ass rhs_oper = conc move string(ass rhs,ass lhs) %finish ->out op(xor): ->load it %if control&noeis#0 swop %if same(ass lhs,with)#0 ->load it %unless same(ass lhs,ass rhs)#0 %and ass lhs_type=integers load(with,any) rop(xorw,with_base,ass lhs); ->wout op(swob):->load it %if ass lhs_type=byte op(neg): op(not): ->load it %unless same(ass lhs,ass rhs)#0 !!!!! FORGET DEST(ASS LHS) op1(opc,ass lhs); release(ass rhs_base) ->out op(add): op(or): swop %if same(ass lhs,with)#0 op(sub): ->load it %unless same(ass lhs,ass rhs)#0 %if ass lhs_type=byte %start ->load it %if oper#or opc = bisb %finish load(with,any) %if with_type#ass lhs_type !!!!! FORGET DEST(ASS LHS) op2(opc,with,ass lhs) ->wout op(bic): ->load it %unless same(ass lhs,with)#0 !!!!! FORGET DEST(ASS LHS) opc = bicb %if ass lhs_type=byte op2(opc,ass rhs,ass lhs) release and drop(with); ->out op(and): swop %if same(ass lhs,with)#0 ->load it %unless same(ass lhs,ass rhs)#0 %if with_form=constant %start with_disp = \with_disp %finish %else %start load(with,any) op1(com,with); forget(with_base) %finish opc = bicb %if ass lhs_type=byte op2(opc,with,ass lhs); ->wout op(lsh): op(rsh): ->load it %unless same(ass lhs,ass rhs)#0 ->load it %unless with_form=constant %if with_disp=1 %start cword(k'000241') %if oper=rsh opc = opc!k'100000' %if ass lhs_type=byte op1(opc,ass lhs) %finish %else %start; %if with_disp=8 %and %c ass rhs_type=integers %start claim(ass lhs_base) op1(clrb,ass lhs) %if oper=rsh op1(swab,ass lhs) op1(clrb,ass lhs) %if oper=lsh %finish %else ->load it; %finish ->wout %end; !OF ASSIGN %routine return %return %if uncond jump=ca selectoutput(direct); printch(return code); put(ca) selectoutput(object); printch(procedure return) cword(rtpc) uncond jump = ca %end %routine test zero(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %record (stackfm) %name w %integer op,d,which monitor(v,"test zero") %if diag&1#0 %if v_oper=bic %and v_form=constant %start v_oper = and; v_disp = \v_disp %finish %if v_oper=and %and (test='=' %or test='#') %start v_oper = 0; w == v_link op = bit; d = v_base address(v,0) address(w,0) %if v_type=byte %start op = bitb !* %if W_FORM = CONSTANT %start !* %if (V_FORM = V IN S %or V_FORM = V IN REC) !* %c %and (D = 0 %or D > 128) %start !* V_TYPE = INTEGERS;!* OP = BIT !* %if V_DISP&1 # 0 %start !* W_DISP = W_DISP<<8;!* V_DISP = V_DISP&(\1) !* %finish !* %finish !* %finish %finish op2(op,v,w); cc ca = -1; drop(w); %return %finish load(v,any) %if v_oper#0 which = any; which = anyf %if v_type=real unsigned = 10 %and ccca = 0 %if v_type=byte address(v,0) d = 0 %cycle %if ccca=ca %and (same(ccrhs,v)#0 %or same(cclhs,v)#0) %start cword(cfcc) %if which=anyf release(v_base); %return %finish %exit %unless d=0 %and v_type=integers %and register spare#0 d = 1 load(v,any) %repeat %if v_type=integers %start op = tst %finish %else %start %if v_type=real %then op = tstf %else op = tstb %finish op1(op,v) cword(cfcc) %if op=tstf %end %routine compare strings(%record(stackfm)%name l, r) !NOTIMP80 !NOTIMP80 %recordspec L(STACKFM); %recordspec r(stackfm) %if l_oper!r_oper=0 %start %if l_length=1 %start; ! LEFT NULL r_type = byte; test zero(r) invert = invert!!32; %return %finish %if r_length=1 %start; !RIGHT NULL l_type = byte; test zero(l) %return %finish %finish address(r,0); !TO FORCE A LOAD IF NESC. load(l,r1); load(r,r2) release(r1); release(r2) perm(scomp) %end %routine compare(%record(stackfm)%name l, r) !NOTIMP80 !NOTIMP80 %recordspec L(STACKFM); %recordspec r(stackfm) %integer op %if diag&1#0 %start monitor(l,"comp lhs") monitor(r,"comp rhs") %finish unsigned = 0 !EMAS: TEST = NEXTSYMBOL; !CONDITION TEST FOLLOWING test = byteinteger(fptr); !EMAS %if l_type=string %start compare strings(l,r) l_type = string; r_type = string %return %finish %if zero(r)#0 %start test zero(l); %return %finish %if zero(l)#0 %start test zero(r); invert = invert!!32; %return %finish address(l,0); address(r,0) %if l_type=real %or r_type=real %start load(l,anyf) load(r,anyf) %if r_type#real fop(cmpf,l_base,r) cword(cfcc) cc ca = -1 %return %finish %if l_type#r_type %start %if l_type=byte %start %if r_form=constant %and r_disp>>8=0 %start r_type = byte %finish %else load(l,any) %finish %else %start; %if l_form=constant %and l_disp>>8=0 %start l_type = byte %finish %else load(r,any); %finish %finish %if l_type=byte %then op = cmpb %and unsigned = 10 %else op = cmp %if l_form=v in r %start op2(op,r,l); invert = invert!!32; !FASTER WITH REG SECOND know(l_base,r) %if test='#' %finish %else %start op2(op,l,r) know(r_base,l) %if r_form=v in r %and test='#' %finish cc ca = -1; !ZERO COND CODE UNKNOWN!!! %end %routine array ref(%integer mode) %integer l %record (stackfm) %name x !MODE = 0 FINAL/ONLY INDEX ! = 1 ALL OTHERS set both %if mode#0 %start load(rhs,any) %if rhs_oper#0 rhs_link == lhs_link lhs_link == rhs lhs_oper = multi stp = stp-1; !POP THE INDEX %return %finish %if lhs_oper=multi %start lhs_oper = 0 %cycle push(rhs) drop(rhs) rhs == lhs_link; %exit %if addr(rhs)=addr(null) lhs_link == rhs_link %repeat stp = stp-1; !POP INDEX stack s(lhs); !THE ARRAY pop lhs lhs_type = integers; lhs_form = v in s push(lhs); drop(lhs) perm(aref) set lhs lhs_form = v in s; lhs_form = a in s %if lhs_flags&indirect#0 lhs_disp = 0; lhs_reloc = 0 lhs_base = r1; claim(r1) %return %finish address(lhs,1); lhs_extra = 0 !change A(X+CONST) into a(X)++CONST%c i.e. add the !constant into the displacement of A.%c Note that !if X is in a register OPERATE will%c have changed the !expression into an AVINS. l = lhs_length l = 2 %if lhs_flags&indirect#0 %if const(lhs)#0 %start lhs_extra = rhs_disp*l rhs_disp = 0 %finish %if (rhs_oper=0 %and rhs_form=av in s) %or (rhs_oper=add %and %c const(rhs_link)#0) %start x == rhs x == rhs_link %if x_oper#0 lhs_extra = x_disp*l %if x_form=av in s %start x_form = v in r; x_disp = 0 %finish %else %start rhs_oper = 0; drop(x) %finish %finish !!!! ADDRESS(RHS, 0) operate(indexing) set lhs; address(lhs,1); !TO PREVENT TROUBLE WITH ! a(j) = j WHERE j = rN %end !LABEL PROCESSING %integer %fn new label labs = labs+1; abort(5) %if labs>max label %result = addr(labels(labs)) %end %integer %fn find(%integer label) %integer lp %record (labelfm) %name l lp = labs %while lp#label start %cycle l == labels(lp) %result = addr(l) %if l_id=label lp = lp-1 %repeat %result = addr(null label) %end %routine define label(%integer label) %record (envfm) %name e %record (labelfm) %name l %return %if label=0 l == record(find(label)) %if addr(l)=addr(null label) %start l == record(new label) l_id = label; l_tag = new tag forget everything e == record(environment(label)); e_label = 0 %finish %else %start; %if l_tag&x'8000'#0 %and label>=0 %start l_tag = new tag e == record(environment(label)); e_label = 0 %finish; %finish l_tag = l_tag!x'8000' define tag(l_tag&x'7FFF') merge environment(label) %if uncond jump#ca restore environment(label) ccca = 0 uncond jump = -1; !YOU CAN GET HERE! %end %routine jump to(%integer label,cond,def) %const %byte %integer %array rev(0:19)= %c 0, 1, 2, 5, 6, 3, 4, 7, 8, 9, 10,11,12,15,16,13,14,17,18,19 !COND+10 == LOGICAL BRANCH %record (labelfm) %name lab invert = 0 %return %if label=0 %or uncond jump=ca cond = rev(cond&31) %if cond&32#0 cond = cond!32 %unless cond=jump lab == record(find(label)) %if addr(lab)=addr(null label) %start lab == record(new label) lab_id = label lab_tag = new tag remember environment(label) %finish %else %start; %if lab_tag&x'8000'#0 %and def#0 %start lab_tag = new tag remember environment(label) %finish %else %start merge environment(label) %if lab_tag&x'8000'=0 %finish; %finish jtag = lab_tag&x'7FFF' %if def<0 %start; !FROM DEFINE VAR select output(direct) printch(8); put(jtag) select output(object) %return %finish define reference(jtag,cond) pdump(branch code,jtag); printch(cond) ccca = ccca+2 uncond jump = ca %if cond=jump; !NO WAY PAST HERE %if known flag#0 %start; !SOMETHING TO LEARN known flag = 0 remember(known reg,known v) %finish %end %routine load params(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %record (stackfm) %name w %integer reg %return %if addr(v)=addr(null) reg = v_oper; v_oper = 0 w == v_link load(v,reg) load params(w) release and drop(v) %end %routine call(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %switch b(0:15) %integer addr,t,l %record (stackfm) temp %routine tostring(%integer n) lhs_base = 0; lhs_disp = ga lhs_type = string; lhs_form = v in s lhs_reloc = mod gla bit n = n&255 %if n=nl %start; !CATCH SNL lhs_disp = snl %and %return %if snl>=0 snl = ga %finish gbyte(1); gbyte(n) %end monitor(v,"call") %if diag&1#0 %if v_base=primitive %start; !IN-LINE drop(v) set lhs; !PARAMETER (POSS SECOND) l = 0; t = v_disp; sym = 0 ->b(t) b(13): !**SNL stack c(nl); set lhs b(12): !**TOSTRING %if lhs_form=constant %and lhs_oper=0 %start tostring(lhs_disp); %return %finish load(lhs,any) op1(swab,lhs) op1(clrb,lhs); op1(inc,lhs) temp = 0 frame = (frame+1)&(\1) temp_base = lnb; temp_disp = frame; frame = frame+2 temp_type = integers; temp_form = v in s; temp_format = 2 op2(mov,lhs,temp) lhs = temp; lhs_type = string %return b(11): operate(swob); %return; !**SWAB b(8): operate(remy); %return; !**REM b(6): stack c(0); !**LENGTH b(7): set both; !**CHARNO lhs_flags = lhs_flags&(\indirect) lhs_type = byte; lhs_length = 1 array ref(0); %return b(3): l = 255; !**STRING b(1): !**INTEGERS b(2): !**REAL b(4): !**RECORDS b(5): vmap(lhs); !**BYTE lhs_format = 0 lhs_length = l; lhs_type = t; %return b(0): amap(lhs); %return; !**ADDR b(9): !**READSYMBOL b(10): perm(freadch); !**READCH claim(r1); stack x(r1,0,v in r,0) assign(1); %return b(14): !**INT b(15): !**INTPT load(lhs,anyf) %if t=15 %start cword(addf&x'FFF0'+actual(lhs_base)<<6+k'37') cword(k'040000'); !+short %finish hazard(r1) fop(stcfi,lhs_base,vr(r1)) release(lhs_base) lhs_base = r1; lhs_type = integers %return %finish hazard all addr = v_disp %if v_base&128=0 %start; !PARAMETER stack s(v); pop lhs; lhs_form = v in s amap(lhs); lrd(lhs,r2); perm(11) %finish %else %start l = v_base-128-16 local use = local use!(1<=0 cword(jsr+k'737') pdump(v_reloc,addr) %finish forget everything drop(v) %if v_type=0; !NOT A FN OR MAP %end %routine for %record (stackfm) %name cv,iv,inc,fv %record (forfm) %name f %integer lab,type %routine stab(%record(stackfm)%name v) !NOTIMP80 %recordspec V(STACKFM) %integer t %record (stackfm) w %return %if const(v)#0 %if v_type=byte %then load(v,any) %else address(v,0) t = (frame+1)&(\1); frame = t+2 w = 0 w_base = lnb; w_disp = t; w_type = integers; w_form = v in s op2(mov,v,w) v = w %end stp = stp-4 cv == stacked(stp+1)_v inc == stacked(stp+2)_v fv == stacked(stp+3)_v iv == stacked(stp+4)_v lab = tag stab(inc); stab(fv) %if cv_form#v in s %or (cv_base#0 %and cv_base#local) %start type = cv_type amap(cv); stab(cv) cv_type = type; cv_form = a in s; cv_base = local %finish stack s(cv); stack s(iv); stack s(inc) operate(sub); assign(1); !CV = IV-INC forp = forp+1; abort(18) %if forp>max for f == forinf(forp) f_label = forlab; forlab = lab f_cdisp = cv_disp; f_ldisp = fv_disp f_reloc = cv_reloc; f_flags = 0 f_flags = f_flags!1 %if cv_base=local f_flags = f_flags!2 %if cv_form=v in s f_flags = f_flags!4 %if cv_type=byte f_flags = f_flags!8 %if const(fv)#0 %if f_flags&8#0 %and const(inc)#0 %and const(iv)#0 %and %c fv_disp#cv_disp+inc_disp %start f_flags = f_flags!16 %finish %else %start jump to(lab+2,jump,redefine) %finish define label(lab) stack s(cv); stack s(cv); stack s(inc) operate(add); assign(1); !CV = CV+INC drop(cv); drop(iv); drop(inc); drop(fv) %end %routine resolve(%integer flag) ! s -> a.(b).c %routine pop push pop lhs; push(lhs); drop(lhs) %end stack c(0) %if flag&1=0 pop push pop push stack c(0) %if flag&2=0 pop push pop push perm(resolution) perm(resflop) %if flag&4=0 %end !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: next: readch(sym); ->c(sym) c('l'):j = tag; ->next c('O'):abort(13) %if stp#0 abort(20) %unless addr(using_link)=addr(null d) abort(22) %if active regs#0 display use %if diag&16#0 current line = tag stemp = 0 ->next c('$'):define var; ->next %routine adump %integer j %if owntype=integers %start gword(ownval) %finish %else %start; %if owntype=byte %start gbyte(ownval) %finish %else %start; %if owntype=string %start dump string(data size) %finish %else %start %cycle j = data size>>1-1,-1,0 gword(0) %repeat %finish; %finish; %finish %end c('A'):aparm = tag text = "" %and stack c(0) %if stp=0; !default value pop drop; own val = lhs_disp %if ownflags&array bit#0 %start %cycle j = aparm-1,-1,0 adump %repeat %finish %else %start %if otype<0 %start decvar_disp = ownval decvar_reloc = 0 decvar_form = v in s %finish %else %start abort(0) %if lhs_form#constant %and (owntype#string %or %c lhs_length=0) decvar_disp = ga adump %finish %finish ->next c('b'):pop drop; vub = lhs_disp pop drop; vlb = lhs_disp ->next c('d'):dim = tag !EMAS: SKIPSYMBOL fptr = fptr+1 n = tag frame = (frame+round)&(\round) %if parameter list=0 %then names = names-n %else parms = parms+n %if dim>1 %start abort(0) %if parameter list#0 stp = 0 %cycle j = 1,1,dim op1(clr,to ds); !JUST FOR SPACE stp = stp+2 set both push(lhs); drop(lhs) push(rhs); drop(rhs) %repeat stp = 0 perm(set dope) cword(dim); cword(data size) %while n>0 %cycle n = n-1; names = names+1; decvar == var(names) decvar_form = a in s decvar_disp = frame; decvar_base = local perm(multi dec) cword(k'010264'); cword(frame); !mov_r2,frame(lnb) frame = frame+2 %repeat ->next %finish set both %if const(lhs)#0 %and const(rhs)#0 %start vlb = lhs_disp; vub = rhs_disp abort(23) %if vub0 %cycle n = n-1 %if parameter list=0 %start names = names+1; decvar == var(names) %finish %else %start parms = parms-1; decvar == var(parms) %finish decvar_disp = frame-vlb; frame = frame+k %repeat %finish %else %start lrd(lhs,r2); lrd(rhs,r3) perm(12); cword(data size) %while n>0 %cycle n = n-1; names = names+1; decvar == var(names) decvar_form = ains; !ARRAYNAME decvar_disp = frame cword(k'010564'); cword(frame); !*MOV DS,(FRAME) cword(k'060164'); cword(frame); !*ADD R1,(FRAME) cword(k'060005'); !*ADD R0, DS frame = frame+2 %repeat %finish stp = stp-2 ->next c('N'): !EMAS: STACK C(TAG) j = (halfinteger(fptr)<<16)!halfinteger(fptr+2); !EMAS fptr = fptr+4; !EMAS: stack c(j); !EMAS: ->next c('G'):get string(alias); ->next c(''''):get string(text); ->next c('n'):len = tag; set lhs j = -lhs_format j = integer(addr(var(j)_free))-len stack v(var(j)) set both; stp = stp-1 %if lhs_form=v in s %or lhs_form=v in rec %start rhs_disp = rhs_disp+lhs_disp lhs_form = lhs_form-v in s+rhs_form %finish %else %start; %if lhs_form=a in rec %start lhs_form = v in rec; lhs_type = integers load(lhs,any) lhs_form = rhs_form %finish %else %start; %if lhs_form<=v in r %start lhs_form = rhs_form %finish %else %start lhs_extra = lhs_disp lhs_form = rhs_form+rec mod %finish; %finish; %finish lhs_disp = rhs_disp lhs_type = rhs_type lhs_format = rhs_format lhs_flags = rhs_flags lhs_length = rhs_length drop(rhs) ->next c('@'):v == var(tag) %if v_type&128#0 %start; !SPEC NEEDED v_type = v_type-128 show used(v_reloc>>4) %finish stack v(v) ->next c('='):opr = 1; ->cond c('#'):opr = 2; ->cond c('>'):opr = 3; ->cond c('<'):opr = 5; ->cond c(')'):opr = 4; ->cond c('('):opr = 6; ->cond c('t'):opr = 7; ->cond c('k'):opr = 8; ->cond cond: jump to(tag,opr+invert+unsigned,redefine) invert = 0; ->next c('C'):set both; amap(lhs); amap(rhs) c('?'):set both; compare(lhs,rhs) drop(rhs); drop(lhs); stp = stp-2; ->next c('"'):set both; compare(lhs,rhs) lhs = rhs %if swopped=0 stp = stp-1; drop(rhs); swopped = 0 claim(lhs_base); ->next c('a'):array ref(0); ->next c('i'):array ref(1); ->next c('.'):operate(conc); ->next c('+'):operate(add); ->next c('-'):operate(sub); ->next c('&'):operate(and); ->next c('!'):operate(or); ->next c('%'):operate(xor); ->next c('['):operate(lsh); ->next c(']'):operate(rsh); ->next c('*'):operate(mul); ->next c('/'):operate(div); ->next c('U'):operate(neg); ->next c('\'):operate(not); ->next c('X'):operate(exp); ->next c('Q'):set both; load(lhs,anyf) operate(div) ->next c('v'):set lhs address(lhs,0) %if lhs_type=real %start load(lhs,anyf) op1(absf,lhs) %finish %else %start test zero(lhs); claim(lhs_base) cword(k'002001'); !BGE .+2 cword(k'005400'+lhs_base-1); !NEG REG cc ca = ca; !CC KNOWN HERE %finish ->next c(117): !++ c(113): !-- set both j = lhs_type amap(lhs) stack c(lhs_length); operate(mul) %if sym=117 %then operate(add) %else operate(sub) vmap(lhs) lhs_type = j ->next c('j'):assign(2); ->next c('S'):assign(1); ->next c('Z'):assign(0); ->next c('p'):assign(-1); ->next c('E'):pop lhs; load params(lhs_link) x == lhs; call(x) %if x_type#0 %and sym#0 %start; !FN OR MAP claim(r1) lhs == record(descriptor) lhs_base = r1 lhs_form = v in r; lhs_form = v in s %if x_type&16#0 lhs_type = x_type&15 lhs_base = f1 %if lhs_type=real lhs_format = x_format drop(x) %if lhs_form=v in r %and (lhs_type=string %or lhs_type=records) %start !S/R FN lhs_form = v in s !EMAS: N = NEXTSYMBOL n = byteinteger(fptr); !EMAS %if n#'S' %and n#'j' %start j = temp string(lhs_length) lhs_base = local; lhs_disp = j; lhs_flags = in temp stack s(lhs) stack x(r1,0,v in s,0) rhs_type = lhs_type; rhs_format = lhs_format assign(1) %finish %finish %finish ->next c('M'): c('V'):pop lhs amap(lhs) %if sym='M' %if gvar_type=real %then lrd(lhs,f1) %else lrd(lhs,r1) c('R'):return; ->next c('T'):cword(true); return; ->next c('K'):cword(false); return; ->next c('B'):val = tag; n = jump %if val=for lab %start fr == forinf(forp); forp = forp-1 forlab = fr_label define label(val+2) %if fr_flags&16=0 stack x(lnb,fr_cdisp,v in s,0); !CONTROL rhs_base = 0 %if fr_flags&1=0 rhs_form = a in s %if fr_flags&2=0 rhs_reloc = fr_reloc rhs_type = byte %if fr_flags&4#0 stack x(lnb,fr_ldisp,v in s,0) rhs_base = 0 %and rhs_form = constant %if fr_flags&8#0 set both compare(lhs,rhs) drop(rhs); drop(lhs); stp = stp-2 n = 2; !NOT EQUAL %finish jump to(val,n,define); ->next c('F'):jump to(tag,jump,redefine); ->next c(':'):define label(tag); ->next c('J'):k = tag jump to(-k,jump,define); ->set jump c('L'):k = tag define label(-k) set jump: names = k %if k>names ->next c('f'):for; ->next c('r'):resolve(tag); ->next c('_'):v == var(tag); pop drop k = new tag; define tag(-k) gpatch(k,integer(addr(v_free))+lhs_disp*2) forget everything; ->next c('W'):v == var(tag) stack c(1); operate(lsh) pop lhs %if const(lhs)#0 %start lhs_disp = lhs_disp+integer(addr(v_free)) %finish %else %start load(lhs,any) lhs_disp = integer(addr(v_free)) %finish drop(lhs) lhs_form = a in s; lhs_reloc = mod gla bit op1(jmp,lhs) uncond jump = ca ->next c('m'):j = -1; ->ce c('s'):j = 0; ->ce c('e'):j = tag ce: stack c(0) %while stp<2 pop lhs; lrd(lhs,r2) pop lhs; lrd(lhs,r1) cload(j,r0) perm(signal) uncond jump = ca; ->next c('o'):events = tag; !EVENTS TRAPPED frame = (frame+1)&(\1) cword(k'010564'); cword(frame) local use = local use!(1<<(local use-16)); ! FIX !EMAS: SKIPSYMBOL fptr = fptr+1 k = tag; !FINISH LABEL jump to(k,jump,1); evfrom = jtag; !SKIP EVENT BODY j = new tag; define tag(-j); evep = dtag; !ENTRY POINT cword(k'016405'); cword(frame) frame = frame+2 forget everything ->next c('w'):machine code forget everything ->next c('P'): pop drop cword(lhs_disp) forget everything ->next c('y'):k = tag diag = k&x'3FFF' %if k>>14=2 ->next c('z'):k = tag; n = k>>12; k = k&x'FFF' %if n=0 %start control = k %finish %else %start; %if n=1 %start use limit = k %finish %else %start; %if n=2 %start max envirs = k %finish %else %start; %if n=3 %start array opt = k %finish %else %start; %if n=4 %start %finish; %finish; %finish; %finish; %finish ->next c('H'):decvar == begin; decvar_disp = new tag potype = 1; spec = 0 external name = "$GO" %if level#16 %start stack c(decvar_disp); pop lhs potype = 0; lhs_type = 0 lhs_reloc = label code lhs_base = level!128 call(lhs) %finish assemble(0,labs,names,level+1); ->next c('~'):readch(sym) %if sym='A' %start; !ALT START decvar == gvar assemble(-2,labs,names,level+1) aligned = alt aligned ->next %finish %if sym='B' %start; !ALT END ->out %finish %if sym='D' %start; ! START OF INCLUDE FILE readch(j) fptr = fptr+j; ! SKIP FILE NAME ->next %finish %if sym='E' %then ->next; ! END OF INCLUDE FILE abort(0) %unless sym='C' max frame = frame %if frame>max frame frame = frame base ->next c('{'):parameter list = -1 assemble(gtype,labs,names,level+1) ->next c('}'):parameter list = 0 ->out %if amode<0 frame = (frame+1)&(\1) new frame = (level-16)*2; !LEAVING SPACE FOR DISPLAY special = 0 %if names>gstart %start %if decvar_type=string %and decvar_form=v in s %start frame = (decvar_disp+1)&(\1) %finish special = 1 special = 0 %if names-gstart>2 integer(addr(gvar_free)) = parms %cycle j = gstart+1,1,names ap == var(j) parms = parms-1; fp == var(parms) fp = ap ap_disp = ap_disp-frame fp_base = ds; fp_disp = 0 special = 0 %if fp_form&indirect=0 %and fp_type#integers %and %c fp_type#byte special = 0 %if fp_type=general %or fp_form&procedure#0 %repeat abort(15) %if parms<=names %if fp_type=string %and fp_form=v in s %start; !FINAL STRING fp_base = param; fp_disp = r1 %if amode=0 %start; !PREPARE FOR ASSIGNMENT ap_disp = new frame; new frame = new frame+((ap_format+1)&(\1)) stack v(ap) stack x(r1,0,v in s,0); rhs_type = string claim(r1) assign(1) %finish %finish %finish %if special#0 %start special = 0 n = r0 %cycle j = parms,1,integer(addr(gvar_free))-1 fp == var(j) %continue %if fp_type=15 fp_base = param; fp_disp = n %if amode=0 %start stack v(fp); pop drop lhs_base = lnb; lhs_disp = -(n-r0+1)*2 %if lhs_form#v in s %start lhs_type = integers; lhs_form = v in s %finish remember(n,lhs) %finish special = special+1 n = n+1 %repeat %finish %else special = frame<<2 ->out %if amode#0; !-> IF SPEC frame = new frame ->next c(';'):return %if level#16 forget everything gfix out: %if amode=0 %start selectoutput(direct); printch(procedure end) put(ca); put((frame+1)&(\1)); put(events) put(local use); put(special) selectoutput(object); printch(procedure end) put(events); put(evep); put(evfrom) %finish %else %start %if amode<0 %start %if aligned=0 %and xframe#0 %start %while alt pt#parms %cycle alt pt = alt pt-1 v == var(alt pt) v_disp = v_disp-1 %repeat max frame = max frame-1 frame = frame-1 %finish frame = max frame %if max frame>frame %if amode=-1 %start frame = (frame+1)&(\1) %if aligned#0 gvar_format = frame gvar_base = aligned %finish %else %start old frame = frame %finish alt aligned = aligned!alt aligned %finish %finish frame = old frame; ca = old ca; uncond jump = old jump local = old local %end; !OF ASSEMBLE fptr = comreg(46); !EMAS: fptrinit = fptr fend = fptr+integer(fptr); !EMAS fptr = fptr+32; !EMAS: ! !EMAS: SELECTINPUT(ICODE); selectoutput(object) var(0) = 0 assemble(0,0,0,16); printch('*') selectoutput(direct); put((ga+1)&(\1)) %end %end %of %file