!#if e(=true) !#else(=false) {#report ASS11 - DEIMOS version} !#fi {############################################} {# PDP11 I-code Assembler for IMP77 #} {# #} {# Copyright November 1981 #} {# Peter S. Robertson #} {# All rights reserved #} {# #} {############################################} %Constinteger McOps = 118 %constinteger Absf = 1, Adc = 2, Adcb = 3, Add = 4, Addf = 5, Ash = 6, Ashc = 7, Asl = 8, Aslb = 9, Asr = 10, Asrb = 11, Bcc = 12, Bcs = 13, Beq = 14, Bge = 15, Bgt = 16, Bhi = 17, Bhis = 18, Bic = 19, Bicb = 20, Bis = 21, Bisb = 22, Bit = 23, Bitb = 24, Ble = 25, Blo = 26, Blos = 27, Blt = 28, Bmi = 29, Bne = 30, Bpl = 31, Bpt = 32, Br = 33, Bvc = 34, Bvs = 35, Ccc = 36, Cfcc = 37, Clc = 38, Cln = 39, Clr = 40 %constinteger Clrb = 41, Clrf = 42, Clv = 43, Clz = 44, Cmp = 45, Cmpb = 46, Cmpf = 47, Com = 48, Comb = 49, Dec = 50, Decb = 51, Div = 52, Divf = 53, Emt = 54, Fadd = 55, Fdiv = 56, Fmul = 57, Fsub = 58, Halt = 59, Inc = 60, Incb = 61, Iot = 62, Jmp = 63, Jsr = 64, Ldb = 65, Ldcfd = 66, Ldcif = 67, Ldf = 68, Ldfps = 69, Mfpd = 70, Mfpi = 71, Modf = 72, Mov = 73, Movb = 74, Mtpd = 75, Mtpi = 76, Mul = 77, Mulf = 78, Neg = 79, Negb = 80 %constinteger Negf = 81, Nop = 82, Reset = 83, Rol = 84, Rolb = 85, Ror = 86, Rorb = 87, Rti = 88, Rts = 89, Rtt = 90, Sbc = 91, Sbcb = 92, Scc = 93, Sec = 94, Sen = 95, Setd = 96, Setf = 97, Seti = 98, Setl = 99, Sev =100, Sez =101, Sob =102, Spl =103, Stcfd =104, Stcfi =105, Stf =106, Stfps =107, Stst =108, Sub =109, Subf =110, Swab =111, Sxt =112, Trap =113, Tst =114, Tstb =115, Tstf =116, Wait =117, Xor =118 %constintegerarray Optable(1:McOps) = %c 8_170600, {absf} 8_005500, {adc} 8_105500, {adcb} 8_060000, {add} 8_172000, {addf} 8_072000, {ash} 8_073000, {ashc} 8_006300, {asl} 8_106300, {aslb} 8_006200, {asr} 8_106200, {asrb} 8_103000, {bcc} 8_103400, {bcs} 8_001400, {beq} 8_002000, {bge} 8_003000, {bgt} 8_101000, {bhi} 8_103000, {bhis} 8_040000, {bic} 8_140000, {bicb} 8_050000, {bis} 8_150000, {bisb} 8_030000, {bit} 8_130000, {bitb} 8_003400, {ble} 8_103400, {blo} 8_101400, {blos} 8_002400, {blt} 8_100400, {bmi} 8_001000, {bne} 8_100000, {bpl} 8_000003, {bpt} 8_000400, {br} 8_102000, {bvc} 8_102400, {bvs} 8_000257, {ccc} 8_170000, {cfcc} 8_000241, {clc} 8_000250, {cln} 8_005000, {clr} 8_105000, {clrb} 8_170400, {clrf} 8_000242, {clv} 8_000244, {clz} 8_020000, {cmp} 8_120000, {cmpb} 8_173400, {cmpf} 8_005100, {com} 8_105100, {comb} 8_005300, {dec} 8_105300, {decb} 8_071000, {div} 8_174400, {divf} 8_104000, {emt} 8_075000, {fadd} 8_075030, {fdiv} 8_075020, {fmul} 8_075010, {fsub} 8_000000, {halt} 8_005200, {inc} 8_105200, {incb} 8_000004, {iot} 8_000100, {jmp} 8_004000, {jsr} 8_000000, {ldb} 8_177400, {ldcfd} 8_177000, {ldcif} 8_172400, {ldf} 8_170100, {ldfps} 8_106500, {mfpd} 8_006500, {mfpi} 8_171400, {modf} 8_010000, {mov} 8_110000, {movb} 8_106600, {mtpd} 8_006600, {mtpi} 8_070000, {mul} 8_171000, {mulf} 8_005400, {neg} 8_105400, {negb} 8_170700, {negf} 8_000240, {nop} 8_000005, {reset} 8_006100, {rol} 8_106100, {rolb} 8_006000, {ror} 8_106000, {rorb} 8_000002, {rti} 8_000200, {rts} 8_000006, {rtt} 8_005600, {sbc} 8_105600, {sbcb} 8_000277, {scc} 8_000261, {sec} 8_000270, {sen} 8_170011, {setd} 8_170001, {setf} 8_170002, {seti} 8_170012, {setl} 8_000262, {sev} 8_000264, {sez} 8_077000, {sob} 8_000230, {spl} 8_176000, {stcfd} 8_175400, {stcfi} 8_174000, {stf} 8_170200, {stfps} 8_170300, {stst} 8_160000, {sub} 8_173000, {subf} 8_000300, {swab} 8_006700, {sxt} 8_104400, {trap} 8_005700, {tst} 8_105700, {tstb} 8_170500, {tstf} 8_000001, {wait} 8_074000 {xor} %Constbytearray OpType(1:McOps) = %c 2_01000001, {absf} 2_00010000, {adc} 2_00010000, {adcb} 2_00100001, {add} 2_01000100, {addf} 2_00110100, {ash} 2_00110100, {ashc} 2_00010000, {asl} 2_00010000, {aslb} 2_00010000, {asr} 2_00010000, {asrb} 2_00000000, {bcc} 2_00000000, {bcs} 2_00000000, {beq} 2_00000000, {bge} 2_00000000, {bgt} 2_00000000, {bhi} 2_00000000, {bhis} 2_00100001, {bic} 2_00100001, {bicb} 2_00100001, {bis} 2_00100001, {bisb} 2_00100101, {bit} 2_00100101, {bitb} 2_00000000, {ble} 2_00000000, {blo} 2_00000000, {blos} 2_00000000, {blt} 2_00000000, {bmi} 2_00000000, {bne} 2_00000000, {bpl} 2_00000000, {bpt} 2_00000000, {br} 2_00000000, {bvc} 2_00000000, {bvs} 2_00000000, {ccc} 2_00000000, {cfcc} 2_00000000, {clc} 2_00000000, {cln} 2_00010000, {clr} 2_00010000, {clrb} 2_01000001, {clrf} 2_00000000, {clv} 2_00000000, {clz} 2_00100101, {cmp} 2_00100101, {cmpb} 2_01000101, {cmpf} 2_00010000, {com} 2_00010000, {comb} 2_00010000, {dec} 2_00010000, {decb} 2_00110100, {div} 2_01000100, {divf} 2_00000000, {emt} 2_00000000, {fadd} 2_00000000, {fdiv} 2_00000000, {fmul} 2_00000000, {fsub} 2_00000000, {halt} 2_00010000, {inc} 2_00010000, {incb} 2_00000000, {iot} 2_00010000, {jmp} 2_00000000, {jsr} 2_10110100, {ldb} 2_11000100, {ldcfd} 2_11000100, {ldcif} 2_11000100, {ldf} 2_00000000, {ldfps} 2_00000000, {mfpd} 2_00000000, {mfpi} 2_01000100, {modf} 2_10100001, {mov} 2_10100001, {movb} 2_00000000, {mtpd} 2_00000000, {mtpi} 2_00110100, {mul} 2_01000100, {mulf} 2_00010000, {neg} 2_00010000, {negb} 2_01000001, {negf} 2_00000000, {nop} 2_00000000, {reset} 2_00010000, {rol} 2_00010000, {rolb} 2_00010000, {ror} 2_00010000, {rorb} 2_00000000, {rti} 2_00000000, {rts} 2_00000000, {rtt} 2_00010000, {sbc} 2_00010000, {sbcb} 2_00000000, {scc} 2_00000000, {sec} 2_00000000, {sen} 2_00000000, {setd} 2_00000000, {setf} 2_00000000, {seti} 2_00000000, {setl} 2_00000000, {sev} 2_00000000, {sez} 2_00111000, {sob} 2_00000000, {spl} 2_01000001, {stcfd} 2_01000001, {stcfi} 2_01000001, {stf} 2_00000000, {stfps} 2_00000000, {stst} 2_00100001, {sub} 2_01000100, {subf} 2_00010000, {swab} 2_00010000, {sxt} 2_00000000, {trap} 2_00010001, {tst} 2_00010001, {tstb} 2_01000101, {tstf} 2_00000000, {wait} 2_00110001 {xor} %Constintegerarray Val1(1:McOps) = %c 8_006223, 8_006303, 8_006303, 8_006304, 8_006304, 8_007250, 8_007250, 8_007254, 8_007254, 8_007262, 8_007262, 8_010243, 8_010263, 8_010361, 8_010445, 8_010464, 8_010511, 8_010511, 8_010543, 8_010543, 8_010563, 8_010563, 8_010564, 8_010564, 8_010705, 8_010717, 8_010717, 8_010724, 8_010751, 8_011005, 8_011114, 8_011124, 8_011140, 8_011403, 8_011423, 8_012243, 8_012403, 8_012703, 8_012716, 8_012722, 8_012722, 8_012722, 8_012726, 8_012732, 8_012760, 8_012760, 8_012760, 8_013055, 8_013055, 8_014343, 8_014343, 8_014566, 8_014566, 8_016764, 8_020144, 8_020311, 8_020765, 8_021265, 8_024154, 8_027003, 8_027003, 8_027064, 8_030760, 8_031262, 8_034302, 8_034303, 8_034303, 8_034306, 8_034306, 8_036420, 8_036420, 8_037044, 8_037066, 8_037066, 8_037320, 8_037320, 8_037354, 8_037354, 8_040347, 8_040347, 8_040347, 8_041060, 8_050363, 8_051054, 8_051054, 8_051062, 8_051062, 8_051311, 8_051323, 8_051324, 8_052203, 8_052203, 8_052243, 8_052343, 8_052356, 8_052364, 8_052364, 8_052364, 8_052364, 8_052366, 8_052372, 8_053042, 8_053114, 8_053303, 8_053303, 8_053306, 8_053306, 8_053323, 8_053342, 8_053342, 8_053441, 8_053524, 8_055201, 8_055264, 8_055264, 8_055264, 8_062151, 8_065062 %Constintegerarray Val2(1:McOps) = %c 8_004340, 8_002040, 8_004140, 8_002040, 8_004340, 8_002040, 8_004200, 8_002040, 8_004140, 8_002040, 8_004140, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_005200, 8_002040, 8_004140, 8_002040, 8_004140, 8_002040, 8_004140, 8_002040, 8_002040, 8_005200, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_002040, 8_004200, 8_002040, 8_002040, 8_002040, 8_004140, 8_004340, 8_002040, 8_002040, 8_002040, 8_004140, 8_004340, 8_002040, 8_004140, 8_002040, 8_004140, 8_002040, 8_004340, 8_002040, 8_004240, 8_005340, 8_004640, 8_004140, 8_005240, 8_002040, 8_004140, 8_002040, 8_002040, 8_002040, 8_002040, 8_004404, 8_004546, 8_002040, 8_005123, 8_004240, 8_004500, 8_004340, 8_002040, 8_004140, 8_004240, 8_004500, 8_002040, 8_004340, 8_002040, 8_004140, 8_004340, 8_002040, 8_004364, 8_002040, 8_004140, 8_002040, 8_004140, 8_002040, 8_002040, 8_002040, 8_002040, 8_004140, 8_002040, 8_002040, 8_002040, 8_004240, 8_004340, 8_004500, 8_004640, 8_002040, 8_002040, 8_002040, 8_002040, 8_004404, 8_004411, 8_002040, 8_005123, 8_005240, 8_002040, 8_004340, 8_004140, 8_002040, 8_005040, 8_002040, 8_004140, 8_004340, 8_005240, 8_002040 %Constbytearray Mc Type(1:McOps) = 1, 1, 1, 2, 3, 7, 7, 1, 1, 1, 1, 8, 8, 8, 8, 8, 8, 8, 2, 2, 2, 2, 2, 2, 8, 8, 8, 8, 8, 8, 8, 0, 136, 8, 8, 0, 0, 0, 0, 1, 1, 1, 0, 0, 2, 2, 3, 1, 1, 1, 1, 7, 3, 5, 9, 9, 9, 9, 128, 1, 1, 0, 129, 7, 0, 3, 3, 3, 1, 1, 1, 3, 2, 2, 1, 1, 7, 3, 1, 1, 3, 0, 0, 1, 1, 1, 1, 128, 137, 128, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 9, 3, 3, 3, 1, 1, 2, 3, 1, 1, 5, 1, 1, 1, 0, 7 %constinteger Op Mask = 2_0 000 00 11, Type Mask = 2_0 111 00 00, ToReg = 2_1 000 00 00, Zero Instruction = 0<<4, {zero operands} Single Instruction = 1<<4, {one operand} Double Instruction = 2<<4, {two operands} Register Instruction = 3<<4, {register+operand} Floating Instruction = 4<<4 {floating register+operand} {User control options} %constinteger Trusted = 1<< 0, No Eis = 1<< 8, Stack Check = 1<< 9, Profiling = 1<<10, Check Jumps = 1<<11 !#if e(=true) %constinteger Max Stack = 50, Max Vars = 1000, Max Stack Items = 40, Max Knowing = 60, Max Fors = 8, Max Label = 50, Max Nesting = 8 !#else(=false) {} { %constinteger Max Stack = 50,} { Max Vars = 500,} { Max Stack Items = 40,} { Max Knowing = 60,} { Max Fors = 8,} { Max Label = 50,} { Max Nesting = 8} {} {%constrecord(*)%name Null == 0} {%externalroutinespec Print ch %alias "PRINTSYMBOL" (%integer i)} !#fi {Monitoring control bits} %constinteger MonCode = 1<<0, MonStack = 1<<1, MonReg = 1<<2, MonOperand = 1<<3, MonOperate = 1<<4, MonMove = 1<<5, MonLine = 1<<6, MonOpt = 1<<7, MonCond = 1<<8 %begin %constinteger Word Length = 2, {in bytes} Alignment = Word Length-1 !#if e(=true) %dynamicroutinespec Decode11(%integer Ca, Op, R, Sp) %externalstring%fnspec ItoS %alias "S#ITOS" (%integer N); !THE CONLIB SPEC !#fi %routine Print Octal(%integer N) %integer j Printch((N>>J)&7+'0') %for J = 15,-3,0 %end %constinteger R0 = 1, R1 = 2, R2 = 3, R3 = 4, {work registers} LNB = 5, DS = 6, SP = 7, PC = 8, {dedicated regs} AnyG = 9, {any of R0-R3} F0 = 10, F1 = 11, F2 = 12, F3 = 13, {floating regs} AnyF = 14, {any of F0-F3} Cc Lhs = 15, {condition code} Cc Rhs = 16, Iresult = R2 {fn/map result} %constbytearray Actual(0:AnyF) = 0, 0, 1, 2, 3, 4, 5, 6, 7, 255, 0, 1, 2, 3, 255 %conststring(3)%array RegId(0:CcRhs) = "", "R0 ", "R1 ", "R2 ", "R3 ", "LNB", "DS", "SP ", "PC ", "R* ", "F0 ", "F1 ", "F2 ", "F3 ", "F* ", "CCl", "CCr" %constinteger VinR = 0, { Value = Base+Disp } VinS = 1, { Value = Loc(Base+Disp) } Ainc = 2, { Value = (Base)+ } Adec = 3, { Value = -(Base) } VinX = 4, { Value = Loc(Loc(Base+Extra)+Disp) } AinX = 5, { Value = Loc(Loc(Loc(Base+Extra)+Disp)) } Proc = 6 { Procedure, no value } %conststring(4)%array FormId(VinR:Proc) = "VinR", "VinS", "()+", "-()", "VinX", "AinX", "Proc" %constinteger Undefined = 0, Integers = 1, {2-byte integers} Bytes = 2, {1-byte unsigned} Reals = 3, {4-byte real} Lreals = 4, {8-byte real} Strings = 5, {unsigned byte + data bytes} Records = 6, {word-aligned for now} Generals = 7, {general type - 3 words} Labels = 8, Alhs = 9 %conststring(7)%array TypeId(Undefined:Alhs) = %c "Unknown", "Integer", "Byte ", "Real ", "Lreal ", "String ", "Record ", "General", "Label ", "Alhs " %constbytearray Type Code(Undefined:Labels) = 0,1,5,2,8,3,4,0,10 %constbytearray Clear op(Integers:Lreals) = Clr, Clrb, Clrf, Clrf %constbytearray Move op(Integers:Lreals) = Mov, Movb, Ldf, Ldf %recordformat Opfm(%integer More, Extra, Modereg) %recordformat Varfm(%byte Type, Form, Base, Flags, %integer Disp, Area, Extra, (%integer Format %or %integer Scale)) %recordformat Datafm(%record(Varfm) V, (%integer Bias %or %integer Dope %c %or %byte Reg, Label), %integer Oper, %record(Varfm) A, %record(Datafm)%name Link) {Note: Link should be Stackfm but IMP80 refuses to allow the} { necessary recordformatspec - how convenient!} %recordformat Stackfm( %c ( ( %record(Varfm) V %c %or %byte Type, Form, Base, Flags, %integer Disp, Area, Extra, ( %integer Format %c %or %integer Scale )), ( %integer Bias %c %or %integer Dope %c %or %byte Reg, Label), %integer Oper, %record(Varfm) A, %record(Stackfm)%name Link %c %or %record(Datafm) Data), %record(Stackfm)%name Using, Stack, Params, ( %integer Preg %c %or %integer Cc Ca)) {*------*} {| Dope |} {*---*------*------*---*------*-------*-------*--------*------*} {| V | Bias | Oper | A | Link | Using | Stack | Params | Preg |} {*---*------*------*---*------*-------*-------*--------*------*} {| D A T A | | CcCa |} {*----------------------------* *------*} !#if e(=true) %constrecord(Stackfm)%name Null = 0 !#fi %ownrecord(Stackfm) Cc1, Cc2 %recordformat EnvFm(%record(Datafm)%name E) %recordformat Forfm(%byte Label, Entry, Reg, %record(Datafm) Control, Final) %record(Forfm)%array Fors(0:Max Fors) %owninteger ForP = 0 %ownrecord(Stackfm)%name Stack %record(Stackfm)%array Stack Item(0:Max Stack Items) %ownrecord(Stackfm)%name Using, Dasl %recordformat Realfm(%longreal R %or %integer W1, W2, W3, W4) %ownrecord(Realfm) Real Value = 0 %owninteger Integer Value = 0 %ownstring(255) String Value = "" {Flag bits} %constinteger In Work = 1<<0, Array = 1<<1, Simple P = 1<<1, Parameter = 1<<2, Indirect = 1<<3, Answer = 1<<4, Hazarded = 1<<4, Awanted = 1<<4, Primitive = 1<<5, Static = 1<<5, Xproc = 1<<6, Arrayname = 1<<6, Closed = 1<<7, Safe Byte = 1<<7 {Operand modes} %constinteger Reg = 0<<3, Defer = 1<<3, AutoI = 2<<3, Immediate = AutoI+7, AutoI Defer = 3<<3, Absolute = AutoI Defer+7, AutoD = 4<<3, AutoD Defer = 5<<3, Index = 6<<3, Relative = Index+7, Index Defer = 7<<3, Relative Defer = Index Defer+7 {Internal operations} %constinteger Real Shift = 14 %constinteger NOTx = 1, {Integer operations} NEGx = 2, ADDx = 3, SUBx = 4, MULx = 5, DIVx = 6, EXPx = 7, ANDx = 8, ORx = 9, XORx = 10, BICx = 11, LSHx = 12, RSHx = 13, REMx = 14, CONCx = 15, RNEGx = NEGx+Real Shift, {floating-point operations} RADDx = ADDx+Real Shift, RSUBx = SUBx+Real Shift, RMULx = MULx+Real Shift, RDIVx = DIVx+Real Shift, REXPx = EXPx+Real Shift %conststring(4)%array OperId(NOTx:REXPx) = %c "not ", "neg ", "add ", "sub ", "mul ", "div ", "exp ", "and ", "or ", "xor ", "bic ", "lsh ", "rsh ", "rem ", "conc", "negr", "addr", "subr", "mulr", "divr", "expr" {Oper flags} %constinteger Commutative = 1<<0, InPrim = 1<<1, Easy = 1<<2, Selfop = 1<<3, Byteself = 1<<4, Unary = 1<<5, Incdec = 1<<6, No Assoc = 1<<7, Weak Assoc = 1<<8, Assoc Mask = No Assoc!Weak Assoc, Nullop = 1<<9 %ownintegerarray Oper Flags(NOTx:REXPx) = {altered by %Control} {NOTx} Unary!Easy!Selfop!ByteSelf, {NEGx} Unary!Easy!Selfop!ByteSelf, {ADDx} Commutative!Easy!Selfop!Byteself!Nullop!Incdec, {SUBx} Easy!Selfop!Byteself!Nullop!Incdec, {MULx} Commutative!Weak Assoc!Nullop, {DIVx} Weak Assoc!Nullop, {EXPx} InPrim!No Assoc!Nullop, {ANDx} Weak Assoc!Nullop!Selfop!Byteself!Commutative, {ORx} Weak Assoc!Nullop!Selfop!Byteself!Easy!Commutative, {XORx} Weak Assoc!Nullop!Selfop!Commutative, {BICx} Weak Assoc!Nullop!Selfop!Byteself!Easy, {LSHx} No Assoc!Nullop!Selfop!Byteself, {RSHx} No Assoc!Nullop!Selfop!Byteself, {REMx} No Assoc, {CONCx} No Assoc, {RNEGx} No Assoc!Unary!Selfop, {RADDx} No Assoc!Commutative, {RSUBx} No Assoc, {RMULx} No Assoc!Commutative, {RDIVx} No Assoc, {REXPx} No Assoc!Inprim %constintegerarray Null Value(ADDx:RSHx) = %c 0, {ADDx} 0, {SUBx} 1, {MULx} 1, {DIVx} 1, {EXPx} x'FFFF', {ANDx} 0, {ORx} 0, {XORx} 0, {BICx} 0, {LSHx} 0 {RSHx} %constbytearray Inc op(ADDx<<1+Integers:SUBx<<1+Bytes) = Inc, Incb, Dec, Decb %constbytearray Operation(NOTx<<1+Integers:REMx<<1+Bytes) = %c Com, Comb, {NOTx} Neg, Negb, {NEGx} Add, 0, {ADDx} Sub, 0, {SUBx} 0, 0, {MULx} 0, 0, {DIVx} 0, 0, {EXPx} Bic, Bicb, {ANDx} Bis, Bisb, {ORx} 0, 0, {XORx} Bic, Bicb, {BICx} 0, 0, {LSHx} 0, 0, {RSHx} 0, 0 {REMx} %constbytearray Fop(RADDx:RDIVx) = Addf, Subf, Mulf, Divf %constbytearray Unary op(NOTx<<1+Integers: NEGx<<1+Bytes) = Com, Comb, Neg, Negb {Condition codes} %constinteger EQ = 1, LT = 2, GT = 4, TT = 8, Always = 7, NE = 6, LE = 3, GE = 5, FF = 9 %constbytearray Reverse(EQ:FF) = EQ {EQ}, GT {LT}, GE {LE}, LT {GT}, LE {GE}, NE {NE}, Always, TT {TT}, FF {FF} %constinteger Own = 1, EqualsEquals = 1, Con = 2, Equals = 0, External = 3, Jam = -1, System = 4, Dynamic = 5, Primrt = 6, Permrt = 7 {Procedure end codes} %constinteger Routine = 0, True = 1, False = 2, Fn = 3, Map = 4 {Perm routines} %constinteger Pr0 = 1<< 8, {preserves R0} Pr1 = 1<< 9, {preserves R1} Pr2 = 1<<10, {preserves R2} Pr3 = 1<<11, {preserves R3} Pall = Pr0+Pr1+Pr2+Pr3 {preserves all registers} %constinteger Signal = 1, {%signal} CheckSp = 2, {stack check} Aset = 3, {set array header} Sw Jump = 4, {switch jump} Intexp = 5, {integer exponentiation} RealExp = 6, {real exponentiation} Smove = 7+Pr2, {string move} Sconc = 8+Pr2, {string concatenation} Scomp = 9, {string comparison} Sjam1 = 10+Pr2, {string jam transfer, length known} Spmove = 11+Pr2, {string parameter move} Sres = 12, {string resolution} Pcall = 13, {procedure parameter entry} Adecl = 14, {1-dim array declaration} Aref = 15, {n-dim array reference} Multi Dec = 17, {n-dim array declaraion} Resflop = 18+Pall, {check for resolution fails} RtMonitor = 19, {invoke run-time monitor} Const Sig = 20, {cheap signal call} Eis Mul = 21, {software multiply} Eis Div = 22, {software divide} Eis Rem = 23, {software remainder} Sjam2 = 24+Pr2, {string jam transfer, length unknown} Getch = 25, {Readsymbol function} ShiftL = 26+Pr0+Pr3,{variable left shift} ShiftR = 27+Pr0+Pr3 {variable right shift} %conststring(9)%array PermId(Signal&255:ShiftR&255) = %c { 1} "P#SIGNAL", "P#CHECKSP", "P#ASET", { 4} "P#SWJUMP", "P#INTEXP", "P#REALEXP", { 7} "P#SMOVE", "P#SCONC", "P#SCOMP", {10} "P#SJAM1", "P#SPMOVE", "P#SRES", {13} "P#PCALL", "P#ADEC", "P#AREF", {16} "??????", "P#MULTI", "P#RESFLOP", {19} "P#MONITOR", "P#CONSIG", "P#EISMUL", {22} "P#EISDIV", "P#EISREM", "P#SJAM2", {25} "P#READCH", "P#SHIFTL", "P#SHIFTR" %ownintegerarray Perm Used(Signal&255:ShiftR&255) = 0(*) %constintegerarray Perm Op(NOTx:REXPx) = %c 0, {NOT} 0, {NEG} 0, {ADD} 0, {SUB} EisMul, {MUL} EisDiv, {DIV} IntExp, {EXP} 0, {AND} 0, {OR} 0, {XOR} 0, {BIC} ShiftL, {LSH} ShiftR, {RSH} EisRem, {REM} 0, {CONC} 0, {RNEG} 0, {RADD} 9, {RSUB} 0, {RMUL} 0, {RDIV} RealExp {REXP} {File data} !#if e(=true) %constinteger Obj = 2, Dir = 3, Icode = 1 !#else(=false) { %constinteger Obj = 1, Dir = 2, Icode = 1} !#fi {Object stream} {Directive stream} %constinteger Obj Select = 31, Dir Ujump = 1, Obj End = 33, Dir Cjump = 2, Obj Byte = 34, Dir Return = 4, Obj Dummy = 35, Dir Label = 5, Obj Call = 36, Dir Block = 6, Obj Switch = 37, Dir End = 7, Obj Jump = 38, Dir Spec = 8, Obj Return = 39, Obj Line = 40, Dir Notex = 10, Obj External = 42, Dir Xdef = 12, Obj PcRel = 43, Dir Ddef = 13, Obj Block = 44, Dir Mcused = 14, Obj Label = 45, Dir Section = 15, Obj Word = 46, Dir Entry1 = 16, Obj LNB1 = 47, Dir Entry2 = 17, Obj LNB2 = 48, Dir Slab = 18, Obj Branch = 49, Dir Switch = 19, Obj Sob = 50, {calculated from Obj Branch} Obj Modlab = 51, Dir Call = 20, Obj Entry1 = 52, Dir Prefix1 = 21, Obj Entry2 = 53, Dir Prefix2 = 22, Obj LNB10 = 54 {also 23,24,25} {Block attributes} %constinteger Attr R1 = 1<< 8, {has a parameter in R1} Attr R2 = 1<< 9, {has a parameter in R2} Attr Inner Uses = 1<<10, {locals are used as globals} Attr Uses Locals = 1<<11, {local stack frame is used} Attr Dynamic = 1<<12 {needs a consistent stack} {Instruction modification} %constinteger No Relocation = -1, Test Single = -Obj LNB1, Test Double = -Obj LNB2, Test One = -Obj LNB10 %constinteger Code Area = 0<<1+0, Constant Area = 1<<1+0, Own Area = 2<<1+0 %owninteger Uses Display = 0 %owninteger Own Base = 0, {current own area address} Constant Base = 0, {current constant area address} Current Area = Code Area, {currently selected area} External Spec, Event Count = 0 %ownintegerarray Frame Use(128:128+Max Nesting) = 0(*) %owninteger Fmark = 0 {Global Variables} %integer J %owninteger Code = 0, {current I-code symbol} Pending = 0, {next I-code symbol} Pending Tag = 0, {optimise 0<=N<=...} Language Flags = 0, Falign = 0, {worst internal alignment} Ds Bias = 0 {displacement of DS from true} %owninteger Invert = 0, Unsigned = 0, Free Label %constinteger Defined = x'8000', Label Mask = \Defined, Inverted = 1 %ownintegerarray Ilabel(1:Max Label) = Defined(*) %ownrecord(EnvFm)%array Env(1:Max Label) = 0(*) {should be a Namearray, IMP80 screws it up again} %ownrecord(Datafm) Kasl = 0 %ownrecord(Datafm)%name KTail, Knowing %ownintegerarray Ktimes(0:Cc Rhs) = 0(*) %record(Datafm)%array Known(0:Max Knowing) %owninteger Diag = 0, Control = 0 %ownintegerarray Used(0:Cc Rhs) = 0(*) %ownintegerarray Activity(0:Cc Rhs) = %c {0} -1, {R0} 0, {R1} 0, {R2} 0, {R3} 0, {LNB} -1, {DS} -1, {SP} -1, {PC} -1, {ANYG} -1, {F0} 0, {F1} 0, {F2} 0, {F3} 0, {ANYF} -1, {CCLHS} 0, {CCRHS} 0 %ownrecord(Stackfm)%array RegV(R0:AnyF) %owninteger Active Registers = 0 %ownstring(15) Alias = "", Internal Id = "", External Id = "", Section Id = "" %owninteger Decl Size, Vlb, Vub, Ostate, OwnType, OwnForm, OwnExtra, Constant Type, Init Flag = 0, FP Mode = Undefined %record(Varfm)%name DefV %record(Varfm)%array Var(0:Max Vars) %owninteger Parms %owninteger Section = 0 %routine Put(%integer N) Printch(N&255) Printch(N>>8) %end %routine Put Text(%string(*)%name S) %integer J, L L = Length(S) Printch(L) Printch(Charno(S, J)) %for J = 1,1,L %end %routine Ocode(%integer Item) Select Output(Obj) Printch(Item) %end %routine Dcode(%integer Item) Select Output(Dir) Printch(Item) %end !============================================================================== %routine Assemble(%record(Varfm)%name Avar, %integer Amode, Vars, Local, Parameter List) !============================================================================== {Amode = -16 - Initial call } { -2 - Alternate format start} { -1 - Recordformat } { 0 - Procedure } { >0 - Procedure spec } !============================================================================== {%predicate} %integerfnspec Const(%record(Stackfm)%name V) {%predicate} %integerfnspec Same(%record(Stackfm)%name A, B) {%predicate} %integerfnspec InReg(%record(Stackfm)%name V) {%predicate} %integerfnspec In Safe Reg(%record(Stackfm)%name V) {%predicate} %integerfnspec In Free Reg(%record(Stackfm)%name V) {%predicate} %integerfnspec Floating(%record(Stackfm)%name V) %integerfnspec Power(%integer N) %integerfnspec Gpr %integerfnspec Fpr %integerfnspec Item Size(%integer T) {%record(Stackfm)%map} %integerfnspec Register(%integer R) %routinespec Claim(%integer Register) %routinespec Release(%integer Register) %routinespec Release and Drop(%record(Stackfm)%name V) %routinespec Release and Clear(%record(Stackfm)%name V) %routinespec Hazard(%integer Register) %routinespec Forget(%integer Register) %routinespec Forget Destination(%record(Stackfm)%name V) %routinespec Forget Everything %routinespec Remember(%integer Register, %record(Stackfm)%name V) %routinespec Promote(%integer Reg) %routinespec Optimise(%record(Stackfm)%name V, %integer Mode) %routinespec Address(%record(Stackfm)%name V, %integer Mode) %routinespec Reduce(%record(Stackfm)%name V) %routinespec Amap(%record(Stackfm)%name V) %routinespec Vmap(%record(Stackfm)%name V, %integer Type) %routinespec Load(%record(Stackfm)%name V, %integer Register) %routinespec Loadup(%record(Stackfm)%name V) %routinespec Load Pair(%record(Stackfm)%name V1, V2) %routinespec Load Base(%record(Stackfm)%name V) %routinespec Move(%record(Stackfm)%name From, To) %routinespec Store(%record(Stackfm)%name L, R) %routinespec Operate(%integer Op, %record(Stackfm)%name L, R) %routinespec Array Access %routinespec Compare(%record(Stackfm)%name L, R) %integerfnspec Spare Register %routinespec Test Zero(%record(Stackfm)%name V) %routinespec Clear Vars(%integer Limit) %routinespec Dump External(%integer C, %record(Varfm)%name V) {%record(Stackfm)%map} %integerfnspec Descriptor {%record(Stackfm)%map} %integerfnspec Temporary %routinespec Drop(%record(Stackfm)%name V) {%record(Stackfm)%map} %integerfnspec Literal(%integer N) {%record(Stackfm)%map} %integerfnspec Copy(%record(Stackfm)%name V) %integerfnspec Tag %integerfnspec Four Bytes %routinespec Perm(%integer N) %routinespec Perm Operation(%integer Op, %record(Stackfm)%name A, B) %routinespec Plant(%integer Op, Reloc) %routinespec Plant0(%integer X) %routinespec Plant1(%integer X, %record(Stackfm)%name V1) %routinespec Plant2(%integer X, %record(Stackfm)%name V1, V2) %routinespec PlantR(%integer X, R, %record(Stackfm)%name V) %routinespec PlantF(%integer X, R, %record(Stackfm)%name V) %routinespec Set Real(%record(Stackfm)%name V) %routinespec Dump Real(%integer Type) %routinespec Dump Text(%integer Max) %routinespec Assign(%integer How) !============================================================================== %owninteger Frame = 0 %integer Current Line, Block Type, Code Base, Uncond Jump, Z Ca, Z Reg, D, N, Parameter Mode, VarBase, First Alt, Frame Base, Old Frame, Alt Align, {Worst alignment of record alternatives} Frame Extra, {putative padding at front of alternative} Max Frame {largest alternative so far} %integer Parameter Frame, Result Reg, SpSize, Attributes, MyMark, Open, Event Label, Event Body, Event Bits, Jlab {***** these are nicer as initialised declarations - SOD IMP80} Current Line = 0 Block Type = 0 Code Base = 0 Uncond Jump = -1 Var Base = Vars First Alt = Parms-1 Parameter Frame = 0 SpSize = 0 Attributes = 0 Open = Closed {assume in cannot return} Event Bits = 0 Result Reg = Iresult Result Reg = F0 %if Reals <= Avar_Type <= Lreals %c %and Avar_Flags&Indirect = 0 {not a real map} %integername Ca; Ca == Code Base {current Address} %routine Put with CA(%integer X) Put(X) Put(Ca) %end %routine BD(%integer Base, Disp) Write(Disp, 1) Printch('(') %if R0 <= Base <= AnyF %start Printstring(Regid(Base)) %finish %else %start Printch('L') %and Base = Base-128 %if Base >= 128 Write(Base, 0) %finish Printch(')') %end %routine Show(%integer N, %string(15) Text) %if N # 0 %start Space; Printstring(Text) Write(n, 1) %finish %end %routine Common(%record(Varfm)%name V, %integer X) Space; Printstring(Typeid(V_Type)) Space; Printstring(Formid(V_Form)) %if V_Form >= VinX %start BD(V_Base, X) %if V_Disp >= 0 %then Printstring("++") %else Printch('-') Write(V_Disp, 0) %finish %else %start BD(V_Base, V_Disp) %finish Show(V_Format, "Fm:") Show(V_Flags, "Fl:") Show(V_Area, "R:") %end %routine Show Data(%record(Datafm)%name D) Common(D_V, D_V_Extra) %if D_A_Scale # 0 %start Printstring(" A: ") Common(D_A, 0) Show(D_Bias, "Bias") %finish %end %routine Display(%record(Stackfm)%name V, %integer Bias) %if V == Null %start Printstring("Null"); Newline %return %finish Show Data(V_Data) newline %if V_Oper # 0 %start Spaces(Bias-4); Printstring(Operid(V_Oper)) Display(V_Link, Bias) %finish %end %routine Show Reg(%integer R) %integer A A = Activity(R) Printstring(Regid(R)) Printstring(" act:") %if A < 0 %then Printch('*') %else Write(A, 0) Printstring(" u:"); Print Octal(Used(R)) Printstring(" k:"); Write(Ktimes(R), 0) Newline %end %routine Monitor Register(%integer R, %string(15) Text) Select Output(0) Printstring(Text); Spaces(16-length(Text)) Show Reg(R) Select Output(Obj) %end %routine Monitor(%record(Stackfm)%name V, %string(15) Text) Select Output(0) Printstring(Text); spaces(16-length(Text)) Display(V, 16) Select Output(Obj) %end %routine Mon Regid(%integer R, %string(15) Text) Select Output(0) Printstring(Regid(R)); Space Printstring(Text) Newline Select Output(Obj) %end %routine Display Knowledge %record(Datafm)%name K Select Output(0) K == Knowing %while K ## Null %cycle Printstring(Regid(K_Reg)); Printstring(" = ") Show Data(K) Newline K == K_Link %repeat Select Output(Obj) %end %routine Fail(%string(63) Why) %integer R %routine Pcode(%integer S) %if ' ' <= S <= 126 %start Printch(''''); Printch(S); Printch('''') %finish write(S, 3) %end Select Output(0) Printstring("Pass 2 fails -- "); Printstring(Why) Printstring(" at source line "); Write(Current Line, 0); newline Printstring("Code "); Pcode(Code) Printstring(" Pending "); Pcode(Pending) Newline Show Reg(R) %for R = R0, 1, F3 %while Stack ## Null %cycle Printstring("S:"); Display(Stack, 5) Stack == Stack_Stack %repeat %while Using ## Null %cycle Printstring("U:"); Display(Using, 5) Using == Using_Using %repeat Printstring("Ca="); Print Octal(Ca) Newline %monitor; %stop %end %routine Warn(%string(63) What) Select Output(0) Printstring("Warning: "); Printstring(What) Printstring(" at source line "); Write(Current Line, 0); newline Select Output(Obj) %end %routine Set Mode(%integer Type) {Change the mode of the floating-point processor. Fp MODE defines the} {current mode.} %if Fp Mode # Type %start Fp Mode = Type %if Type = Reals %then Plant0(SETF) %else %c %if Type = Lreals %then Plant0(SETD) %else %c %if Type # Undefined %then Fail("FP Mode") %finish %end %routine Replace(%record(Stackfm)%name Old, New) Release(Old_Base) Old_Data = New_Data Claim(Old_Base) %end %routine Reduce Array(%record(Stackfm)%name V) %record(Stackfm) X %record(Stackfm)%name Z %integer Flags, Type, Bias, Scale, Reloc Monitor(V, "Reduce A") %if Diag&MonOperate # 0 Flags = V_A_Flags; Type = V_Type Reloc = 0 Reloc = V_A_Area %if Flags&Arrayname = 0 Z == Record(Descriptor) Z_V = V_A {describing A(0)} %if Reloc # 0 %start %if Z_Form >= VinX %then Reloc = 0 {do it now} %c %else Z_Area = 0 {delay it} %finish Optimise(V, 0) Bias = V_Bias Scale = V_A_Scale %if Scale # 0 %start X = 0 X_V = V_V {index} X_Type = V_A_Type Operate(MULX, X, Record(Literal(Scale))) Amap(Z) {describing addr(A(0))} %if Z_Oper # 0 %start Bias = Bias+Z_Link_Disp Drop(Z_Link) Z_Link == Null Z_Oper = 0 %finish %if Z_Form = VinR %start Bias = Bias+Z_Disp; Z_Disp = 0 %finish Operate(ADDX, X, Z) {X is now Addr(A(X))} Loadup(X) %if X_Oper # 0 V_A_Type = Alhs Remember(X_Base, V) V_Data = X_Data %finish %else %start V_Type = Integers Drop (Z) %finish Z == Record(Literal(Bias)); Z_Area = Reloc Operate(ADDx, V, Z) {V_Disp = V_Disp+Bias} Vmap(V, Integers) %if Flags&Indirect # 0 {name array} Vmap(V, Type) %end %routine Address(%record(Stackfm)%name V, %integer Mode) Monitor(V, "Addr") %if Diag&MonOperand # 0 %if V_Oper # 0 %start {must be loaded} Loadup(V) Fail("LHS") %if Mode = 0 %return %finish Reduce Array(V) %if V_A_Scale # 0 %if V_Form >= VinX %start {must be simplified} Reduce(V) %unless V_Form = VinX %and V_Disp = 0 %finish Optimise(V, Mode) {try to improve it} %end %routine Reduce(%record(Stackfm)%name V) %record(Stackfm) Temp Monitor(V, "Reduce") %if Diag&MonOperand # 0 Temp = 0 Temp_Base = V_Base Temp_Disp = V_Extra Temp_Type = Integers Temp_Form = VinS %if V_Flags&Hazarded # 0 %start {Hazard hit it} V_Flags = V_Flags&(\Hazarded) %finish %else %start Temp_Area = V_Area V_Area = 0 %finish Load(Temp, AnyG) {pick up the record base} V_Base = Temp_Base; V_Extra = 0 %if V_Form = AinX %start V_Form = VinX V_Extra = V_Disp V_Disp = 0 %finish %else %if V_Form = VinX %start V_Form = VinS %finish %else %start Fail("Reduce ".FormId(V_Form)) %finish %end %routine Vmap(%record(Stackfm)%name V, %integer New Type) %record(Stackfm)%name W %integer N, R N = 0; R = 0 Monitor(V, "Vmap") %if Diag&MonOperate # 0 %if V_Oper # 0 %start W == V_Link %if V_Oper = ADDx %and W_Form = VinR %start {Integer(X+23) or (X+R1) or (X+Addr(Y))} N = W_Disp; W_Disp = 0 R = W_Area; W_Area = 0 %if R # 0 %start V_Oper = 0; V_Link == Null Loadup(V); V_Area = R V_Oper = ADDx; V_Link == W %finish %if W_Base # 0 %start {add in the register} Loadup(V) %finish %else %start V_Oper = 0; V_Link == Null; Drop(W) %finish %finish %else %start Loadup(V) %finish %finish Reduce array(V) %if V_A_Scale # 0 Loadup (V) %if V_Type # Integers %if V_Form = VinR %start V_Form = VinS V_Disp = V_Disp+N %finish %else %if V_Form = VinS %start V_Extra = V_Disp V_Disp = N V_Form = VinX %finish %else %start Reduce(V) %if V_Form = AinX {leaving VinX} %if N = 0 %start V_Form = AinX %finish %else %start Reduce(V) V_Extra = V_Disp V_Disp = N V_Form = VinX %finish %finish V_Flags = Hazarded %if R # 0 %and V_Form # VinS V_Type = New Type %end %routine Amap(%record(Stackfm)%name V) Monitor(V, "Amap") %if Diag&MonOperate # 0 Reduce Array(V) %if V_A_Scale # 0 %if V_Form = VinR %or V_Oper # 0 %start Fail("Amap") %finish %else %start V_Type = Integers %if V_Form = VinX %start %if V_Disp # 0 %start V_Oper = ADDx; V_Link == Record(Literal(V_Disp)) %finish V_Form = VinS V_Disp = V_Extra; V_Extra = 0 %finish %else %if V_Form = VinS %start V_Form = VinR %finish %else %if V_Form = AinX %start V_Form = VinX %finish {leave Ainc and Adec alone} %finish %end %routine Process Operand(%record(Stackfm)%name V, %record(Opfm) %name D, %integer Mode, Use) Monitor(V, "Process") %if Diag&MonOperand # 0 Address(V, Mode) D = 0 D_More = V_Area Load Base(V) %if V_Base > Pc %if V_Form = VinR %start %if V_Base = 0 %start {constant+relocation} Fail("LHS") %if Mode = 0 D_Modereg = Immediate D_Extra = V_Disp D_More = No Relocation %if D_More = 0 %finish %else %if V_Disp = 0 %and V_Area = 0 %start %if V_Base = AnyG %start V_Base = Gpr %finish %else %if V_Base = AnyF %start V_Base = Fpr %finish D_Modereg = Reg %finish %else %start {address calculation} V_Link == Record(Register(V_Base)) V_Oper = ADDx V_Base = 0 Use = AnyG %if Use = 0; Load(V, Use) D_Modereg = Reg D_More = 0 %finish %finish %else %if V_Form = VinS %start %if V_Base = 0 %start D_Modereg = Absolute D_Extra = V_Disp D_More = No Relocation %if D_More = 0 %finish %else %if V_Disp = 0 %and V_Area = 0 %start D_Modereg = Defer %finish %else %start D_Modereg = Index D_Extra = V_Disp D_More = No Relocation %if D_More = 0 %finish %finish %else %if V_Form = VinX %and V_Disp = 0 %start %if V_Base = 0 %start D_More = D_More!1 {make Pc relative} D_Modereg = Relative Defer %finish %else %start D_Modereg = IndexDefer %finish D_Extra = V_Extra D_More = No Relocation %if D_More = 0 %finish %else %if V_Form = Ainc %or V_Form = Adec %start Fail("Auto") %if V_Disp # 0 %or V_Base = 0 %or V_Area # 0 D_Modereg = AutoI D_Modereg = AutoD %if V_Form = Adec %finish %else %start Fail("Form") %finish D_Modereg = D_Modereg+Actual(V_Base) Attributes = Attributes!Attr Uses Locals %if V_Base = LNB Monitor(V, "done") %if Diag&MonOperand # 0 %end %routine Cbyte(%integer N) Printch(Obj Byte) Printch(N&255) Ca = Ca+1 %end %routine Cword(%integer N) Plant(N, 0) %end {Area Control} %routine Select Area(%integer Area Id, %integername Base) Current Area = Area Id Ca == Base Ocode(Obj Select); Put with Ca(Current Area) %end %routine Select Code Area Select Area(Code Area, Code Base) %end %routine Select Constant Area Select Area(Constant Area, Constant Base) %end %routine Select Own Area Select Area(Own Area, Own Base) %end %routine Word Align Cbyte(0) %if Ca&1 # 0 %end %routine Plant(%integer Op, Reloc) %integer Code !#if e(=true) %if Diag # 0 %start Select Output(0) Decode11(Ca, Op, Reloc, 0) Select Output(Obj) %finish !#fi %if Reloc > 0 %start %if Reloc > Own Area!1 %start Dcode(Dir Spec); Put(Reloc) %finish Ocode(Obj External); Put(Reloc) %finish Code = Obj Word Code = -Reloc %if Reloc < No Relocation {no relocation, but perhaps info} Printch(Code) Put(Op) Ca = Ca+2 %end %routine Protect(%record(Stackfm)%name V) %integer R %if InReg(V)#0 %and Activity(V_Base) > 1 %start %if V_Base >= F0 %then R = Fpr %else R = Gpr Load(V, R) %finish %end {%predicate} %integerfn Cc Known(%record(Stackfm)%name V) %result=-1 %if Cc1_Cc Ca = Ca %and Same(V, Cc1)#0 %result=-1 %if Cc2_Cc Ca = Ca %and Same(V, Cc2)#0 %result=0 %end %routine Set CC1(%record(Stackfm)%name V) Cc1_Data = V_Data Cc1_Cc Ca = Ca %end %routine Plant0(%integer Op) Fail("Operand") %if OpType(Op)&Type Mask # Zero Instruction Cword(OpTable(Op)) %end %routine Process Reals 2(%integer Op, %record(Stackfm)%name V1, V2) %integer Reg, Store, Stop Fail("Real op") %unless Op = LDF %if V1_Form = VinR %and V1_Disp = 0 %and V1_Base = 0 %start PlantF(CLRF, 0, V2) %return %finish %if V2_Form # VinR %start Store = 1 %if InReg(V1)#0 %start Reg = V1_Base %finish %else %start Reg = Fpr PlantF(LDF, Reg, V1) %finish %finish %else %start Store = 0 Reg = V2_Base %if Reg = AnyF %start %return %if InReg(V1)#0 Reg = Fpr %finish PlantF(LDF, Reg, V1) %finish Release(V1_Base) V1_Base = Reg; V1_Form = VinR; V1_Disp = 0 Claim(Reg) Stop = Stf Stop = Stcfd %if V2_Type = Reals PlantF(Stop, Reg, V2) %if Store # 0 %end %routine Plant1(%integer Op, %record(Stackfm)%name V1) %record(Opfm) Op1 %integer T %record(Stackfm) Hold %if V1_Type >= Reals %start PlantF(Op, 0, V1) %return %finish T = Optype(Op) Fail("Op") %if T&Type Mask # Single Instruction Protect(V1) %if T&OpMask = 0 Hold_Data = V1_Data Process Operand(V1, Op1, T&Op Mask, 0) Claim(V1_Base) %if Hold_Base = AnyG %or Hold_Base = AnyF %if Op = TST %start ->TZ %if Cc Known(V1)#0 N = Spare Register %if N # 0 %and V1_Form # VinR %start Load(V1, N) Remember(N, Hold) Test Zero(V1) ->TZ %finish %finish Plant(OpTable(Op)+Op1_Modereg, Test Single) Plant(Op1_Extra, Op1_More) %if Op1_More # 0 %if T&OpMask = 0 %start {destination} Forget Destination(V1) Forget Destination(Hold) %finish Set CC1(V1) TZ:%if Op = TST %and Op1_ModeReg&8_70 = 0 %start Z Ca = Ca Z Reg = V1_Base %finish %end %routine Plant2(%integer Op, %record(Stackfm)%name V1, V2) %record(Opfm) Op1, Op2 %integer T, Wanted %record(Stackfm) Hold1, Hold2 %if V2_Type >= Reals %start Process Reals 2(Op, V1, V2) %return %finish T = OpType(Op) Protect(V2) %if T&(ToReg!OpMask<<2) = 0 {dest modification} Wanted = 0 Wanted = V2_Base %if T&ToReg # 0 %and V2_Form = VinR Fail("Op") %if T&Type Mask # Double Instruction Hold1 = V1 Hold2 = V2 {Beware: V2 can point to ANYG or ANYR so don't alter it} Process Operand(V1, Op1, T&Op Mask, Wanted) %if (V2_Base = AnyG %or V2_Base = AnyF) %and In Reg(V1)#0 %start %return %if Activity(V1_Base) >= 0 {don't use dedicated registers} %finish Process Operand(Hold2, Op2, T&Op Mask<<2, 0) %unless Op1_Modereg = Op2_Modereg %and %c Op1_Extra = Op2_Extra %and %c Op1_More = Op2_More %and %c (Op = MOV %or Op = MOVB) %start Plant(OpTable(Op)+(Op1_Modereg<<6)+Op2_Modereg, Test Double) Plant(Op1_Extra, Op1_More) %if Op1_More # 0 Plant(Op2_Extra, Op2_More) %if Op2_More # 0 %if T&OpMask<<2 = 0 %start {destination} Forget Destination(Hold2) Forget Destination(V2) Set CC1(Hold2) %finish %if T&ToReg # 0 %start Cc2_Data = V1_Data; Cc2_Cc Ca = Ca Remember(Hold2_Base, Hold1) %if InReg(Hold2)#0 %if InReg(V1)#0 %start %if V2_Form = VinR %then Remember(V1_Base, Hold2) %c %else Remember(V1_Base, V2) %finish %finish %finish %if Wanted # 0 %start {going to a register} Replace(V1, Hold2) %finish %else %start V2_Data = Hold2_Data %finish %end %routine PlantR(%integer Op, Reg, %record(Stackfm)%name V) %record(Opfm) Op1 %record(Stackfm) Hold %integer T T = OpType(Op) Fail("Op") %if T&Type Mask # Register Instruction Fail("Register") %unless R0 <= Reg <= R3 Protect(V) %if T&OpMask<<2 = 0 Hold = V Process Operand(V, Op1, T&Op Mask<<2, 0) Plant(OpTable(Op)+(Actual(Reg)<<6)+Op1_Modereg, Test Double) Plant(Op1_Extra, Op1_More) %if Op1_More # 0 %if T&OpMask<<2 = 0 %start Forget Destination(Hold) Forget Destination(V) %finish Forget(Reg) %if T&OpMask = 0 Set Cc1(V) %end %routine PlantF(%integer Op, Reg, %record(Stackfm)%name V) %record(opfm) Op1 %record(Stackfm) Hold %record(Stackfm)%name R %integer T T = OpType(Op) Fail("Op") %if T&Type Mask # Floating Instruction Fail("Register") %unless 0 <= Reg <= F3 Protect(V) %if T&OpMask<<2 = 0 Hold = V Process Operand(V, Op1, T&Op Mask<<2, 0) {Reg=0 for unary operations} %unless Op = TSTF %and Cc Known(V)#0 %start %if Reg = 0 %then Set Mode(V_Type) %else Set Mode(Lreals) Plant(OpTable(Op)+(Actual(Reg)<<6)+Op1_Modereg, Test Single) Plant(Op1_Extra, Op1_More) %if Op1_More # 0 %if T&OpMask<<2 = 0 %start {destination} Forget Destination(Hold) Forget Destination(V) %finish %if Reg # 0 %start Forget(Reg) %if T&OpMask = 0 R == RegV(Reg) Set Cc1(R) %finish %if Op = LDF %or Op = STF %start Remember(Reg, Hold) Cc2_Data = V_Data; Cc2_Cc Ca = Ca %finish Replace(V, R) %if T&ToReg # 0 %finish %end %routine Machine Code %constbytearray Limits(0:9) = 0,0,0,0,63,255,63,0,255,7 %integer P, Code, Type, Limit, Errors, Change Ds, Varop %string(6) Text %integerarray Disps, Rels(1:2) %record(Varfm)%name V {%predicate} %integerfn Match(%integer Wanted) %result=0 %unless Pending = Wanted Readch(Pending) %result=-1 %end %routine Mc Error(%string(31) S) %integer N Errors = Errors-1 Warn(Text.S) %if Errors = 0 %while Pending # ';' %cycle %if Match('N')#0 %then N = Four Bytes %else Readch(Pending) %repeat %end %integerfn Literal(%integer Limit) %integer N %if Match('N')#0 %start N = Four Bytes %result = N %if Limit = 0 %or 0 <= N <= Limit %finish Mc Error(" Value?") %result=0 %end %routine Add(%integer D, R) P = P+1 Disps(P) = D Rels(P) = R %end %integerfn Operand %record(Varfm)%name V %integer Indirect, Mode, Reg, Lit, Rel Mode = 0; Reg = 0; Lit = 0; Rel = 0; Varop = 0 %routine Get Index Reg = Literal(7) Mc Error(" ) ?") %unless Match(')')#0 %end %routine Modify %cycle %if Match('+')#0 %start Lit = Lit+Literal(0) %finish %else %if Match('-')#0 %start Lit = Lit-Literal(0) %finish %else %return %repeat %end Indirect = 0 Indirect = 1 %if Match('@')#0 %if Match('#')#0 %start Mode = 2; Reg = 7 %if Match(' ')#0 %start V == Var(Tag) Rel = V_Area Lit = V_Disp Mc Error(" Address?") %if Rel = 0 Modify %finish %else %start Lit = Literal(0) %finish Add(Lit, Rel) %finish %else %if Match('(')#0 %start Get Index Mode = 1 Mode = 2 %if Match('+')#0 %finish %else %if Match('-')#0 %start %if Match('(')#0 %start Get Index Mode = 4 %finish %else %start Mode = 6 Lit = -Literal(0) %if Match('(')#0 %then Get Index %else Mc Error(" ( ?") Modify Add(Lit, 0) %finish %finish %else %if Pending = 'N' %start Lit = Literal(0) %if Match('(')#0 %start Get Index Mode = 6 Modify Add(Lit, 0) %finish %else %start Mc Error(" Register?") %unless 0 <= Lit <= 7 Reg = Lit %finish %finish %else %if Match(' ')#0 %start Varop = 1 V == Var(Tag) Rel = V_Area Lit = V_Disp Reg = V_Base %if V_Type = Labels %start Rel = -(Lit<<1); Mode = 6; Reg = 7 Lit = 0 %finish %else %if V_Base = Local %start Reg = Actual(Lnb); Mode = 6 %finish %else %if Rel # 0 %or Reg = 0 %start Reg = 7; Mode = 3 %finish %else %start Mc Error(" Address?") %finish %if Indirect # 0 %start Mode = 6; Rel = Rel!1 %finish Modify %if Lit = 0 %and Rel = 0 %and Mode = 6 %then Mode = 1 %c %else Add(Lit, Rel) %finish %else %start Mc Error(" Format?") %finish %if Indirect # 0 %start Mc Error(" Indirect?") %if Mode&1 # 0 Mode = Mode+1 %finish %result = Mode<<3+Reg %end %routine Get Oper %integer M1, M2, J, H, L Text = "" %while Pending # '_' %cycle Text = Text.Tostring(Pending) %unless Length(Text) = 5 Readch(Pending) %repeat Readch(Pending) Text = Text." " %while Length(Text) # 5 M1 = ((Charno(Text, 1)<<5+Charno(Text, 2))<<5+Charno(Text, 3))&8_077777 M2 = Charno(Text, 4)<<5+Charno(Text, 5) L = 1; H = McOps {Binary search} %cycle J = (L+H)>>1 %if Val1(J) = M1 %start %if Val2(J) = M2 %start Type = Mc Type(J) Code = Op Table(J) Limit = Limits(Type&15) %return %finish %if Val2(J) > M2 %then H = J-1 %else L = J+1 %finish %else %start %if Val1(J) > M1 %then H = J-1 %else L = J+1 %finish %repeat %until L > H Type = 0 Code = 0 Mc Error(" Unknown") %end %routine Pop(%integer N) %integer V, R, L V = Disps(N); R = Rels(N) %if R < 0 %start {label} R = -R L = R>>1 Printch(Obj PcRel) %if R&1 # 0 {?was after ca+2?} Dcode(Dir Mcused); Put with Ca(L) Ocode(Obj Modlab); Put(L); Put(V) Ca = Ca+2 %finish %else %start Plant(V, R) %finish %end %routine Code Instruction %switch Mc(0:9) ->Mc(Type&15) Mc(2): Code = Code!Operand<<6 Change Ds = Test One %if Varop # 0 Com: ->Err %unless Match(',')#0 Mc(1): Code = Code!Operand %if Varop # 0 %start %if Change DS = 0 %then Change DS = Test Single %C %else Change DS = Test Double %finish Plant(Code, Change Ds) Pop(1) %if P # 0 Pop(2) %if P = 2 %return Mc(0): Plant(Code, 0); %return Mc(3): Mc(7): Code = Code!Literal(Limit)<<6 ->Com Mc(4): Mc(5): Mc(9): Plant(Code!Literal(Limit), 0); %return Mc(6): Code = Code!Literal(3)<<6 ->Err %unless Match(',')#0 Mc(8): %if Match(' ')#0 %start V == Var(Tag) %if V_Type = Labels %start Dcode(Dir Mcused); Put with Ca(V_Disp) Ocode(Obj Branch+4-((Type&15)>>1)); Put(V_Disp); Put(Code) Ca = Ca+2 %return %finish %finish Mc Error(" Label?") %return Err: Mc Error(" Comma?") %end Errors = 1 Change Ds = 0 P = 0 Get Oper Code Instruction Uncond Jump = Ca %if Type&128 # 0 Mc Error(" Operands?") %if Pending # ';' Readch(Pending) %end {%predicate} %integerfn In Safe Reg(%record(Stackfm)%name V) %result=0 %if V_Form # VinR %or V_Disp # 0 %or V_Base >= 128 %c %or Activity(V_Base) # 1 %result=-1 %end {%predicate} %integerfn In Free Reg(%record(Stackfm)%name V) %result=0 %if V_Form # VinR %or V_Disp # 0 %or Activity(V_Base) # 0 %result=-1 %end %routine Float(%record(Stackfm)%name V, T) {Convert the integral object V into a floating-point object} {T defines the sort of result required: Real or Long real, and {possibly the register to do it into} %integer R Monitor(V, "Float") %if Diag&MonOperate # 0 Fail("Integral") %if V_Type > Bytes %if Const(V)#0 %start Real Value_R = V_Disp Set Real(V) %return %finish Loadup(V) %if V_Type = Bytes %or V_Oper # 0 %if In Free Reg(T)#0 %then R = T_Base %c %else R = Fpr PlantF(LDCIF, R, V) %end %routine Equate Types(%record(Stackfm)%name Old, New, %integer ToNew) %integer Nt, Ot, R %record(Stackfm) Rw %record(Stackfm)%name Rv %routine Update New_Data = Rw_Data %if New_Form # VinR Replace(Old, New) %end Nt = New_Type; Ot = Old_Type %if Ot = Strings %or Ot = Records %start Amap(Old); %return %finish %if Ot = Bytes %start {must be loaded} %if In Free Reg(New)#0 %then R = New_Base %else R = Gpr Rv == RegV(R) %if Old_Flags&Safe Byte # 0 %start {Movb will zero extend} Plant2(MOVB, Old, Rv) %finish %else %start Claim(R) Plant1(CLR, Rv); Plant2(BISB, Old, Rv) Release(Old_Base) %finish Old_Data = Rv_Data; Ot = Integers %return %if Nt = Integers %finish %if Reals <= Nt <= Lreals %start %if Reals <= Ot <= Lreals %start %if ToNew # 0 %and InReg(Old)#0 %start Rw_Data = New_Data PlantF(STCFD, Old_Base, Rw) Update %finish %else %start R = AnyF R = New_Base %if ToNew # 0 %and New_Form = VinR R = Fpr %if R = AnyF PlantF(LDCFD, R, Old) Old_Type = Nt %finish %finish %else %start {float required} Float(Old, New) %finish %finish %else %if Reals <= Ot <= Lreals %start Loadup(Old) %if ToNew # 0 %start Rw_Data = New_Data PlantF(STCFI, Old_Base, Rw) Update %finish %else %start Rv == RegV(Gpr) PlantF(STCFI, Old_Base, Rv) Replace(Old, Rv) %finish %finish %end %routine Simple(%record(Stackfm)%name From, To) {Move the object described by the simple descriptor FROM into the} {destination TO. FROM is updated if To is a register and TO is left unaltered} %integer Type, N, Treg %record(Stackfm) Temp %if Diag&MonMove # 0 %start Monitor(From, "S-From") Monitor(To, "S-To") %finish %return %if Same(From, To)#0 Treg = Inreg(To) %if Treg # 0 %start N = Activity(To_Base) %if N > 0 %start Hazard(To_Base) %if N > 1 %or To_Base # From_Base %finish %finish Type = To_Type %if Const(From)#0 %and %c (From_Disp = 0 %or (-1 <= From_Disp <= 1 %and Treg#0)) %start Promote(To_Base) N = From_Disp Optimise(From, 1) {just in case} Move(From, To) %and %return %if From_Base # 0 Temp_Data = From_Data %if N # 0 %start From_Disp = 0; Optimise(From, 1) %finish %if From_Base # 0 %start Move(From, To) %finish %else %start From_Data = To_Data Claim(From_Base) Plant1(Clearop(Type), From) %finish %if N # 0 %start %if N < 0 %then N = DEC %else N = INC Plant1(N, From) %finish Remember(From_Base, Temp) %if From_Form = VinR %finish %else %start Equate Types(From, To, 1) %if From_Type # Type Plant2(Move op(Type), From, To) %finish %end {%predicate} %integerfn Incdec Done(%record(Stackfm)%name S, D, %integer Oper) %result=0 %unless Const(S)#0 %and (S_Disp = 1 %or S_Disp = -1) Oper = ADDx+SUBx-Oper %if S_Disp < 0 Plant1(Inc op(Oper<<1+D_Type), D) %result=-1 %end {%predicate} %integerfn Shifted(%record(Stackfm)%name S, D, %integer Pickup, Oper) %integer Now, Then, N %result=0 %unless Const(S)#0 Load(D, Pickup) %if Pickup # 0 N = S_Disp %result=0 %if N&7 >= 5 %and Pickup = 0 %unless 0 <= N <= 16 %start !#if e(=true) warn("Shift by ".ItoS(N)) !#else(=false) { warn("Shift by ".ItoS(N,1))} !#fi %if N < 0 %then N = 0 %else N = 16 %finish %result = 0 %unless 0 < N <= 2 %or 8 <= n <= 10 %if N >= 8 %start Plant1(CLRB, D) %if Oper = RSHx Plant1(SWAB, D) Plant1(CLRB, D) %if Oper = LSHx N = N-8 %finish Now = Asl; Then = Asl %if Oper = RSHx %start Now = ROR; Then = ASR Oper = 0 %finish %if N > 0 %start Plant0(CLC) %if Oper = 0 %cycle Plant1(Now, D) Now = Then N = N-1 %repeat %until N = 0 %finish %result=-1 %end {%predicate} %integerfn Self(%record(Stackfm)%name S, D, %integer Oper) %integer Flags Flags = Oper Flags(Oper) %result=0 %if Flags&Selfop = 0 %or %c (Flags&Byteself = 0 %and D_type = Bytes) {Beware - INCB and DECB are funnies as there are no ADDB and SUBB} %if Flags&Unary # 0 %start %if Oper = RNEGx %start PlantF(NEGF, 0, D) %finish %else %start Plant1(Unary op(Oper<<1+D_Type), D) %finish %finish %else %start {Binary} %if Flags&Incdec # 0 %start %result=-1 %if Incdec Done(S, D, Oper)#0 %result=0 %if D_Type = Bytes %finish %if Oper = XORx %start Loadup(S) PlantR(XOR, S_Base, D) %finish %else %if Oper = LSHx %or Oper = RSHx %start %result=0 %unless Shifted(S, D, 0, Oper)#0 %finish %else %start Loadup(S) %if S_Type = Bytes # D_Type Plant2(Operation(Oper<<1+D_Type), S, D) %finish %finish %result=-1 %end %routine Advance Ds %if DsBias # 0 %start Cword(8_062705); Cword(DsBias) {ADD_#DsBias,Ds} DsBias = 0 %finish %end %routine Retreat Ds(%integer Shift) Ds Bias = Shift %if Ds Bias # 0 %start Cword(8_162705); Cword(DsBias) {SUB_#DsBias,Ds} %finish %end %routine To Work Area(%record(Stackfm)%name V) %record(Stackfm)%name W {Leaves V as the address of the area} Load(V, R1) Hazard(R2) W == Record(Literal(DsBias)) W_Base = Ds; W_Flags = In Work DsBias = DsBias+256 Load(W, R2); Release(R2) Attributes = Attributes!Attr Dynamic Release and Clear(V) Perm(Smove) Claim(R2) V_Data = W_Data W_Flags = 0; Drop(W) %end %routine Complex(%record(Stackfm)%name From, To) {Move the object described by the complex descriptor FROM into the} {destination TO. FROM is updated and TO is left unaltered} %record(Stackfm)%name W, Work, V %integer Even, Odd, N, Oper, Flags %record(Stackfm) Reg %switch Nasty(ADDx:REXPx) %routine Choose a Register(%integer Type) Reg = 0 Reg_Type = Type %if In Free Reg(To)#0 %start Reg_Base = To_Base %finish %else %start Optimise(From, 1) %if In Safe Reg(From)#0 %start Reg_Base = From_Base %finish %else %start %if Type >= Reals %then Reg_Base = AnyF %else Reg_Base = AnyG %finish %finish %end %routine Choose odd Register Reg = 0 Reg_Type = Integers %if In Safe Reg(From)#0 %and From_Base&1 = 0 %start Reg_Base = From_Base %finish %else %if Activity(R0)+Activity(R1) < Activity(R2)+Activity(R3) %start Reg_Base = R1 %finish %else %start Reg_Base = R3 %finish %end %if Diag&MonMove # 0 %start Monitor(From, "C-From") Monitor(To, "C-To") %finish W == From_Link; From_Link == Null Oper = From_Oper; From_Oper = 0 Flags = Oper flags(Oper) %if Same(From, To)#0 %and Self(W, To, Oper)#0 %start Release and Drop(W) %unless W == Null {beware unary operators} %return %finish %if Flags&Commutative # 0 %start %if Same(W, To)#0 %and Self(From, To, Oper)#0 %start Replace(From, To) Release and Drop(W) %return %finish %else %if In Safe Reg(W)#0 %c %and (%not In Safe Reg(From)#0 %c %or Ktimes(From_Base) < Ktimes(W_Base)) %start Reg_Data = From_Data From_Data = W_Data W_Data = Reg_Data %finish %finish %if Flags&InPrim # 0 %start Perm Operation(Oper, From, W) {sets FROM to describe the result} Drop(W) Sout: Simple(From, To) %return %finish %if Oper >= RNEGx %start {floating-point operation} Choose a register(Lreals) Simple(From, Reg) %if Oper = RNEGx %start Plant1(NEGF, From) %finish %else %start Equate Types(W, From, 0) %if W_Type # From_Type PlantF(Fop(Oper), From_Base, W) Release and drop(W) %finish ->Sout %finish %if Flags&Easy # 0 %start Choose a register(Integers) Simple(From, Reg) %if Oper <= NEGx %start Plant1(Operation(Oper<<1+Integers), From) %finish %else %start %unless Flags&IncDec # 0 %and Incdec Done(W, From, Oper)#0 %start Loadup(W) %if W_Type = Bytes Plant2(Operation(Oper<<1+Integers), W, From) %finish Release and drop(W) %finish ->Sout %finish {This leaves the nasties: MUL, DIV, REM, XOR, SHL, SHR, CONC} ->Nasty(Oper) Nasty(XORx):Choose a register(Integers) Simple(From, Reg) Loadup(W) PlantR(XOR, W_Base, From) Release and drop(W) ->Sout Nasty(MULx):Choose odd register Simple(From, Reg) Loadup(W) %if W_Type = Bytes PlantR(MUL, From_Base, W) Release and drop(W) ->Sout Nasty(REMx): Nasty(DIVx):Choose odd register Simple(From, Reg) Odd = From_Base; Even = Odd-1 Hazard(Even); Claim(Even) Test Zero(From) Plant1(SXT, RegV(Even)); Forget(Even) Loadup(W) %if W_Type = Bytes PlantR(DIV, Even, W); Forget(Odd) Release and drop(W) From_Base = Even {assume DIVx} From_Base = Odd %if Oper = REMx Release(Even+Odd-From_Base) {the other one} ->Sout Nasty(LSHx): Nasty(RSHx): N = AnyG N = To_Base %if To_Form = VinR %and To_a_Scale = 0 %if Shifted(W, From, N, Oper)=0 %start loadup(w) %if W_Type = Bytes choose a register(integers) simple(from,reg) %if Oper = RSHx %start %if Const(W) = 0 %start loadup(w) plant1(neg,w) %finish %else %start w_disp=-w_disp %finish %finish plantR(ash,from_base,w) %finish release and drop(w) ->sout ! N = AnyG ! N = To_Base %if To_Form = VinR ! Perm Operation(Oper, From, W) %unless Shifted(W, From, N, Oper)#0 ! Drop(W) ! ->Sout Nasty(CONCx): %if From_Flags&In Work # 0 %start Amap(From) %finish %else %start To Work Area(From) %finish From_Flags = From_Flags&(\In Work) %while W ## Null %cycle V == W; W == W_Link V_Oper = 0; V_Link == Null %if V_Type # Strings %start {Tostring} N = From_Format {max size} Load(From, R2) Cword(8_105212) {INCB_(R2)} Forget(R2) Work == Record(Copy(From)); Release(R2) Work_Type = Bytes Work_Form = VinS Work_Flags = Work_Flags!Safe Byte %if 2 <= N <= 128 Loadup(Work) Cword(8_060200+Actual(Work_Base)); Forget(Work_Base) Work_Type = Bytes; Work_Form = VinS Move(V, Work) Release and Drop(Work); Release and Drop(V) N = N + 1 %finish %else %start N = From_Format + V_Format Load(V, R1); Load(From, R2) Release and Drop(V); Release(R2) Perm(Sconc) %finish From_Format = N Claim(R2) %repeat Simple(From, To) %unless To_Base = AnyG From_Flags = From_Flags!In Work %return Nasty(*): Fail("Operation") %end %routine Move(%record(Stackfm)%name From, To) {Move the object FROM into the destination TO} {FROM is updated and TO is left unaltered} %if From_Oper = 0 %then Simple (From, To) %c %else Complex(From, To) %end %routine Load(%record(Stackfm)%name V, %integer R) Move(V, RegV(R)) %end %routine Loadup(%record(Stackfm)%name V) {load the value V into a suitable register depending on its type} %integer R %if Floating(V)#0 %then R = AnyF %c %else R = AnyG Load(V, R) %end %routine Load Base(%record(Stackfm)%name V) %record(Varfm) D %record(Stackfm) T %return %if V_Base <= 128 Monitor(V, "LoadB") %if Diag&MonOperand # 0 %if V_Base = Local %start V_Base = Lnb %finish %else %start %if Uses Display = 0 %start External Id = "@DISPLAY" D_Form = VinS; Dump External(Dir Notex, D) Uses Display = D_Area %finish Frame Use(V_Base) = 0 {show the level used} T = 0 T_Disp = (V_Base-128-1)*2 T_Type = Integers T_Form = VinS T_Area = Uses Display Loadup(T) V_Base = T_Base %finish %end %routine Load Pair(%record(Stackfm)%name V1, V2) {Loads V1 into R1 and V2 into R2} Load(V1, R1) Load(V2, R2) Load(V1, R1) %if V1_Base # R1 {in case of Hazard} %end %routine Push(%record(Stackfm)%name V) %record(Stackfm) S S = 0 S_Base = DS; S_Type = Integers; S_Form = Ainc Move(V, S) %end %routine Constant Operation(%integer Op, %integername L, %record(Stackfm)%name R) %switch Cop(NOTX:REXPX) %integer N N = R_Disp Drop(R) ->Cop(Op) Cop(ADDX): L = L+N; ->Out Cop(SUBX): L = L-N; ->Out Cop(MULX): L = L*N; ->Out Cop(BICx): L = L&(\N); ->Out Cop( ORX): L = L!N; ->Out Cop(XORX): L = L!!N; ->Out Cop(LSHX): L = L<Out Cop(RSHX): L = (L&16_ffff)>>N; ->Out Cop(EXPX): Fail("Exp") %if N < 0; L = L\\N; ->Out Cop(REMx): Fail("Zero divide") %if N = 0; L = L-L//N*N; ->Out Cop(DIVX): Fail("Zero divide") %if N = 0; L = L//N; ->Out Cop(*): Fail("C-op") Out: %end %routine Operate(%integer Oper, %record(Stackfm)%name Lhs, Rhs) %integer Op, Rconst, Key, Lflags, Rflags, N %record(Stackfm)%name W %routine Swop %record(Stackfm) Temp Temp_Data = Lhs_Data Lhs_Data = Rhs_Data Rhs_Data = Temp_Data %end %routine Reduce Constant %integer Op, N, F %routine Fix(%integer Op) Lhs_Oper = Op Drop(Lhs_Link) Lhs_Link == Null %end Op = Lhs_Oper; F = Oper Flags(Op) N = Lhs_Link_Disp %if F&Nullop # 0 %and Null Value(Op) = N %start Fix(0) %finish %else %if Op = MULx %start %if N = 0 %start Fix(0) Release(Lhs_Base) Lhs_Form = VinR; Lhs_Base = 0; Lhs_Disp = 0; Lhs_Area = 0 %finish %else %if N = -1 %start Fix(NEGX) %finish %else %start N = Power(N) %if N > 0 %start Lhs_Link_Disp = N Lhs_Oper = LSHX %finish %finish %finish %else %if Op = XORX %and N = -1 %start Fix(NOTX) %finish %else %if Op = BICx %and N&x'FF00' = 0 %start Lhs_Flags = Lhs_Flags!Safe Byte %if Lhs_Type = Bytes %finish %end %if Diag&MonOperate # 0 %start Monitor(Lhs, "O-Lhs") Monitor(Rhs, "O-Rhs") %finish Rflags = Oper Flags(Oper) %if Rflags&Unary # 0 %start %if Const(Lhs)#0 %start {this excludes reals} %if Oper = NEGX %start Lhs_Disp = -Lhs_Disp %finish %else %if Oper = NOTX %start Lhs_Disp = \Lhs_Disp %finish %else Fail("Operator") %finish %else %start Oper = RNEGx %if Floating(Lhs)#0 %if Lhs_Oper # 0 %start %if Lhs_Oper = Oper %start {e.g. -(-A) } Lhs_Oper = 0 {this must catch reals} ->Mon %finish %if Lhs_Oper = NEGx %or Lhs_Oper = NOTx %start { -(\A) -> A+1 Note: -NEG = ADD } { \(-A) -> A-1 -NOT = SUB } Lhs_Oper = 0 %if Oper = NEGx %then Oper = ADDx %else Oper = SUBx Operate(Oper, Lhs, Record(Literal(1))) ->Mon %finish Loadup(Lhs) %finish Lhs_Oper = Oper; Lhs_Link == Null %finish ->Mon %finish %if Oper = ConcX %start Lhs == Lhs_Link %while Lhs_Oper # 0 {skip to the end} Lhs_Oper = ConcX; Lhs_Link == Rhs {append the new bit} ->Mon %finish Swop %if Rflags&Commutative # 0 %and Const(Lhs)#0 {1@? -> ?@1} %if Oper = ANDx %start Operate(NOTx, Rhs, Null) Operate(BICx, Lhs, Rhs) %return %finish %if Rhs_Oper # 0 %start Op = Rhs_Oper %if Op = NEGx %and (Oper = ADDx %or Oper = SUBx) %start { Lhs + (-Rhs) } Oper = (ADDx+SUBx)-Op { Lhs - Rhs } %finish %else %start Loadup(Rhs) %finish Rhs_Oper = 0 %finish %if Const(Rhs)#0 %start Rconst = 1 %if Oper = SUBX %start { Lhs-(+const) } Rhs_Disp = -Rhs_Disp Oper = ADDX { Lhs+(-const) } %finish %finish %else %start Rconst = 0 %finish %if Lhs_Oper # 0 %start Op = Lhs_Oper; Lflags = Oper Flags(Op) W == Lhs_Link %if Op = NEGx %and Oper = MULx %start Lhs_Oper = 0 Operate(MULx, Lhs, Rhs) Operate(NEGx, Lhs, Null) %return %finish %if Lflags&Unary = 0 %and Const(W)#0 %start %if Rconst # 0 %start Key = (Lflags!Rflags)&Assoc Mask %if Key = 0 {strongly associative} %or %c (Key = Weak Assoc {weakly associative} %and Oper = Op) %start %if Rhs_Base = 0 %or Oper = ADDX %start Constant Operation(Oper, W_Disp, Rhs) Reduce Constant %if Rhs_Base = 0 ->Mon %finish %finish %if Op = ADDx %and Oper = MULx %start { (A+c)*m -> Am+cm } W_Disp = W_Disp*Rhs_Disp Lhs_Link == Null; Lhs_Oper = 0 Operate(MULx, Lhs, Rhs) Operate(ADDx, Lhs, W) %return %finish %finish %finish Loadup(Lhs) {no other choice} %finish %if Const(Lhs)#0 %and Rconst # 0 %start Constant Operation(Oper, Lhs_Disp, Rhs) ->Mon %finish %if Lhs_Type >= Reals %or Rhs_Type >= Reals %start Oper = Oper+Real Shift %unless Oper >= RNEGx %finish %else %if Rhs_Form = VinR %and Rhs_A_Scale = 0 %and %c (Oper = ADDx %or Oper = SUBx) %start %if Lhs_Form = VinR %and Lhs_A_Scale = 0 %and Lhs_Area = 0 %start N = Rhs_Disp; Rhs_Disp = 0 N = -N %if Oper = SUBx N = N+Lhs_Disp %if Rhs_Base = 0 %start Lhs_Area = Rhs_Area Drop(Rhs) %finish %else %start Lhs_Disp = 0 Lhs_Oper = Oper; Lhs_Link == Rhs; Loadup(Lhs) %finish Lhs_Disp = N ->Mon %finish %finish %if Rflags&Commutative # 0 %and InReg(Rhs)#0 %start Swop Rconst = 0 Rconst = 1 %if Const(Rhs)#0 %finish Lhs_Oper = Oper; Lhs_Link == Rhs Reduce Constant %if Rconst # 0 Mon: Monitor(Lhs, "Operate") %if Diag&MonOperate # 0 %end %routine Modulus Loadup(Stack); Protect(Stack) %if Floating(Stack)#0 %start Plant1(ABSF, Stack) %finish %else %start Test Zero(Stack) Cword(8_002001) {BGE_.+1} Plant1(NEGX, Stack) %finish %end %routine Aop Array Access Stack_A_Flags = Stack_A_Flags&(\Indirect) Stack_A_Flags = Stack_A_Flags!Arrayname %end {***Register optimisation routines***} {%predicate} %integerfn Memorable(%record(Stackfm)%name V, %record(Datafm)%name K) %integer F %result=0 %if V_Oper # 0 %if V_Form = VinR %start %if V_Base = 0 %start {constant} F = 0 %finish %else %if V_Disp # 0 %start {address of variable} F = 1 %finish %else %result=0 %finish %else %if V_Form = VinS %start {variable direct} F = 2 %finish %else %if V_Form = VinX %start {variable indirect/record direct} F = 3 {indirect} F = 5 %if V_Disp # 0 {direct} %finish %else %start {record indirect} F = 6 %finish K_V = V_V K_V_Form = F K_A = V_A %result=-1 %end %routine Optimise(%record(Stackfm)%name V, %integer Mode) {Mode = 0 if destination (address) wanted} { = 1 if source (value) wanted} %record(Datafm)%name P %record(Datafm) M %record(stackfm)%name W %integer F, Bias, Op %routine Set(%integer Form) Release(V_Base); Release(V_A_Base) V_Data = 0 V_Type = P_V_Type V_Form = Form %if Form = VinR %start V_Type = Integers %if V_Type = Bytes V_Type = Lreals %if V_Type = Reals %finish V_Disp = 0 V_Bias = Bias V_Base = P_Reg; Claim(V_Base) Monitor(V, "Opt'd") %if Diag&MonOpt # 0 %end Monitor(V, "Opt") %if Diag&MonOpt # 0 Bias = V_Bias P == Knowing; %return %if P == Null {nothing known} %if V_Oper # 0 %start Op = V_Oper; V_Oper = 0 W == V_Link; V_Link == Null Optimise(V, Mode); Optimise(W, Mode) %unless W == Null V_Oper = Op; V_Link == W %return %finish %return %unless Memorable(V, M)#0 {worth looking for?} %cycle %if P_V_Disp = M_V_Disp %and P_V_Base = M_V_Base %and %c P_V_Type = M_V_Type %and P_V_Area = M_V_Area %and %c P_V_Extra = M_V_Extra %and P_A_Scale = M_A_Scale %start {Basically ok, now check for arrays} %if M_A_Scale # 0 %start {an array index wanted} %if P_A_Base = M_A_Base %and P_A_Area = M_A_Area %and %c P_A_Form = M_A_Form %and P_A_Extra = M_A_Extra %and %c P_V_Form = M_V_Form %start %if Mode # 0 %start %if P_A_Type # Alhs %and P_A_Disp = M_A_Disp %start Set VinR: Set(VinR) %return %finish %finish %else %if P_A_Type = Alhs %start %if M_A_Form = VinS %or M_A_Form = VinX %start Bias = Bias+M_A_Disp; M_A_Disp = 0 ->Set VinR %finish %else %if M_A_Disp = P_A_Disp %start ->Set VinR %finish %finish %finish %finish %else %start F = P_V_Form %if F = M_V_Form %and Mode # 0 %start {exact match} ->Set VinR %finish %else %if F+1 = M_V_Form %start {address in register} Set(VinS) Optimise(V, Mode) %if Mode # 0 %return %finish %finish %finish P == P_Link %repeat %until P == Null %end {%record(Datafm)%map} %integerfn NewK %record(Datafm)%name P P == Kasl_Link %if P ## Null %start Kasl_Link == P_Link Ktail == Kasl %if Kasl_Link == Null P_Label = 0 {invalidate any environment information} %finish %result = Addr(P) %end %routine Forget Everything %record(Datafm)%name K K == Knowing %if K ## Null %start K == K_Link %while K_Link ## Null Ktail_Link == Knowing Ktail == K Knowing == Null %finish Used(R0) = 0; Used(R1) = 0; Used(R2) = 0; Used(R3) = 0 Ktimes(R0) = 0; Ktimes(R1) = 0; Ktimes(R2) = 0; Ktimes(R3) = 0 Used(F0) = 0; Used(F1) = 0; Used(F2) = 0; Used(F3) = 0 Ktimes(F0) = 0; Ktimes(F1) = 0; Ktimes(F2) = 0; Ktimes(F3) = 0 Cc1_Cc Ca = -1; Cc2_Cc Ca = -1; Z Ca = -1 Ktimes(Cc Lhs) = 0; Ktimes(Cc Rhs) = 0 %end %routine IncK(%integer R) Ktimes(R) = Ktimes(R)+1 %if R&128 = 0 %end %routine Kinc(%record(Datafm)%name K) IncK(K_Reg) IncK(K_V_Base) IncK(K_A_Base) %end %routine DecK(%integer R) Ktimes(R) = Ktimes(R)-1 %if R&128 = 0 %end %routine Kdec(%record(Datafm)%name K) DecK(K_Reg) DecK(K_V_Base) DecK(K_A_Base) %end %routine Forget(%integer Register) %integername N %record(Datafm)%name K, R Fail("Forget") %unless R0 <= Register <= AnyF N == Ktimes(Register) Used(Register) = 0 %return %if N = 0 %or Activity(Register) < 0 K == Knowing; Knowing == Null %while K ## Null %cycle R == K; K == K_Link %if R_Reg = Register %or R_V_Base = Register %or %c R_A_Base = Register %start Ktail_Link == R Ktail == R Ktail_Link == Null Kdec(R) Mon Regid(Register, "Lost") %if Diag&MonOpt # 0 %finish %else %start R_Link == Knowing; Knowing == R {retain it} %finish %repeat Fail("Still known") %if N # 0 %end %routine Inherit(%integer New, Old) %record(Datafm)%name P, K, X %return %if New = Old Used(New) = Ca P == Knowing %while P ## Null %cycle K == P; P == K_Link %if K_Reg = Old %start X == Record(NewK); %return %if X == Null X = K X_Reg = New X_Link == Knowing; Knowing == X Kinc(X) %finish %repeat %end %routine Promote(%integer Reg) %record(Datafm)%name Front, Back, Next %record(Datafm) D Back == Null Front == D %while Knowing ## Null %cycle Next == Knowing_Link %if Knowing_Reg # Reg %start Knowing_Link == Back Back == Knowing %finish %else %start Front_Link == Knowing Front == Knowing %finish Knowing == Next %repeat Front_Link == Back Knowing == D_Link Display Knowledge %if Diag&MonOpt # 0 %end %routine Remember(%integer Register, %record(Stackfm)%name V) %record(Datafm)%name K %record(Datafm) M %return %unless R0 <= Register <= F3 Used(Register) = Ca %if InReg(V)#0 %start {inherit other register's data} Inherit(Register, V_Base) %return %finish %return %if Register = V_Base %or Register = V_A_Base %if Memorable(V, M)#0 %start K == Record(NewK); %return %if K == Null K = M K_Reg = Register K_Link == Knowing; Knowing == K Kinc(K) Monitor(V, "Remember ".Regid(Register)) %if Diag&MonOpt # 0 %finish %end %routine Forget Destination(%record(Stackfm)%name V) %integer Low, High %record(Datafm)%name P, K {%predicate} %integerfn Dangerous %if V_Form >= VinX %start %result=-1 %if Control&Trusted # 0 %result=0 %finish %if V_A_Scale # 0 %start {array element altered} %if K_V_Format # 0 %start {array address known} %result=0 %if Control&Trusted = 0 {not always safe!} %result=-1 %if 1 <= K_A_Base <= 127 %or {unknown array base} %c 1 <= V_A_Base <= 127 {unknown altered base} %finish %result=-1 %if K_A_Form = 3 {indirect} %result=-1 %if 0 < K_V_Base < 128 {unknown base} %result=0 %finish %if K_V_Format # 0 %start {array element known} %result=-1 %if Control&Trusted # 0 %and %c 1 <= V_Base <= 127 {unknown base altered} %result=-1 %if K_V_Base = V_Base %and {index altered} %c Low <= K_V_Disp < High %and %c K_V_Area = V_Area %result=-1 %if K_A_Base = V_Base %and {arrayname altered} %c Low <= K_A_Disp < High %and %c K_A_Area = V_Area %finish %else %if K_V_Form = 1 %start {address} %result=-1 %if Control&Trusted # 0 %and %c 1 <= K_V_Base <= 127 {unknown base} %finish %else %if K_V_Form = 2 %start {direct reference} %result=-1 %if Control&Trusted # 0 %and %c (1 <= K_V_Base <= 127 %or {unknown base} %c 1 <= V_Base <= 127) {unknown base altered} %result=-1 %if K_V_Base = V_Base %and {direct hit} %c Low <= K_V_Disp < High %and %c K_V_Area = V_Area %finish %else %if K_V_Form = 3 %start {indirect reference} %result=-1 %unless Control&Trusted = 0 %result=-1 %if K_V_Base = V_Base %and {direct hit} %c Low <= K_V_Disp < High %and %c K_V_Area = V_Area %finish %result=0 %end Monitor(V, "Forget Dest") %if Diag&MonOpt # 0 %return %if V_Base = Ds %if InReg(V)#0 %start Forget(V_Base) %return %finish Low = V_Disp; High = Low+Item Size(V_Format) P == Knowing; Knowing == Null %while P ## Null %cycle K == P; P == P_Link %if Dangerous#0 %start Kdec(K) Ktail_Link == K Ktail == K Ktail_Link == Null Mon Regid(K_Reg, "Lost") %if Diag&MonOpt # 0 %finish %else %start K_Link == Knowing; Knowing == K {remember it} %finish %repeat %end {Environment handling} %routine Remember Environment(%integer Label) %record(Datafm)%name K, Top Top == Null %if Kasl_Link ## Null %start K == Knowing %while K ## Null %cycle %routine Add(%record(Datafm)%name K) %record(Datafm)%name P P == Record(NewK) {cannot return Null} %if Top == Null %start Top == P %finish %else %if Top == P %start Top == Kasl_Link %finish P = K P_Link == Null P_Label = Label Ktail_Link == P Ktail == P Mon RegId(P_Reg, "in env") %if Diag&MonOpt # 0 %end Add(K) K == K_Link {onto the next item} %repeat CC1_Reg = Cc Rhs %and Add(Cc1_Data) %if Cc1_Cc Ca = Ca CC2_Reg = Cc Lhs %and Add(Cc2_Data) %if Cc2_Cc Ca = Ca %finish Env(Label)_E == Top {remember the start} %end %routine Merge Environment(%integer Label) {Update the saved environment of Label with the data in Knowing} {Knowing is unaltered} %record(Datafm)%name P, K, Next, Top, First Monitor(Null, "Merge") %if Diag&MonOpt # 0 Top == Null; First == Null %if Knowing ## Null %start Next == Env(Label)_E %cycle P == Next; %exit %if P == Null %or P == First %or P_Label # Label Next == P_Link P_Label = 0 K == Knowing %cycle %if K_Reg = P_Reg %and %c K_V_Disp = P_V_Disp %and K_V_Base = P_V_Base %and %c K_V_Type = P_V_Type %and K_V_Area = P_V_Area %and %c K_V_Form = P_V_Form %and K_V_Extra = P_V_Extra %and %c K_A_Disp = P_A_Disp %and K_A_Base = P_A_Base %and %c K_A_Extra = P_A_Extra %and K_A_Scale = P_A_Scale %and %c K_A_Type = P_A_Type %and %c K_A_Area = P_A_Area %and K_A_Form = P_A_Form %start K == Record(NewK) First == K %if First == Null %if Top == Null %start Top == K %finish %else %if Top == K %start Top == Kasl_Link %finish K = P K_Link == Null K_Label = Label Ktail_Link == K Ktail == K Mon RegId(K_Reg, "Merged") %if Diag&MonOpt # 0 %exit %finish K == K_Link %repeat %until K == Null %repeat %finish Env(Label)_E == Top %end %routine Restore Environment(%integer Label) {a little care is needed here in case the environment has} {migrated to the top of the asl} %record(Datafm)%name P, K, Next Forget Everything {dispose of old knowledge} Next == Env(Label)_E %cycle P == Next; %return %if P == Null %or P_Label # Label Next == P_Link %if P_Reg >= Cc Lhs %start %if P_Reg = Cc Lhs %start Cc1_Data = P; Cc1_Cc Ca = Ca %finish %else %start Cc2_Data = P; Cc2_Cc Ca = Ca %finish %finish %else %start K == Record(NewK) K = P K_Link == Knowing; Knowing == K Kinc(K) %finish Mon RegId(P_Reg, "Back") %if Diag&MonOpt # 0 %repeat %end %routine Forget Environment(%integer Label) Env(Label)_E == Null %end {Testing Predicates} {%predicate} %integerfn InReg(%record(Stackfm)%name V) %result=0 %if V_Form # VinR %or %c V_Disp # 0 %or %c V_Base = 0 %or %c V_Area # 0 %or %c V_Oper # 0 %or %c V_A_Scale # 0 %result=-1 %end {%predicate} %integerfn Floating(%record(Stackfm)%name V) %result=-1 %if Reals <= V_Type <= Lreals %or V_Oper >= RNEGx %result=0 %end {%predicate} %integerfn Same(%record(Stackfm)%name A, B) %result=0 %if A == Null %or B == Null %result=0 %if A_Disp # B_Disp %or %c A_Base # B_Base %or %c A_Form # B_Form %or %c A_Extra # B_Extra %or %c A_Type # B_Type %or %c A_Area # B_Area %or %c A_A_Format # B_A_Format %result=-1 %if A_A_Format = 0 %result=0 %if A_A_Disp # B_A_Disp %or %c A_A_Base # B_A_Base %or %c A_A_Area # B_A_Area %or %c A_A_Form # B_A_Form %or %c A_A_Extra # B_A_Extra %or %c A_Bias # B_Bias %result=-1 %end {%predicate} %integerfn Const(%record(Stackfm)%name V) %result=0 %if V_Form # VinR %or V_Base # 0 %or %c V_Type # Integers %or %c V_Area # 0 %or %c V_Oper # 0 %or %c V_A_Scale # 0 %result=-1 %end %integerfn Power(%integer N) %integer P, Mask %result = -1 %if N > ( \( (-1)>>1 ) )>>1 {Beware x'4001' etc.} Mask = 1 P = 0 %cycle %result = P %if Mask = N %result = -1 %if Mask > N Mask = Mask<<1 P = P+1 %repeat %end %integerfn Item Size(%integer F) %result = F %if F >= 0 %result = Var(-F)_Format %end {Register Control} %routine Claim(%integer Register) %return %unless R0 <= Register <= F3 %and Activity(Register) >= 0 Activity(Register) = Activity(Register)+1 Active Registers = Active Registers+1 Used(Register) = Ca Monitor Register(Register, "Claimed") %if Diag&MonReg # 0 %end %routine Release(%integer Register) %return %unless R0 <= Register <= F3 %and Activity(Register) >= 0 Monitor Register(Register, "Release") %if Diag&MonReg # 0 Activity(Register) = Activity(Register)-1 Fail("Not claimed") %if Activity(Register) < 0 Active Registers = Active Registers-1 %end %routine Release and Drop(%record(Stackfm)%name V) Release and Drop(V_Link) %unless V_Link == Null Release(V_Base); Release(V_A_Base) Drop(V) %end %routine Release and Clear(%record(Stackfm)%name V) Release(V_Base) V_Base = 0 %end %routine Hazard(%integer Register) %record(Stackfm)%name U %integer T, Ar %integername N Monitor Register(Register, "Hazard") %if Diag&MonReg # 0 %routine Set(%record(stackfm)%name V, %integer New) V_Base = Local V_Flags = V_Flags!Hazarded %if V_Form = VinS %start V_Extra = New V_Form = VinX %finish %else %if V_Form = VinX %start V_Form = AinX V_Disp = V_Extra V_Extra = New %finish %else %if V_Form = VinR %start %if V_Disp # 0 %start V_Extra = New V_Form = VinX Amap(V) %finish %else %start V_Disp = New V_Form = VinS %finish %finish %end %routine Simplify(%record(Stackfm)%name V) %integer Op Op = V_Oper V_Oper = 0 Address(V, 0) V_Oper = Op %end N == Activity(Register); %return %if N <= 0 T = (Frame+Alignment)&(\Alignment) Frame = T+Word Length {assume integer} Ar = Actual(Register)<<6 %if Register >= F0 %start {it's real} Frame = Frame+Word Length*3 {longreal temp} Set Mode(Lreals) Plant(8_174064+Ar, Test Single) %finish %else %start Plant(8_010064+Ar, Test Single) %finish Plant(T, 0) Attributes = Attributes!Attr Uses Locals U == Using %while U ## Null %cycle %if U_A_Scale # 0 %start Simplify(U) U == Using %continue %finish %if U_Base = Register %start %if U_Form = AinX %or (U_Form = VinX %and U_Disp # 0) %start Simplify(U) U == Using %continue %finish Set(U, T) Active Registers = Active Registers-1 N = N-1 %finish U == U_Using %repeat Fail("Use lost") %if N # 0 %end %routine Hazard All %while Active Registers # 0 %cycle Hazard(R0); Hazard(R1); Hazard(R2); Hazard(R3) Hazard(F0); Hazard(F1); Hazard(F2); Hazard(F3) %repeat %end {%record(Stackfm)%map} %integerfn Register(%integer Reg) %record(Stackfm)%name R R == Record(Descriptor) %if Reg <= AnyG %then R_Type = Integers %else R_Type = Lreals R_Base = Reg %result = Addr(R) %end %integerfn Cheapest(%integer Base) %integer R %integer Min Activity, Min Known, Min Reg, {default to R3 or F3} Oldest Min Activity = 1000 Min Known = 1000 Min Reg = Base+3 Oldest = Ca %for R = Base, 1, Base+3 %cycle %if Activity(R) = Min Activity %start %if Min Known > Ktimes(R) %start Min Reg = R Min Known = Ktimes(R) Oldest = Used(R) %finish %else %if Min Known = Ktimes(R) %start %if Oldest > Used(R) %start Min Reg = R Oldest = Used(R) %finish %finish %finish %else %if Activity(R) < Min Activity %start Min Activity = Activity(R) Min Reg = R Min Known = Ktimes(R) Oldest = Used(R) %finish %repeat Used(Min Reg) = Ca %result = Min Reg %end %integerfn Spare Register %result = R0 %if Activity(R0) = 0 %and Ktimes(R0) = 0 %result = R1 %if ACtivity(R1) = 0 %and Ktimes(R1) = 0 %result = R2 %if Activity(R2) = 0 %and Ktimes(R2) = 0 %result = r3 %if Activity(R3) = 0 %and Ktimes(R3) = 0 %result = 0 %end %integerfn Gpr %result = Cheapest(R0) %end %integerfn Fpr %result = Cheapest(F0) %end {Descriptor Control} {%record(Stackfm)%map} %integerfn Descriptor %record(Stackfm)%name V Fail("Descriptors") %if Dasl == Null V == Dasl; Dasl == V_Using V = 0 V_Using == Using; Using == V Monitor(Null, "Descriptor") %if Diag&MonStack # 0 %result = Addr(V) %end %routine Drop(%record(Stackfm)%name V) %record(Stackfm)%name P, E Monitor(V, "Drop") %if Diag&MonStack # 0 %if V_Flags&In Work # 0 %start {release string workspace} Ds Bias = Ds Bias-256 Fail("String") %if DsBias < 0 %finish %if Using == V %start {first is quick} Using == V_Using %finish %else %start {otherwise search for it} P == Using %cycle Fail("Not in use") %if P == Null E == P P == P_Using %repeat %until P == V E_Using == P_Using %finish V_Using == Dasl; Dasl == V %end %routine Pop Release and Drop %record(Stackfm)%name S S == Stack Stack == S_Stack Release and Drop(S) %end {%record(Stackfm)%map} %integerfn Literal(%integer N) %record(Stackfm)%name V V == Record(Descriptor) V_Disp = N V_Type = Integers %result = Addr(V) %end {%record(Stackfm)%map} %integerfn Temporary %record(Stackfm)%name T Frame = (Frame+Alignment)&(\Alignment) T == Record(Literal(Frame)) Frame = Frame+Word Length T_Base = Local T_Form = VinS %result = Addr(T) %end {%record(Stackfm)%map} %integerfn Copy(%record(Stackfm)%name V) %record(Stackfm)%name C %result = Addr(Null) %if V == Null C == Record(Descriptor) C_Data = V_Data; Claim(C_Base); Claim(C_A_Base) C_Oper = V_Oper C_Link == Record(Copy(V_Link)) %unless V_Link == Null %result = Addr(C) %end {Stack control} %routine Stack Var(%integer Varno) %record(Stackfm)%name V V == Record(Descriptor) V_V = Var(Varno) V_Stack == Stack Stack == V %if V_Form = VinX %or V_Form = AinX %start V_Extra = V_Disp; V_Disp = 0 %finish %if V_Form = Proc %and Pending # 'p' %start V_Bias = Ds Bias Advance Ds %finish Monitor(V, "Stack Var") %if Diag&MonStack # 0 %end %routine Select(%integer Item) %integer X %record(Stackfm)%name V, Sub V == Stack X = Var(-V_Format)_Extra-Item Reduce Array(V) %if V_A_Scale # 0 Stack Var(X) Sub == Stack; Stack == Stack_Stack Fail("Select") %if V_Form = VinR Reduce(V) %if V_Form = AinX %if V_Form = VinS %start %if Sub_Form = VinS %start V_Disp = V_Disp+Sub_Disp %finish %else %start V_Form = VinX V_Extra = V_Disp+Sub_Extra V_Disp = 0 %finish %finish %else %start {VinX} %if Sub_Form = VinS %start V_Disp = V_Disp+Sub_Disp %finish %else %start V_Form = AinX V_Disp = V_Disp+Sub_Extra %finish %finish V_Format = Sub_Format V_Type = Sub_Type V_Flags = Sub_Flags Monitor(V, "Select") %if Diag&MonStack # 0 Drop(Sub) %end %routine Stack Integer(%integer N) %record(Stackfm)%name V V == Record(Literal(N)) V_Stack == Stack Stack == V %end %integerfn Popped Value %record(Stackfm)%name V V == Stack Stack == V_Stack Drop(V) %result = V_Disp %end {Label & Jump Handling} %integerfn New Label Free Label = Free Label+1 %result = Free Label %end %routine Jump to(%integer Internal Label, Cond Code) %record(Stackfm) Z Jlab = Internal Label {remember for Events} Cond Code = Reverse(Cond Code) %and Invert = 0 %if Invert # 0 %if Cond Code = Always %then Dcode(Dir Ujump) %c %else Dcode(Dir Cjump) Put with Ca(Internal Label) Ocode(Obj Jump); Printch(Cond Code+Unsigned); Unsigned = 0 %if Z Ca = Ca %and Cond Code = NE %start {zero known} Z = 0 Z_Type = Integers Remember(Z Reg, Z) %finish Ca = Ca+2 {assume 2 bytes worth} Cc1_Cc Ca = Cc1_Cc Ca+2 Cc2_Cc Ca = Cc2_Cc Ca+2 Uncond Jump = Ca %if Cond Code = Always {can't get past here} %end %routine Define Label(%integer Internal Label) Dcode(Dir Label); Put with Ca(Internal Label) Ocode(Obj Label); Put(Internal Label) Uncond Jump = -1 {can get here now} %end %routine Define Compiler Label(%integer Label) %integername L L == Ilabel(Label) %if L&Defined # 0 %start {redefinition} Forget Environment(Label) L = New Label %finish L = L!Defined {show it's defined} Merge Environment(Label) %if Uncond Jump # Ca Define Label(L&Label Mask) Restore Environment(Label) %end %routine Jump Forward(%integer Label, Cond Code) %integername L L == Ilabel(Label) %if L&Defined # 0 %start {redefine it} L = New Label Remember Environment(Label) %finish %else %start {another reference} Merge Environment(Label) %finish Jump To(L, Cond Code) %end %routine Jump Backward(%integer Label) %record(Stackfm) C, F %record(Forfm)%name For %integername L %integer How L == Ilabel(Label) How = Always Fail("Label missing") %if L&Defined = 0 %if Forp # 0 %start For == Fors(Forp) %if Label = For_Label %start {repeat of a %for statement} C_Data = For_Control Load(C, For_Reg) Define Compiler Label(For_Entry) %if For_Entry # 0 F_Data = For_Final Compare(F, C) Release(For_Reg) How = NE Forp = Forp-1 %finish %finish Jump To(L&Label Mask, How) %end %routine Set User Label(%integer Label) %record(Varfm)%name V V == Var(Label) Clear Vars(Label) V_Type = Labels V_Disp = New Label %end %routine User Jump(%integer Label) %record(Varfm)%name V V == Var(Label) Set User Label(Label) %if Label > Vars {not yet allocated a var} Jump To(V_Disp, Always) %end %routine Define User Label(%integer Label) %record(Varfm)%name V V == Var(Label) Set User Label(Label) %if Label > Vars {not yet allocated a var} Define Label(V_Disp) Forget Everything %end %routine Return(%integer How) %record(Stackfm)%name V %if Uncond Jump = Ca %start Pop Release and Drop %if How # 0 %return %finish %if How = True %start Plant0(SEC) %finish %else %if How = False %start Plant0(CLC) %finish %else %if How # 0 %start V == Stack; Stack == Stack_Stack Loadup(V) %if V_Type = Strings %and V_Oper # 0 Amap(V) %if How = Map Load(V, Result Reg) Release and Drop(V) %finish Dcode(Dir Return); Put with Ca(0) Ocode(Obj Return) Ca = Ca+2 {assume two bytes} Uncond Jump = Ca {Can't get past here} Open = 0 {the procedure returns} %end %routine Compile For(%integer Repeat Label) %integer Type %record(Stackfm)%name Initial, {initial value} Final, {final value} Inc, {increment} Control, {control variable} Increment, {copy of increment} C {copy of control} %record(Forfm)%name For %routine Stab(%record(Stackfm)%name V) %record(Stackfm)%name T %return %if Const(V)#0 T == Record(Temporary) T_Base = Local; T_Form = VinS Store(T, V) Replace(V, T) Drop(T) %end %integerfn Loop Type %integer I, N %result = 1 %unless Const(Initial)#0 %and Const(Inc)#0 %c %and Const(Final)#0 I = Inc_Disp %if I # 0 %start N = Final_Disp-Initial_Disp+I %result = 1 %if N = 0 {zero iterations?} %result = 0 %if N!!I >= 0 %and N-N//I*I = 0 %finish %else I = 1 Warn("Non-integral %for loop") Final_Disp = Initial_Disp+N//I*I %result = 1 %end Initial == Stack Final == Initial_Stack Inc == Final_Stack Control == Inc_Stack Stack == Control_Stack Stab(Inc) Stab(Final) %unless Control_Form = VinS %and Control_A_Scale = 0 %and %c (Control_Base = 0 %or Control_Base = Local) %start {protect expensive (i.e. non-local) or moveable control variable} Type = Control_Type Amap(Control); Stab(Control) {save its address} Vmap(Control, Type) %finish Fail("Fors nested too deeply") %if Forp = Max Fors Forp = Forp+1; For == Fors(Forp) For_Label = Repeat Label For_Control = Control_Data For_Final = Final_Data For_Entry = Loop Type {and check on the fly} Increment == Record(Copy(Inc)) {beware of corruption in operate} Operate(SUBX, Initial, Inc) Loadup(Initial) For_Reg = Initial_Base %if For_Entry # 0 %start {may never execute the loop} C == Record(Copy(Control)) Store(C, Initial) Drop(C) For_Entry = Repeat Label+2 Jump Forward(For_Entry, Always) %finish Define Compiler Label(Repeat Label) Operate(ADDX, Initial, Increment) Store(Control, Initial) Release and Drop(Control) Release and Drop(Initial) Release and Drop(Final) %end %routine Call External(%integer N) Cword(8_004737); Plant(0, N) {JSR_Pc,@#0} %end %routine Perm(%integer N) %integername P %record(Varfm) V %integer For For = N&Pall; N = N&255 Fail("Perm ") %unless Signal&255 <= N <= ShiftR&255 %if Diag&MonOperate # 0 %start Select Output(0) Printstring("Perm "); Printstring(PermId(N)); Newline Select Output(Obj) %finish P == Perm Used(N) %if P = 0 %start {first use} External Id = Perm Id(N) Dump External(Dir Notex, V) P = V_Area %finish Call External(P) Forget(R0) %if For&Pr0 = 0 Forget(R1) %if For&Pr1 = 0 Forget(R2) %if For&Pr2 = 0 Forget(R3) %if For&Pr3 = 0 %end %routine Perm Operation(%integer Oper, %record(Stackfm)%name A, B) %if Oper = REXPx %start Load(A, F0) Load(B, R2) %finish %else %start Load Pair(A, B) %finish Release(A_Base) Release(B_Base) Perm(Perm Op(Oper)) Claim(A_Base) %end %routine Compile Tostring %record(Stackfm)%name W, One %if Pending = '.' %start loadup(stack) %if stack_oper # 0 %return %finish %if Const(Stack) # 0 %start String Value = Tostring(Stack_Disp) Select Constant Area Stack_Disp = Ca Stack_Area = Constant Area Dump Text(1) Select Code Area %finish %else %start W == Record(Temporary) W_Type = Bytes W_Disp = W_Disp+1 Move(Stack, W) One == Record(Literal(1)) W_Disp = W_Disp - 1 Plant2(Movb, One, W); Drop(One) Replace(Stack, W) Drop(W) %finish Stack_Form = VinS Stack_Type = Strings; Stack_Format = 2 %end %routine Special Call(%integer N) %switch Sp(1:19) %record(Stackfm)%name V V == Stack %constbytearray Type Map(3:8) = Strings, Integers, Bytes, Reals, Lreals, Records %constbytearray Len Map(3:8) = 0, 2, 1, 2, 4, 0 ->Sp(N) Sp(19): Amap(V); %return {addr} Sp(1): {Readch} Sp(2):Hazard All; Attributes = Attributes ! Attr Dynamic Perm(Getch) {Getch} V == Record(Register(R2)); Claim(R2) V_Stack == Stack; Stack == V Compile Tostring %if Stack_Stack_Type = Strings Assign(Equals) %return Sp(3): {string} Sp(4): {integer, shortinteger, integer} Sp(5): {byteinteger, byte} Sp(6): {real} Sp(7): {longreal, long} Sp(8): Vmap(V, Type Map(N)) {record} V_Format = Len Map(N) %return Sp(9): Stack == Stack_Stack {rem} Operate(REMx, Stack, V) %return Sp(11): Amap(V) {length} Vmap(V, Bytes) V_Flags = V_Flags!Safe Byte %if 1 <= V_Format-1 <= 127 %return Sp(12): Stack == Stack_Stack {charno} Amap(Stack) Operate(ADDx, Stack, V) Vmap(Stack, Bytes) %return Sp(13): Stack Integer(Nl) {snl} Sp(14): Compile Tostring; %return {tostring} Sp(15): {sizeof} Sp(16): %if V_Type = Generals %start {typeof} Amap(V) V_Disp = V_Disp+(N-14)*2 {} %finish %else %start %if N = 15 {sizeof} %start N = Item Size(V_Format) %if N = 1 %and V_Type = Strings %start V_Type = Integers V_Form = VinS V_Disp = V_Disp+2 %return %finish %finish %else %start N = Type Code(V_Type) %finish Release(V_Base); Release(V_A_Base) V_Data = 0 V_Disp = N V_Type = Integers %finish Sp(17): %return {intpt} Sp(18): Load(V, AnyF) {int} Cword(8_172027+Actual(V_Base)<<6) {ADDF_V,0.5} Cword(8_040000) Forget(V_Base) %end %routine Pick Params(%record(Stackfm)%name P) %return %if P == Null Optimise(P, 1) Pick Params(P_Params) %end %routine Load Params(%record(Stackfm)%name P) %record(Stackfm)%name W %integer Reg %return %if P == Null W == P_Params; Reg = P_Preg Load(P, Reg) %if Activity(Reg) = 0 Load Params(W) Load(P, Reg) Release and Drop(P) %end %routine Call %record(Stackfm)%name V, R %integer Dir, Ep %integerfn Can Save R1 %record(Stackfm)%name W %result = 0 %if V_Flags&Simple P = 0 %or Activity(R1) # 1 W == Using %cycle %result = 0 %if W == Null %exit %if W_Base = R1 %and W_Form = VinR %and W_Disp = 0 W == W_Using %repeat W_Base = DS; W_Form = Adec Release(R1) %result =-1 %end V == Stack Stack == Stack_Stack %if V_Flags&Primitive # 0 %start Special Call(V_Disp) Drop(V) %return %finish %routine Prefix Parameters(%record(Stackfm)%name W) %integer Z, N, Pass %integername P %record(Varfm)%name Q %return %if W == Null %or V_Flags&(Xproc!Parameter) # 0 Prefix Parameters(W_Params) %if W_Params ## Null %return %if W_Preg = R3 %if Const(W)#0 %and (W_Disp = 1 %or W_Disp = -1) %start W_Oper = ADDx W_Link == Record(Literal(W_Disp)) W_Disp = 0 %finish %if W_Oper = ADDx %and Const(W_Link)#0 %start %if W_Preg = R1 %then N = 0 %else N = 1 Z = W_Link_Disp Q == Var(V_Area) %if N = 0 %then P == Q_Disp %else P == Q_Extra Pass = 0 Pass = 1 %if N = 0 %or Dir = Dir Prefix1 %or Q_Disp = 0 %if P = 0 %start %return %if Q_Extra # 0 %or Pass = 0 P = Z %if Q_Area = 0 %start Free Label = Free Label+3 Q_Area = Free Label %finish Dcode(Dir Entry1+N); Put(Z); Put(V_Disp); Put(Q_Area) Select Output(Obj) %finish %if P = Z %and Pass # 0 %start Drop(W_Link); W_Oper = 0; W_Link == Null Ep = Q_Area-N Dir = Dir Prefix1+N %finish %finish %end Attributes = Attributes!Attr Dynamic Ep = V_Disp Dir = Dir Call Prefix Parameters(V_Params) Pick Params(V_Params) Load Params(V_Params) %unless Can save R1#0 %start Hazard All %finish %else %start Cword(8_010125) %finish %if V_Flags&Xproc # 0 %start {external Call} Call External(Ep) %finish %else %if V_Flags&Parameter # 0 %start {procedure parameter call} %finish %else %start {normal internal call} Dir = Dir+3 %if V_Flags&Closed # 0 {cannot return} Dcode(Dir); Put with Ca(Ep) Ocode(Obj Call) Ca = Ca+2 %finish Retreat Ds(V_Bias) Forget Everything %if V_Flags&Answer # 0 %start {set up result descriptor} R == Record(Literal(0)) R_Type = V_Type R_Format = V_Format %if R_Type >= Reals %then R_Base = F0 %else R_Base = Iresult %if V_Flags&Indirect # 0 %or V_Type = Strings %c %or V_Type = Records %start R_Base = Iresult R_Form = VinS %finish Claim(R_Base) %if V_Flags&Indirect = 0 %and V_Type = Strings %c %and Pending # '?' %c %and Pending # 'S' %c %and Pending # 'p' %start To Work Area(R); Vmap(R, Strings) %finish R_Stack == Stack; Stack == R %finish Uncond Jump = Ca %if V_Flags&Closed # 0 Drop(V) %end %routine Switch Label(%integer Tag) %record(Varfm)%name V %integer X V == Var(Tag) X = V_Extra+Popped Value Dcode(Dir Slab); Put with Ca(X) Ocode(Obj Label); Put(X) Uncond Jump = -1 Forget Everything %end %routine Switch Jump(%integer Tag) %record(Varfm)%name V %record(Stackfm)%name X V == Var(Tag) X == Stack Stack == Stack_Stack Operate(MULx, X, Record(Literal(2))) {index*2} %if Const(X)#0 %start X_Extra = X_Disp+V_Disp %finish %else %start Loadup(X) X_Extra = V_Disp %finish X_Disp = 0 X_Form = VinX X_Area = V_Area Plant1(JMP, X); Release and Drop(X) Uncond Jump = Ca {can't get past} %end %routine Event Trap(%integer Bits) {###################################################} {# Block(......) #} {# ............ #} {# %on EVENT BITS %start #} {# Event Label -> ....... #} {# ....... #} {# %finish #} {# Event Body -> ....... #} {# ....... #} {# %end #} {###################################################} %integer Lab Lab = Tag Frame = (Frame+Alignment)&(\Alignment) Cword(8_010564); Cword(Frame) {MOV_DS,Frame} Jump Forward(Lab, Always) Event Bits = Bits Event Body = Jlab Event Label = New Label Define Label(Event Label) Dcode(Dir McUsed); Put with Ca(Event Label) {force used} Ocode(Obj Dummy) Cword(8_016405); Cword(Frame) {MOV_Frame,DS} Frame = Frame+Word Length Attributes = Attributes!Attr Dynamic!Attr Uses Locals Event Count = Event Count+8 {size of event list} %end %routine Signal Event(%integer Event) %record(Stackfm)%name E, Sub Event, Extra Extra == Stack Sub Event == Extra_Stack Stack == Sub Event_Stack %if Const(Sub Event)#0 %and Const(Extra)#0 %and Extra_Disp = 0 %start Perm(Const Sig) Cword(Sub Event_Disp<<8+Event) Drop(Sub Event); Drop(Extra) %finish %else %start Load Pair(Sub Event, Extra) E == Record(Literal(Event)) Load(E, R0) Release and Drop(E) Release and Drop(Sub Event) Release and Drop(Extra) Perm(Signal) %finish Uncond Jump = Ca Attributes = Attributes!Attr Dynamic %end %routine Operation(%integer Oper) %record(Stackfm)%name V V == Stack Stack == Stack_Stack Operate(Oper, Stack, V) %end %routine Test Zero(%record(Stackfm)%name V) %record(Stackfm)%name W %integer Op Monitor(V, "Tzero") %if Diag&MonCond # 0 %if V_Oper # 0 %start W == V_Link %if (Pending = '=' %or Pending = '#') %and V_Oper = BICx %c %and Const(W)#0 %start W_Disp = \W_Disp V_Oper = 0; V_Link == Null %if V_Type = Integers %then Op = Bit %else Op = Bitb %if Op = Bit %and W_Disp&x'FFFF' = x'8000' %start Test Zero(V) %if Pending = '=' %then Pending = ')' %c %else Pending = '<' %finish %else %start Plant2(Op, V, W) %finish Drop(W) %return %finish Loadup(V) %finish Unsigned = 0 %if V_Type = Bytes %start Unsigned = 10; Op = Tstb %finish %else %if Floating(V)#0 %start Op = TstF %finish %else %start Op = Tst %finish Plant1(Op, V) %if Op = TSTF %start Plant0(Cfcc) %finish %else %if V_Form = VinR %start Z Reg = V_Base Z Ca = Ca %finish %end %routine Test Null(%record(Stackfm)%name V) V == Record(Copy(V)) V_Type = Bytes Test Zero(V) Release and Drop(V) %end %routine Compare Strings(%record(Stackfm)%name Left, Right) %if Left_Oper = 0 = Right_Oper %start %if Right_Format = 1 %and Right_Form = V in S %start {Null string} Test Null(Left) %return %finish %if Left_Format = 1 %and Left_Form = V in S %start {Null string} Test Null(Right) Invert = Invert!!Inverted %return %finish %finish %if Left_Base = R2 %or Right_Base = R1 %start Invert = Invert!!Inverted Load Pair(Right, Left) %finish %else %start Load Pair(Left, Right) %finish Perm(Scomp) %end %routine Compare Bytes(%record(Stackfm)%name L, R) %if R_Type = Bytes %or (Const(R)#0 %and R_Disp>>8 = 0) %start %if InReg(L)#0 %start Invert = Invert!!Inverted Plant2(Cmpb, R, L) %finish %else %start Plant2(Cmpb, L, R) %finish %finish %else %start Load(L, AnyG) Invert = Invert!!Inverted Plant2(Cmp, R, L) %finish Unsigned = 10 %end %routine Compare Reals(%record(Stackfm)%name Left, Right) {Beware: Cmpf is reversed in relation to Cmp} Float(Right, Left) %unless Floating(Right)#0 %if InReg(Left)#0 %start Invert = Invert!!Inverted PlantF(CMPF, Left_Base, Right) %finish %else %start Load(Right, AnyF) PlantF(CMPF,Right_Base, Left) %finish %end %routine Try for Zero(%record(Stackfm)%name V, %integer Mod) %integer Old Old = Pending %if V_Disp-Mod = 0 %start %if Pending = '<' %start {>=1 :: >0} Pending = '(' %finish %else %if Pending = ')' %start {<1 :: <=0} Pending = '>' %finish %finish %else %if V_Disp+Mod = 0 %start %if Pending = '>' %start {<=-1 :: <0} Pending = ')' %finish %else %if Pending = '(' %start {>-1 :: >=0} Pending = '<' %finish %finish V_Disp = 0 %if Pending # Old %end %routine Compare(%record(Stackfm)%name Left, Right) %if Pending Tag # 0 %start %if (Pending # '>' %and Pending # ')') %or %c Right_Disp < 0 %or Const(Right)=0 %start Test Zero(Left) Jump Forward(Pending Tag, LT) %finish %else %start Unsigned = 10 %finish Pending Tag = 0 %finish %if Left_Type = Strings %start Compare Strings(Left, Right) %return %finish %if Const(Right)#0 %start Try for zero(Right, 1) %if Right_Disp = 0 %start Test Zero(Left); %return %finish %finish %else %if Const(Left)#0 %start Try for zero(Left, -1) %if Left_Disp = 0 %start Invert = Invert!!Inverted Test Zero(Right); %return %finish %finish Loadup(Left) %if Left_Oper # 0 Loadup(Right) %if Right_Oper # 0 %if Floating(Left)#0 %start Compare Reals(Left, Right); %return %finish %else %if Floating(Right)#0 %start Invert = Invert!!Inverted Compare Reals(Right, Left); %return %finish %if Left_Type = Bytes %start Compare Bytes(Left, Right); %return %finish %else %if Right_Type = Bytes %start Invert = Invert!!Inverted Compare Bytes(Right, Left); %return %finish %if InReg(Left)#0 %start Invert = Invert!!Inverted Plant2(Cmp, Right, Left) %finish %else %start Plant2(Cmp, Left, Right) %finish %end %routine Compare Values %record(Stackfm)%name L, R R == Stack L == R_Stack; Stack == L_Stack Compare(L, R) Release and Drop(L); Release and Drop(R) %end %routine Compare Double %integer Type %record(Stackfm)%name L, R R == Stack L == R_Stack R_Stack == L_Stack Type = R_Type Loadup(R) %if R_Oper # 0 %or %c (Type <= Lreals %and R_Disp # 0 %and %not Const(R)#0) {beware %if 0 # X&7 # 5} {Note: CMP_X,?&CMP_X,? slower than MOV_X,R&CMP_R&CMP_R} %if Pending = '>' %and L_Disp = 0 %and Const(L)#0 %start {optimise 0<=N<=...} Readch(Pending) Pending Tag = Tag %finish %else %start Compare(L, R) Vmap(R, Strings) %if Type = Strings %finish Release and Drop(L) %end %routine Compare Addresses %record(Stackfm)%name L, R R == Stack L == R_Stack; Stack == L_Stack Amap(L); Amap(R) Compare(L, R) Release and Drop(L); Release and Drop(R) %end %routine Push and Pop %record(Stackfm)%name S S == Stack Stack == S_Stack Push(S) Release and Drop(S) %end %routine Resolve(%integer Flag) {S -> A.(B).C} Attributes = Attributes!Attr Dynamic Stack Integer(0) %if Flag&1 = 0 Push and Pop {A} Push and Pop {B} Stack Integer(0) %if Flag&2 = 0 Push and Pop {C} Push and Pop {S} Perm(Sres) Perm(Resflop) %if Flag&4 = 0 %end %routine Record Assign(%record(Stackfm)%name L, R) %integer LenL, LenR, J, Op, Reg %record(Stackfm)%name N %record(Stackfm) Hold LenL = Item Size(L_Format) LenR = Item Size(R_Format) {note: Var(0)_Format=0 - constants} LenL = LenR %if LenR # 0 %and LenR < LenL Fail("Record(*) = Record(*)") %if LenL = 0 L_Format = LenL Hold_Data = L_Data Loadup(L) %unless l_base = ds %if Const(R)#0 %start {record = 0} Op = 8_005020 {Clr_(L)+ } %finish %else %start Loadup(R); Forget(R_Base) Op = 8_012020+Actual(R_Base)<<6 {Mov_(R)+,(L)+ } %finish Op = Op+Actual(L_Base) Forget Destination(Hold) Forget(L_Base) L_Form = VinS; Forget Destination(L) LenL = LenL>>1 {2 bytes a time} %if LenL > 8 %start {to much to do explicitly} N == Record(Literal(LenL)); Loadup(N) Forget(N_Base) Cword(Op) Reg = Actual(N_Base) %if Control&No Eis = 0 %start Cword(8_077000+2+Reg<<6) {SOB_N,.-2} %finish %else %start Cword(8_005300+Reg) {DEC_N} Cword(8_003000+ (-3)&255) {BGT_.-3} %finish Release and Drop(N) %finish %else %start Cword(Op) %for J = 1, 1, LenL %finish %end %routine String Assign(%record(Stackfm)%name L, R) %record(Stackfm)%name W {%predicate} %integerfn Safe(%record(Stackfm)%name Target, Chain) %result=-1 %if Target_Flags&In Work # 0 %cycle %result=0 %if Same(Target, Chain)#0 %result=-1 %if Chain_Oper = 0 Chain == Chain_Link %repeat %end Forget Destination(L) %if R_Oper # 0 %start {L = X.Y....} W == R_Link %if Safe(L, W)#0 %start {W does not reference L} R_Oper = 0; R_Link == Null String Assign(L, R) %unless Same(L, R)#0 {L = R} L_Flags = L_Flags!In Work L_Oper = CONCX; L_Link == W Loadup(L) L_Flags = L_Flags&(\In Work) %return %finish %finish %if L_Base = Ds %start Load(R, R1) Release and Clear(R) Perm(Spmove); Cword(L_Format-1) %finish %else %if R_FORM = VinS %and R_Format = 1 %start {L = ""} L_Type = Bytes Plant1(Clrb, L) %finish %else %start Load Pair(R, L) Release(L_Base); Release and Clear(R) Perm(Smove) L_Type = Strings; L_Form = VinS; Claim(R2) %finish %end %routine Store(%record(Stackfm)%name L, R) %unless R_Oper = 0 %and Same(L, R)#0 %start %if L_Type = Records %start Record Assign(L, R) %finish %else %if L_Type = Strings %start String Assign(L, R) %finish %else %start Move(R, L) %finish %finish %end %routine Move and Advance(%record(Stackfm)%name L, R) %record(Stackfm)%name Rr Rr == Record(Copy(R)) Store(L, Rr); Release and Drop(Rr) L_Disp = L_Disp+2 %unless L_Form = Ainc R_Disp = R_Disp+2 %end %routine Store Address(%record(Stackfm)%name L, R) %record(Stackfm)%name T %integer Rt %if L_Type = Generals %start Amap(L) Rt = R_Type Amap(R) Move and Advance(L, R) %if Rt = Generals %start Move and Advance(L, R) Move and Advance(L, R) %finish %else %start T == Record(Literal(Item Size(R_Format))) Move and Advance(L, T); Release and Drop(T) T == Record(Literal(Type Code(Rt))) Move and Advance(L, T); Release and Drop(T) %finish %finish %else %if L_Form = Proc %start Fail("Not implemented") %finish %else %if L_Flags&Arrayname # 0 %start Amap(L) Amap(R) Move and Advance(L, R) %if R_Flags&Arrayname # 0 %start Move and Advance(L, R) %finish %else %start T == Record(Literal(0)) Store(L, T); Release and Drop(T) %finish %finish %else %if L_Type = Strings %and L_Format = 1 %start N = R_Format-1 Amap(L) Amap(R) Move and Advance(L, R) %if N = 0 %start Move and Advance(L, R) %finish %else %start T == Record(Literal(N)) Move and Advance(L, T); Release and Drop(T) %finish %finish %else %start Amap(L) Amap(R) Store(L, R) %finish %end %routine Jam Transfer(%record(Stackfm)%name L, R) %integer N, Type %record(Stackfm)%name M Type = L_Type %if Type # Strings %start {just omit the remember} Store(L, R) Forget Destination(L) %finish %else %start N = L_Format-1 {maximum length} %if N <= 0 %start {string(*)%name} M == Record(Copy(L)) Amap (M) M_Disp = M_Disp+2; M_Type = Integers Load Pair(L, R) Load(M, R0); Release and Drop(M) Perm(Sjam2) %finish %else %start Load Pair(L, R) Perm(Sjam1) Cword(N) %finish %finish %end %routine Assign(%integer How) %record(Stackfm)%name L, R R == Stack L == R_Stack; Stack == L_Stack %if Diag&MonMove # 0 %start Monitor(L, "A-L") Monitor(R, "A-R") %finish %if How = Equals %start Store(L, R) %finish %else %if How = EqualsEquals %start Store Address(L, R) %finish %else %start Jam Transfer(L, R) %finish Release and Drop(L); Release and Drop(R) %end %routine Assign Parameter %record(Stackfm)%name P, Rt, V P == Stack; Stack == P_Stack Rt == Stack %if Rt_Flags&Primitive # 0 %start P_Stack == Rt_Stack; Rt_Stack == P %return %finish Rt_Extra = Rt_Extra-1; Stack Var(Rt_Extra) V == Stack; Stack == Stack_Stack %if V_Flags&Parameter # 0 %start {parameter in register} %if V_Form # VinS %start %if P_Oper = CONCx %then Load(P, R3) %c %else Amap(P) %finish Optimise(P, 1) P_Preg = V_Base P_Params == Rt_Params Rt_Params == P Drop(V) %return %finish %if V_Flags&Awanted = 0 %start %if V_Type = Strings %start Load(P, R3) Release and Drop(P) Perm(SpMove) Cword(V_Format) %finish %else %start Store(V, P) Release and Drop(P) %finish %finish %else %start Store Address(V, P) Release and Drop(P) %finish Release and Drop(V) %end %routine Array Access %integer Type, Flags, N %record(Stackfm)%name X, A X == Stack {index value} A == X_Stack {array descriptor} Stack == A_Stack Flags = A_Flags Type = A_Type {type of result} %if A_Oper # 0 %start {final of multi-dimensional} Push(X) {Stack the last one} Release and Drop(X) X == Record(Literal(A_Oper+1)) A_Oper = 0 Amap(A) Load Pair(X, A) Release and Drop(X) Release and Drop(A) Perm(Aref) X == Record(Literal(0)); X_Base = R1; Claim(R1) Vmap(X, Integers) %if Flags&Indirect # 0 {namearray} Vmap(X, Type) %finish %else %start {Single dimensional} Loadup(X) %if X_A_Scale # 0 {simplify index} N = 0 %if X_Oper = ADDx %and X_Link_Form = VinR %start N = X_Link_Disp; X_Link_Disp = 0 %if X_Link_Base = 0 %start Drop(X_Link) X_Oper = 0 X_Link == Null %finish %finish Loadup(X) %if X_Oper # 0 %if X_Form = VinR %start N = N+X_Disp X_Disp = 0 %finish Address(A, 1) %if A_A_Scale # 0 {record arrays?} X_A = A_V X_A_Type = X_Type %if A_Flags & Indirect # 0 %start X_A_Scale = 2 X_A_Scale = 4 %if A_Type = strings %and A_format=1 %finish %else %start X_A_Scale = Item Size(A_Format) %finish X_Bias = N*X_A_Scale X_Type = Type Drop(A) %finish X_Format = A_Format X_Stack == Stack Stack == X %end %routine Array Index Push and Pop Stack_Oper = Stack_Oper+1 {count stacked index values} %end %routine Constant Bounds Vub = Popped Value Vlb = Popped Value %end {%Predicate} %integerfn Alternate format %integer Code %record(Varfm) Dummy Code = Pending; Readch(Pending) %if Code = 'A' %start {Start of alternatives} Assemble(Dummy, -2, Vars, Local, -1) Alt Align = Alt Align!Falign %finish %else %if Code = 'C' %start {Next alternative} Max Frame = Frame %if Frame > Max Frame Frame = Frame Base %finish %else %if Code = 'B' %start {End of alternatives} Frame = Max Frame %if Max Frame > Frame Falign = Alt Align %result=-1 %finish %else %start !#if e(=true) Fail("Format ".ItoS(Code)) !#else(=false) { Fail("Format ".ItoS(Code,1))} !#fi %finish %result=0 %end {Monitoring Control} %routine Set CD(%integer Value, %integername CD) CD = Value&x'3FFF' %if Value&x'C000' = 2<<14 %if CD == Control %and Control&NoEis # 0 %start Oper Flags(MULx) = Oper Flags(MULx)!In Prim Oper Flags(DIVx) = Oper Flags(DIVx)!In Prim Oper Flags(REMx) = Oper Flags(REMx)!In Prim Oper Flags(XORx) = Oper Flags(XORx)!In Prim %finish %end %routine Call Monitor Perm(RtMonitor) Uncond Jump = Ca %end %routine Update Line(%integer This Line) Fail("Stack") %unless Stack == Null Fail("Registers") %unless Active Registers = 0 Fail("Descriptors") %unless Using == Null Fail("Corrupt") %if RegV(AnyG)_Base # AnyG %or %c RegV(AnyF)_Base # AnyF %or %c RegV(Ds) _Base # Ds %or %c RegV(Lnb) _Base # Lnb %or %c RegV(Sp) _Base # Sp %or %c RegV(Pc) _Base # Pc %if This Line # Current Line %start Current Line = This Line Printch(Obj Line); Put(Current Line) %finish Ds Bias = 0 %if Diag&MonLine # 0 %start Select Output(0) Printstring("Line:"); Write(This Line, 1); Newline Select Output(Obj) %finish Display Knowledge %if Diag&MonOpt # 0 %end {Parameter and Format processing} %routine Compile Begin %record(Varfm) B B = 0 {Dummy heading} B_Type = Generals B_Disp = New Label B_Base = 0 {show an internal routine} %if Local # 128 %start {internal} Stack Integer(B_Disp) Call Ostate = 0 %finish %else %start Ostate = External External Id = "%GO" %finish Assemble(B, 0, Vars, Local+1, 0) %end %routine End of Block %if Local # 128 %start {not first (dummy) call} Return(Routine) %if Uncond Jump # Ca %and Avar_Type = Generals %finish %end %routine Terminate Block %integer J %record(Varfm)%name V %if Amode < 0 %start {format - align alternatives} Falign = Alt Align {pass back nested alignment} %if Frame Extra # 0 %and Falign = 0 %start {i byte added at start but not needed} %for J = parms, 1, First Alt %cycle V == Var(J) V_Disp = V_Disp-1 %repeat Max Frame = Max Frame-1 %finish Frame = Max Frame %if Max Frame > Frame %if Amode = -2 %start {end of alternative} Old Frame = Frame {pass it back} %finish %else %start {end of complete format} Frame = (Frame+Alignment)&(\Alignment) {word align formats?} Avar_Format = Frame %finish %finish Frame = Old Frame %end {%Predicate} %integerfn Finish Params %integer J, P, R, A %record(Stackfm)%name S %record(Varfm)%name Ap, Fp Parameter List = 0 {no longer in params or format} %result=-1 %if Amode < 0 {end of format} %if Varbase # Vars %start {parameters given} Frame = (Frame+1) & (\1) P = Parms Avar_Extra = Parms {start of formals+1} %for J = Varbase+1, 1, Vars %cycle Ap == Var(J) {actual} P = 0 %if Ap_Type = 0 %or (Ap_Type # Integers %and Ap_Form = 1) %c %or (Ap_Type = Strings %and Ap_Format = 1) %c %or Ap_Flags&Arrayname # 0 Parms = Parms-1 Fp == Var(Parms) {formal} Fp = Ap Fp_Base = Ds Fp_Disp = 0 Fp_Form = Ainc Fp_Flags = Fp_Flags!Awanted %if Ap_Form # VinS %repeat %if Ap_Type = Strings %and Ap_Form = VinS %c %and Ap_Flags&Array = 0 %start Fp_Form = VinR Fp_Base = R3 Fp_Flags = Fp_Flags!Parameter SpSize = (Ap_Format+1) & (\1) %if Amode = 0 Attributes = Attributes!Attr Dynamic %finish %if P # 0 %and Frame <= 4 %start {pass in registers} Avar_Flags = Avar_Flags!Simple P %if Frame # 0 %and Avar_Area = 0 %start {Beware of specs} Parms = Parms-1; Avar_Area = Parms Var(Parms) = 0 %finish R = R1 A = Attr R1 %for J = Varbase+1, 1, Vars %cycle P = P-1; Fp == Var(P) Fp_Flags = Fp_Flags!Parameter Fp_Base = R Fp_Form = Var(J)_Form Attributes = Attributes!A %if Amode = 0 %start {definition} Stack Var(J) S == Stack; Stack == Stack_Stack %if S_Form = VinX %start S_Form = VinS S_Type = Integers S_Disp = S_Extra S_Extra = 0 %finish S_Format = 0 Remember(R, S) Drop(S) %finish R = R2 A = Attr R2 %repeat %finish %finish %result=-1 %if Amode # 0 {not a definition} Parameter Frame = Frame %result=0 {the body follows} %end %integerfn Tag %integer N Readch(N) N = Pending<<8+N Readch(Pending) %result = N %end %routine Get String(%string(*)%name Text) %string (255) s %integer J Length(S) = Pending %for J = 1, 1, Pending %cycle Readch(Charno(S, J)) %repeat Text <- S Readch(Pending) %end %realfn Real Constant %longreal N, Factor, Base %integer Short %integer J, Q, P N = 0; Factor = 1; Base = 10.0 P = 0 %for J = 1,1,Tag %cycle %if Pending = '.' %start P = 1 %finish %else %if Pending = '_' %start Base = N; N = 0 %finish %else %if Pending = '@' %start Readch(Pending) Short <- Tag !#if e(=true) N = N*Base**Short !#else(=false) { N = N*Base^Short} !#fi %exit %finish %else %start Q = Pending-'0' Q = Q+'0'-'A'+10 %if Q > 9 %if P = 0 %start {no decimal point yet} N = N*Base+Q %finish %else %start Factor = Factor/Base N = N+Q*Factor %finish %finish Readch(Pending) %repeat %if Pending = 'U' %start N = -N Readch(Pending) %finish %result = N %end %integerfn Four Bytes %integer A,B,C,D A = Pending Readch(B); Readch(C); Readch(D) Readch(Pending) %result = ((A<<8+B)<<8+C)<<8+D %end %routine Input Integer Value Constant Type = Integers Integer Value = Four Bytes %if Pending = 'U' %start Integer Value = -Integer Value Readch(Pending) %finish %else %if Pending = '\' %start Integer Value = \Integer Value Readch(Pending) %finish Stack Integer(Integer Value) %unless Pending = 'A' %or Pending = '$' %end %routine Input Real Value Constant Type = Reals Real Value_R = Real Constant %if Pending # 'A' %and Pending # '$' %start Stack Integer(0) Set Real(Stack) %finish %end %routine Set Real(%record(Stackfm)%name V) %if Real Value_R # 0 %start Select Constant Area Word Align V_Form = VinS V_Area = Constant Area V_Disp = Ca V_Type = Reals V_Type = Lreals %if Real Value_W3!Real Value_W4 # 0 Dump Real(V_Type) Select Code Area %finish %end %routine Input String Value Constant Type = Strings Get String(String Value) %if Length(String Value) = 1 %and Pending = '.' %start Stack Integer(Charno(String Value, 1)) %finish %else %if '$' # Pending # 'A' %start {not an own initial value} Select Constant Area Stack Integer(Ca) Stack_Type = Strings Stack_Form = VinS Stack_Area = Constant Area Stack_Format = Length(String Value)+1 Dump Text(0) Select Code Area %finish %end {Var control} %routine Clear Vars(%integer Limit) Fail("Too many objects") %if Limit >= Parms %while Vars < Limit %cycle Vars = Vars+1 Var(Vars) = 0 %repeat %end %routine Dump External(%integer C, %record(Varfm)%name V) %integer D %if C = Dir Notex %start D = External Spec+2 External Spec = D %if V_Form = Proc %then V_Disp = D %c %else V_Area = D %finish %else %start D = V_Disp %finish Dcode(C); Put(D); Put Text(External Id) Select Output(Obj) %end %routine Define Var %integer Decl, Tf, New %integer Spec, Round, Type, {item type} Form, {item form} Format, {Size or format} Dim, Data Size {Size of allocated object} {Decl size is size of actual object} %constbytearray Form Map(0:15) = 0, {Unknown} VinS, {integer} VinX, {integername} 0(4), {label/format/?/switch} Proc(4), {rt/fn/map/pred} VinS, {array} VinX, {arrayname} VinS, {namearray} VinX, {namearrayname} 0 New = 1 Decl = Tag %if Decl # 0 %start {normal item} New = 0 %if Decl <= Vars DefV == Var(Decl); Clear Vars(Decl) %finish %else %start {format item} Parms = Parms-1 DefV == Var(Parms); DefV = 0 %finish Fail("Too many objects") %if Parms <= Vars Internal Id = "" %while Pending # ',' %cycle %if Length(Internal Id) # 15 %start Internal Id = Internal Id.Tostring(Pending) %finish Readch(Pending) %repeat Readch(Pending) {skip comma} Tf = Tag Format = Tag Ostate = Tag Dim = Ostate>>8 Spec = Ostate&8 Ostate = Ostate&7; Ostate = External %if Ostate = Dynamic Type = Tf>>4 Form = Tf&15 %if Alias # "" %start External Id = Alias; Alias = "" %finish %else %start %if Ostate = System %start Ostate = External External Id = "$".Internal Id %finish %else %start External Id = Internal Id %finish %finish Data Size = Word Length; Round = Alignment %if Type = 0 {general} %start Type = Generals Data Size = Word Length*3 DefV_Format = Word Length*3 %finish %else %if Type = 1 {integer} %start Type = Integers %if Format = 2 {byte} %start %if Form # 8 %and (Parameter List <= 0 %or Form # 1) %start {not a function or parameter} Type = Bytes Data Size = 1 Round = 0 %finish %finish DefV_Format = Data Size %finish %else %if Type = 2 {real} %start Type = Reals Type = Lreals %and Data Size = Word Length*2 %if Format = 4 DefV_Format = Data Size %finish %else %if Type = 3 {string} %start Type = Strings Data Size = Format+1 Round = 0 DefV_Format = Data Size %finish %else %if Type = 4 {records} %start Parameter Mode = -1 Type = Records Data Size = Var(Format)_Format %if Format <= Vars DefV_Format = -Format %finish Decl Size = Data Size DefV_Type = Type DefV_Form = Form Map(Form) %if Form = 4 %start {recordformat} DefV_Extra = Parms Parameter Mode = -1 Block Type = -1 %finish %else %if Form = 3 {label} %start Set User Label(Decl) %finish %else %if Form = 6 {switch} %start %return %if Vlb > Vub Select Constant Area Word Align DefV_Format = Ca %if Control&Check Jumps # 0 %start Cword(Vlb); Cword(Vub) %finish DefV_Area = Constant Area DefV_Disp = Ca-Vlb*2 {zero'th element} DefV_Extra = Free Label-Vlb+1 {zero'th tag} Dcode(Dir Switch); Put(Vlb); Put(Vub); Put(Free Label) Ocode(Obj Switch); Put(Vlb); Put(Vub); Put(Free Label) Free Label = Free Label+Vub-Vlb+1 Ca = Ca+(Vub-Vlb+1)*2 Select Code Area %finish %else %if 7 <= Form <= 10 {routine, fn, map, predicate} %start Parameter Mode = 1 Block Type = Spec {0=definition, 8=specification} %if 8 <= Form <= 9 %start {fn/map} DefV_Flags = Answer DefV_Flags = Answer!Indirect %if Form = 9 {map} %finish %if Ostate = PrimRt %start Defv_Flags = Defv_Flags!Primitive Defv_Disp = Dim %finish %finish %else %start %if Form = 11 %or Form = 13 %start {array or namearray} Defv_Flags = Defv_Flags!Array %if Form = 13 %start {namearray} Decl Size = Word Length Decl Size = Word Length*2 %if Type = Strings %and %c Data Size = 1 {string(*)%namearray} DefV_Flags = Indirect Round = 1 {word aligned} %finish Data Size = 0 {no space allocated here} {leave the rest to 'd'} %finish %else %start {normal declaration} %if Form = 2 %start {%name} Round = Alignment %if Type # Generals %start Decl Size = Word Length Decl Size = Word Length*2 %if Type = Strings %and %c Data Size = 1 {string(*)name} Data Size = Decl Size %finish %finish %else %if Form # 1 %start {arrayname or namearrayname} Round = Alignment Data Size = Word Length*2 DefV_Flags = Indirect %if Form = 14 {namearrayname} DefV_Flags = DefV_Flags!Arrayname %finish %finish %if Ostate = 0 %start Frame = (Frame+Round)&(\Round) DefV_Disp = Frame; Frame = Frame+Data Size DefV_Base = Local %finish %else %start %if Spec = 0 %start OwnType = Type; OwnForm = Form Init Flag = 0 %if Ostate = Con %start {const something} %if Form = 2 {constname} %or %c Form = 12 {constarrayname} %or %c Form = 14 {constnamearrayname} %start DefV_Form = VinS Init Flag = -1 %return %finish Select Constant Area %finish %else %start {ownish} Select Own Area %finish OwnExtra = 1 %if Form = 12 %or Form = 14 %if Type = Strings %start OwnExtra = 1 %if Form = 2 %or Form = 13 %finish Owntype = Integers %if Form # 1 %and Form # 11 Word Align %if Round # 0 DefV_Disp = Ca %if Form = 11 %or Form = 13 %start {array or namearray} Integer value = 0 Real value = 0 String value = "" Init Flag = 1 DefV_Disp = DefV_Disp-Vlb*Decl Size {back to A(0)} %finish DefV_Area = Current Area Dump External(Dir Ddef, DefV) %if Ostate = External %finish %else %start {external data spec} Dump External(Dir Notex, DefV) %finish %finish %finish Alt Align = Alt Align!Round {remember worst alignment} %end %routine Dump Real(%integer Type) Cword(Real Value_W1); Cword(Real Value_W2) %if Type = Lreals %start Cword(Real Value_W3); Cword(Real Value_W4) %finish %end %routine Dump Text(%integer Max) %integer J, Len Len = Length(String Value) %if Max = 0 %start {no upper limit} Max = Len {use the actual length} %finish %else %start {check the length} Len = Max %and Warn("String truncated") %if Len > Max %finish Cbyte(Len) {string length} %for J = 1, 1, Max %cycle %if J > Len %then Cbyte(0) %else CByte(Charno(String Value, J)) %repeat %end %routine Adump %integer J %if OwnType = Integers %start Cword(Integer Value) %finish %else %if Owntype = Bytes %start Cbyte(Integer Value) Warn("Truncation") %unless 0 <= Integer Value <= 255 %finish %else %if OwnType = Reals %or OwnType = Lreals %start Dump Real(OwnType) %finish %else %if OwnType = Strings %start Dump Text(Decl Size-1) %finish %else %if OwnType = Records %start Cword(0) %for J = 1, 1, Decl Size>>1 %finish %else Fail("Init") %while OwnExtra > 0 %cycle OwnExtra = OwnExtra-1; Cword(0) %repeat %end %routine Init(%integer N) %if Reals <= OwnType <= Lreals %start Real Value_R = Integer Value %if Constant Type = Integers %finish %if Init Flag < 0 %start {const?name} DefV_Disp = Integer Value %finish %else %start %if Ostate = Con %then Select Constant Area %c %else Select Own Area %if Init Flag > 0 %start {array} %cycle N = N-1 %exit %if N < 0 Adump %repeat %finish %else %start {scalar} Adump %finish Select Code Area %finish String Value = "" {Restore the default values} Integer Value = 0 Real Value = 0 %end %routine Dimension(%integer Dim, N) %integer Bias, Total, X, J %record(Stackfm)%name Lb, Ub, B %record(Varfm)%name V %if Parameter List = 0 %then X = Vars-N %c %else X = Parms+N %if Dim = 1 %start Ub == Stack Lb == Ub_Stack %if Const(Lb)#0 %and Const(Ub)#0 %start {constant bounds} Stack == Lb_Stack Vlb = Lb_Disp Vub = Ub_Disp Total = (Vub-Vlb+1)*Decl Size {total Decl Size} Bias = Vlb*Decl Size {A(First)-A(0)} Fail("Bounds") %if Total < 0 %while N > 0 %cycle %if Parameter List = 0 %then X = X+1 %else X = X-1 V == Var(X) V_Flags = V_Flags!Static V_Disp = Frame-Bias; Frame = Frame+Total N = N-1 %repeat Drop(Lb); Drop(Ub) %return %finish %finish {Create dope-vector} %for J = 1,1,Dim*2 %cycle B == Stack; Stack == B_Stack Push(B) Release and Drop(B) Cword(8_005025) %if J&1 = 0 {CLR_(DS)+} %repeat %if Dim = 1 %start Perm(Adecl) %finish %else %start Cword(8_012725); Cword(Dim) Perm(Multi Dec) %finish Cword(Decl Size) {create the arrays} {R1 = Total size } {R2 = @Dope Vector} {R3 = -A(0)+4 } %while N > 0 %cycle X = X+1 V == Var(X) V_Form = VinX V_Disp = 0 V_Extra = Frame V_Flags = V_Flags!Arrayname Perm(ASET); Cword(Frame) Frame = Frame+4 N = N-1 %repeat Attributes = Attributes!Attr Dynamic %end %switch C(0:127) Old Frame = Frame %if Amode >= -1 %start {procedure definition, format start} Frame = 0 %if Amode >= 0 %start {procedure def} Avar_Disp = New Label %if Avar_Disp = 0 %if Amode = 0 %start {entry to block} Uncond Jump = -1; Forget Everything Dcode(Dir Block); Put(Avar_Disp) Ocode(Obj Block); Put(Avar_Disp) Fmark = Fmark+1; Frame Use(Local) = Fmark %finish %if Ostate = External %start %if Amode # 0 %start {external spec} Avar_Flags = Avar_Flags!Xproc Dump External(Dir Notex, Avar) %finish %else %start {external definition} Dump External(Dir Xdef, Avar) %finish %finish %finish %finish Frame Extra = Frame&1 Frame = Frame+Frame Extra Frame Base = Frame MyMark = Fmark Max Frame = 0 Alt Align = 0 %cycle Code = Pending; Readch(Pending); ->C(Code) c('!'): Operation(ORx); %continue c('"'): Compare Double; %continue c('#'): Jump Forward(Tag, NE); %continue c('$'): Define Var; %continue c('%'): Operation(XORx); %continue c('&'): Operation(ANDx); %continue c(''''): Input String Value; %continue c('('): Jump Forward(Tag, LE); %continue c(')'): Jump Forward(Tag, GE); %continue c('*'): Operation(MULx); %continue c('+'): Operation(ADDx); %continue c('-'): Operation(SUBx); %continue c('.'): Operation(CONCx); %continue c('/'): Operation(DIVx); %continue c(':'): Define Compiler Label(Tag); %continue c(';'): End of Block; %exit c('<'): Jump Forward(Tag, LT); %continue c('='): Jump Forward(Tag, EQ); %continue c('>'): Jump Forward(Tag, GT); %continue c('?'): Compare Values; %continue c('@'): Stack Var(Tag); %continue c('A'): Init(Tag); %continue c('B'): Jump Backward(Tag); %continue c('C'): Compare Addresses; %continue c('D'): Input Real Value; %continue c('E'): Call; %continue c('F'): Jump Forward(Tag, Always); %continue c('G'): Get String(Alias); %continue c('H'): Compile Begin; %continue c('J'): User Jump(Tag); %continue c('K'): Return(False); %continue c('L'): Define User Label(Tag); %continue c('M'): Return(Map); %continue c('N'): Input Integer Value; %continue c('O'): Update Line(Tag); %continue c('P'): Cword(Popped Value); %continue c('Q'): Operation(RDIVx); %continue c('R'): Return(Routine); %continue c('S'): Assign(Equals); %continue c('T'): Return(True); %continue c('U'): Operate(NEGx, Stack, Null); %continue c('V'): Return(Fn); %continue c('W'): Switch Jump(Tag); %continue c('X'): Operation(EXPx); %continue c('Z'): Assign(EqualsEquals); %continue c('['): Operation(LSHx); %continue c('\'): Operate(NOTx, Stack, Null); %continue c(']'): Operation(RSHx); %continue c('_'): Switch Label(Tag); %continue c('a'): Array Access; %continue c('b'): Constant Bounds; %continue c('c'): Section = 1; Get String(Section Id); %exit c('d'): D = Tag; N = Tag; Dimension(D, N); %continue c('e'): Signal Event(Tag); %continue c('f'): Compile For(Tag); %continue c('i'): Array Index; %continue c('j'): Assign(Jam); %continue c('k'): Jump Forward(Tag, FF); %continue c('l'): Language Flags = Tag; %continue c('m'): Call Monitor; %continue c('n'): Select(Tag); %continue c('o'): Event Trap(Tag); %continue c('p'): AssignParameter; %continue c('r'): Resolve(Tag); %continue c('t'): Jump Forward(Tag, TT); %continue c('u'): Aop; %continue c('v'): Modulus; %continue c('w'): Machine Code; Forget Everything; %continue c('x'): Operation(REXPx); %continue c('y'): Set CD(Tag, Diag); %continue c('z'): Set CD(Tag, Control); %continue c('{'): Assemble(DefV, Blocktype, Vars, Local+1, Parameter Mode); %continue c('}'): %exit %if Finish Params#0; %continue c('~'): %exit %if Alternate format#0 c(10): %repeat %if Amode&8 = 0 %start Attributes = Attributes!Attr Inner Uses %if Frame Use(Local) # MyMark Dcode(Dir End); Put((Frame+Alignment)&(\Alignment)) Put(Parameter Frame) Put(SpSize) Put(Attributes) Put(Code Base) Ocode(Obj End); Put(Event Bits) %if Event Bits # 0 %start Put(Event Label); Put(Event Body) %finish Forget Everything Avar_Flags = Avar_Flags!Open %finish Terminate Block %return !#if e(=true) C(*): Fail("Code ".ItoS(code)) !#else(=false) {C(*): Fail("Code ".ItoS(Code,1))} !#fi %end Select Input(Icode); Readch(Pending) Var(0) = 0 %for J = R0, 1, AnyF %cycle Stack == RegV(J) Stack = 0 Stack_Base = J Stack_Type = Integers; Stack_Type = Lreals %if J >= F0 Stack_Form = VinR Stack_Format = 2 %repeat Stack == Null %for J = 1, 1, Max Stack Items %cycle Dasl == Stack Item(J) Dasl_Using == Using Using == Dasl %repeat Using == Null Knowing == Kasl %for J = 1, 1, Max Knowing %cycle Ktail == Known(J) Knowing_Link == Ktail Knowing == Ktail %repeat Knowing == Null Ktail_Link == Null Cc1_Reg = Cc Lhs; Cc2_Reg = Cc Rhs %cycle Select Output(Obj) Parms = Max Vars+1 Perm Used(J) = 0 %for J = Signal&255, 1, ShiftR&255 Ilabel(J) <- Defined %for J = 1,1,50 Uses Display = 0 External Spec = Own Area Event Count = 0 Own Base = 0 Constant Base = 0 Free Label = 0 Section = 0 Assemble(Var(0), -16, 0, 128, 0) {Var(0) is a dummy} Select Output(Dir) Put(Own Base); Put(Constant Base); Put(Event Count) %exit %if Section = 0 Printch(Dir Section); Put Text(Section Id); Section Id = "" %repeat Newline Ocode(Nl) *lm_4,15,16(10) *bcr_15,15 %endofprogram