!#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) %EXTERNALSTRINGFUNCTIONSPEC i to s %ALIAS "S#ITOS"(%INTEGER i) !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 %ORINTEGER Scale)) %RECORDFORMAT Datafm(%RECORD (Varfm) V, (%INTEGER Bias %ORINTEGER Dope %ORBYTE 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(((%RECORD (Varfm) V %ORBYTE Type,Form,Base,Flags, %INTEGER Disp,Area,Extra,(%INTEGER Format %ORINTEGER Scale)), (%INTEGER Bias %ORINTEGER Dope %ORBYTE Reg,Label), %INTEGER Oper, %RECORD (Varfm) A, %RECORD (Stackfm) %NAME Link %ORRECORD (Datafm) Data), %RECORD (Stackfm) %NAME Using,Stack,Params, (%INTEGER Preg %ORINTEGER 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 %ORINTEGER 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 %C Reals<=Avar_Type<=Lreals %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)) %FINISHELSESTART 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) %FINISHELSESTART 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) %ELSEIF Type=Lreals %THEN %C Plant0(SETD) %ELSEIF 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} %ELSE %C 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 %FINISHELSESTART 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) %FINISHELSESTART 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 %FINISHELSEIF V_Form=VinX %START V_Form = VinS %FINISHELSESTART 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) %FINISHELSESTART V_Oper = 0; V_Link == Null; Drop(W) %FINISH %FINISHELSESTART 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 %FINISHELSEIF V_Form=VinS %START V_Extra = V_Disp V_Disp = N V_Form = VinX %FINISHELSESTART Reduce(V) %IF V_Form=AinX {leaving VinX} %IF N=0 %START V_Form = AinX %FINISHELSESTART 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") %FINISHELSESTART 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 %FINISHELSEIF V_Form=VinS %START V_Form = VinR %FINISHELSEIF 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 %FINISHELSEIF V_Disp=0 %AND V_Area=0 %START %IF V_Base=AnyG %START V_Base = Gpr %FINISHELSEIF V_Base=AnyF %START V_Base = Fpr %FINISH D_Modereg = Reg %FINISHELSESTART {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 %FINISHELSEIF V_Form=VinS %START %IF V_Base=0 %START D_Modereg = Absolute D_Extra = V_Disp D_More = No Relocation %IF D_More=0 %FINISHELSEIF V_Disp=0 %AND V_Area=0 %START D_Modereg = Defer %FINISHELSESTART D_Modereg = Index D_Extra = V_Disp D_More = No Relocation %IF D_More=0 %FINISH %FINISHELSEIF 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 %FINISHELSESTART D_Modereg = IndexDefer %FINISH D_Extra = V_Extra D_More = No Relocation %IF D_More=0 %FINISHELSEIF 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 %FINISHELSESTART 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 %C Reloc1 %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 %FINISHELSESTART Reg = Fpr PlantF(LDF,Reg,V1) %FINISH %FINISHELSESTART Store = 0 Reg = V2_Base %IF Reg=AnyF %START %RETURNIF 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 %RETURNIF 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 Op1_Extra=Op2_Extra %AND %C Op1_More=Op2_More %AND (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) %ELSE %C Remember(V1_Base,V2) %FINISH %FINISH %FINISH %IF Wanted#0 %START {going to a register} Replace(V1,Hold2) %FINISHELSESTART 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) %FINISHELSEIF Match('-')#0 %START Lit = Lit-Literal(0) %FINISHELSERETURN %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 %FINISHELSESTART Lit = Literal(0) %FINISH Add(Lit,Rel) %FINISHELSEIF Match('(')#0 %START Get Index Mode = 1 Mode = 2 %IF Match('+')#0 %FINISHELSEIF Match('-')#0 %START %IF Match('(')#0 %START Get Index Mode = 4 %FINISHELSESTART Mode = 6 Lit = -Literal(0) %IF Match('(')#0 %THEN Get Index %ELSE Mc Error(" ( ?") Modify Add(Lit,0) %FINISH %FINISHELSEIF Pending='N' %START Lit = Literal(0) %IF Match('(')#0 %START Get Index Mode = 6 Modify Add(Lit,0) %FINISHELSESTART Mc Error(" Register?") %UNLESS 0<=Lit<=7 Reg = Lit %FINISH %FINISHELSEIF 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 %FINISHELSEIF V_Base=Local %START Reg = Actual(Lnb); Mode = 6 %FINISHELSEIF Rel#0 %OR Reg=0 %START Reg = 7; Mode = 3 %FINISHELSESTART 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 %ELSE %C Add(Lit,Rel) %FINISHELSESTART 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 %FINISHELSESTART %IF Val1(J)>M1 %THEN H = J-1 %ELSE L = J+1 %FINISH %REPEATUNTIL 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 %FINISHELSESTART 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 %ELSE %C 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 %OR %C 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 %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) %FINISHELSESTART Claim(R) Plant1(CLR,Rv); Plant2(BISB,Old,Rv) Release(Old_Base) %FINISH Old_Data = Rv_Data; Ot = Integers %RETURNIF 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 %FINISHELSESTART 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 %FINISHELSESTART {float required} Float(Old,New) %FINISH %FINISHELSEIF Reals<=Ot<=Lreals %START Loadup(Old) %IF ToNew#0 %START Rw_Data = New_Data PlantF(STCFI,Old_Base,Rw) Update %FINISHELSESTART 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 %RETURNIF 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 (From_Disp=0 %OR (-1<=From_Disp<=1 %AND %C Treg#0)) %START Promote(To_Base) N = From_Disp Optimise(From,1) {just in case} Move(From,To) %ANDRETURNIF 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) %FINISHELSESTART 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 %FINISHELSESTART 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=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 %REPEATUNTIL 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 (Flags&Byteself=0 %AND %C 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) %FINISHELSESTART Plant1(Unary op(Oper<<1+D_Type),D) %FINISH %FINISHELSESTART {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) %FINISHELSEIF Oper=LSHx %OR Oper=RSHx %START %RESULT = 0 %UNLESS Shifted(S,D,0,Oper)#0 %FINISHELSESTART 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 %FINISHELSESTART Optimise(From,1) %IF In Safe Reg(From)#0 %START Reg_Base = From_Base %FINISHELSESTART %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 %FINISHELSEIF Activity(R0)+Activity(R1)=RNEGx %START {floating-point operation} Choose a register(Lreals) Simple(From,Reg) %IF Oper=RNEGx %START Plant1(NEGF,From) %FINISHELSESTART 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) %FINISHELSESTART %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) %FINISHELSESTART 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) %FINISHELSESTART 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 %FINISHELSESTART 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) %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 %ELSE R = AnyG Load(V,R) %END %ROUTINE Load Base(%RECORD (Stackfm) %NAME V) %RECORD (Varfm) D %RECORD (Stackfm) T %RETURNIF V_Base<=128 Monitor(V,"LoadB") %IF Diag&MonOperand#0 %IF V_Base=Local %START V_Base = Lnb %FINISHELSESTART %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) %FINISHELSEIF Op=MULx %START %IF N=0 %START Fix(0) Release(Lhs_Base) Lhs_Form = VinR; Lhs_Base = 0; Lhs_Disp = 0 Lhs_Area = 0 %FINISHELSEIF N=-1 %START Fix(NEGX) %FINISHELSESTART N = Power(N) %IF N>0 %START Lhs_Link_Disp = N Lhs_Oper = LSHX %FINISH %FINISH %FINISHELSEIF Op=XORX %AND N=-1 %START Fix(NOTX) %FINISHELSEIF 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 %FINISHELSEIF Oper=NOTX %START Lhs_Disp = \Lhs_Disp %FINISHELSE Fail("Operator") %FINISHELSESTART 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 } %FINISHELSESTART 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 %FINISHELSESTART 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 %FINISHELSEIF Rhs_Form=VinR %AND Rhs_A_Scale=0 %AND (Oper=ADDx %OR %C 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) %FINISHELSESTART 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) %FINISHELSESTART 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 %FINISHELSEIF V_Disp#0 %START {address of variable} F = 1 %FINISHELSERESULT = 0 %FINISHELSEIF V_Form=VinS %START {variable direct} F = 2 %FINISHELSEIF V_Form=VinX %START {variable indirect/record direct} F = 3 {indirect} F = 5 %IF V_Disp#0 {direct} %FINISHELSESTART {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; %RETURNIF 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 %RETURNUNLESS 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 %FINISHELSEIF 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 %FINISHELSEIF M_A_Disp=P_A_Disp %START ->Set VinR %FINISH %FINISH %FINISH %FINISHELSESTART F = P_V_Form %IF F=M_V_Form %AND Mode#0 %START {exact match} ->Set VinR %FINISHELSEIF F+1=M_V_Form %START {address in register} Set(VinS) Optimise(V,Mode) %IF Mode#0 %RETURN %FINISH %FINISH %FINISH P == P_Link %REPEATUNTIL 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 %RETURNIF 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 %FINISHELSESTART 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 %RETURNIF New=Old Used(New) = Ca P == Knowing %WHILE P##Null %CYCLE K == P; P == K_Link %IF K_Reg=Old %START X == Record(NewK); %RETURNIF 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 %FINISHELSESTART 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 %RETURNUNLESS R0<=Register<=F3 Used(Register) = Ca %IF InReg(V)#0 %START {inherit other register's data} Inherit(Register,V_Base) %RETURN %FINISH %RETURNIF Register=V_Base %OR Register=V_A_Base %IF Memorable(V,M)#0 %START K == Record(NewK); %RETURNIF 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 %C 1<=K_A_Base<=127 %OR %C {unknown array base}1<=V_A_Base<=127 {unknown altered base} %FINISH %RESULT = -1 %IF K_A_Form=3 {indirect} %RESULT = -1 %IF 0=Cc Lhs %START %IF P_Reg=Cc Lhs %START Cc1_Data = P; Cc1_Cc Ca = Ca %FINISHELSESTART Cc2_Data = P; Cc2_Cc Ca = Ca %FINISH %FINISHELSESTART 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 V_Disp#0 %OR V_Base=0 %OR %C V_Area#0 %OR V_Oper#0 %OR 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 A_Base#B_Base %OR %C A_Form#B_Form %OR A_Extra#B_Extra %OR A_Type#B_Type %OR %C A_Area#B_Area %OR A_A_Format#B_A_Format %RESULT = -1 %IF A_A_Format=0 %RESULT = 0 %IF A_A_Disp#B_A_Disp %OR A_A_Base#B_A_Base %OR %C A_A_Area#B_A_Area %OR A_A_Form#B_A_Form %OR %C A_A_Extra#B_A_Extra %OR 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 V_Type#Integers %OR %C V_Area#0 %OR V_Oper#0 %OR 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) %RETURNUNLESS 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) %RETURNUNLESS 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 %FINISHELSEIF V_Form=VinX %START V_Form = AinX V_Disp = V_Extra V_Extra = New %FINISHELSEIF V_Form=VinR %START %IF V_Disp#0 %START V_Extra = New V_Form = VinX Amap(V) %FINISHELSESTART 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); %RETURNIF 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) %FINISHELSESTART 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) %FINISHELSEIF Min Known=Ktimes(R) %START %IF Oldest>Used(R) %START Min Reg = R Oldest = Used(R) %FINISH %FINISH %FINISHELSEIF Activity(R)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) %FINISHELSEIF How=False %START Plant0(CLC) %FINISHELSEIF 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 %RETURNIF 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 %C Const(Initial)#0 %AND Const(Inc)#0 %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 %FINISHELSE 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) %FINISHELSESTART 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 %FINISHELSESTART 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 {} %FINISHELSESTART %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 %FINISHELSESTART 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) %RETURNIF P==Null Optimise(P,1) Pick Params(P_Params) %END %ROUTINE Load Params(%RECORD (Stackfm) %NAME P) %RECORD (Stackfm) %NAME W %INTEGER Reg %RETURNIF 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 %EXITIF 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 %RETURNIF W==Null %OR V_Flags&(Xproc!Parameter)#0 Prefix Parameters(W_Params) %IF W_Params##Null %RETURNIF 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 %RETURNIF 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 %FINISHELSESTART Cword(8_010125) %FINISH %IF V_Flags&Xproc#0 %START {external Call} Call External(Ep) %FINISHELSEIF V_Flags&Parameter#0 %START {procedure parameter call} %FINISHELSESTART {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 %OR V_Type=Records %START R_Base = Iresult R_Form = VinS %FINISH Claim(R_Base) %IF V_Flags&Indirect=0 %AND V_Type=Strings %AND Pending#'?' %AND %C Pending#'S' %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 %FINISHELSESTART 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) %FINISHELSESTART 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 %AND %C 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 = ')' %ELSE Pending = '<' %FINISHELSESTART Plant2(Op,V,W) %FINISH Drop(W) %RETURN %FINISH Loadup(V) %FINISH Unsigned = 0 %IF V_Type=Bytes %START Unsigned = 10; Op = Tstb %FINISHELSEIF Floating(V)#0 %START Op = TstF %FINISHELSESTART Op = Tst %FINISH Plant1(Op,V) %IF Op=TSTF %START Plant0(Cfcc) %FINISHELSEIF 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) %FINISHELSESTART 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) %FINISHELSESTART Plant2(Cmpb,L,R) %FINISH %FINISHELSESTART 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) %FINISHELSESTART 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 = '(' %FINISHELSEIF Pending=')' %START {<1 :: <=0} Pending = '>' %FINISH %FINISHELSEIF V_Disp+Mod=0 %START %IF Pending='>' %START {<=-1 :: <0} Pending = ')' %FINISHELSEIF 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 Right_Disp<0 %OR %C Const(Right)=0 %START Test Zero(Left) Jump Forward(Pending Tag,LT) %FINISHELSESTART 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 %FINISHELSEIF 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 %FINISHELSEIF Floating(Right)#0 %START Invert = Invert!!Inverted Compare Reals(Right,Left); %RETURN %FINISH %IF Left_Type=Bytes %START Compare Bytes(Left,Right); %RETURN %FINISHELSEIF 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) %FINISHELSESTART 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 (Type<=Lreals %AND R_Disp#0 %AND %C %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 %FINISHELSESTART 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>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} %FINISHELSESTART Cword(8_005300+Reg) {DEC_N} Cword(8_003000+(-3)&255) {BGT_.-3} %FINISH Release and Drop(N) %FINISHELSESTART 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) %FINISHELSEIF R_FORM=VinS %AND R_Format=1 %START {L = ""} L_Type = Bytes Plant1(Clrb,L) %FINISHELSESTART 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) %FINISHELSEIF L_Type=Strings %START String Assign(L,R) %FINISHELSESTART 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) %FINISHELSESTART 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 %FINISHELSEIF L_Form=Proc %START Fail("Not implemented") %FINISHELSEIF 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) %FINISHELSESTART T == Record(Literal(0)) Store(L,T); Release and Drop(T) %FINISH %FINISHELSEIF 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) %FINISHELSESTART T == Record(Literal(N)) Move and Advance(L,T); Release and Drop(T) %FINISH %FINISHELSESTART 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) %FINISHELSESTART 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) %FINISHELSESTART 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) %FINISHELSEIF How=EqualsEquals %START Store Address(L,R) %FINISHELSESTART 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) %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) %FINISHELSESTART Store(V,P) Release and Drop(P) %FINISH %FINISHELSESTART 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) %FINISHELSESTART {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 %FINISHELSESTART 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 %FINISHELSEIF Code='C' %START {Next alternative} Max Frame = Frame %IF Frame>Max Frame Frame = Frame Base %FINISHELSEIF Code='B' %START {End of alternatives} Frame = Max Frame %IF Max Frame>Frame Falign = Alt Align %RESULT = -1 %FINISHELSESTART !#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 %C RegV(AnyG)_Base#AnyG %OR RegV(AnyF)_Base#AnyF %OR %C RegV(Ds)_Base#Ds %OR RegV(Lnb)_Base#Lnb %OR 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 %FINISHELSESTART 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} %FINISHELSESTART {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) %OR %C (Ap_Type=Strings %AND Ap_Format=1) %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 %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 %FINISHELSEIF Pending='_' %START Base = N; N = 0 %FINISHELSEIF Pending='@' %START Readch(Pending) Short <- Tag !#if e(=true) N = N*Base**Short !#else(=false) { N = N*Base^Short} !#fi %EXIT %FINISHELSESTART Q = Pending-'0' Q = Q+'0'-'A'+10 %IF Q>9 %IF P=0 %START {no decimal point yet} N = N*Base+Q %FINISHELSESTART 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) %FINISHELSEIF 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)) %FINISHELSEIF '$'#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>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 = "" %FINISHELSESTART %IF Ostate=System %START Ostate = External External Id = "$".Internal Id %FINISHELSESTART 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 %FINISHELSEIF 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 %FINISHELSEIF Type=2 {real} %START Type = Reals Type = Lreals %AND Data Size = Word Length*2 %IF Format=4 DefV_Format = Data Size %FINISHELSEIF Type=3 {string} %START Type = Strings Data Size = Format+1 Round = 0 DefV_Format = Data Size %FINISHELSEIF 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 %FINISHELSEIF Form=3 {label} %START Set User Label(Decl) %FINISHELSEIF Form=6 {switch} %START %RETURNIF 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 %FINISHELSEIF 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 %FINISHELSESTART %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 %C Type=Strings %AND 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'} %FINISHELSESTART {normal declaration} %IF Form=2 %START {%name} Round = Alignment %IF Type#Generals %START Decl Size = Word Length Decl Size = Word Length*2 %IF %C Type=Strings %AND Data Size=1 {string(*)name} Data Size = Decl Size %FINISH %FINISHELSEIF 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 %FINISHELSESTART %IF Spec=0 %START OwnType = Type; OwnForm = Form Init Flag = 0 %IF Ostate=Con %START {const something} %IF Form=2 {constname} %OR Form=12 {constarrayname} %OR %C Form=14 {constnamearrayname} %START DefV_Form = VinS Init Flag = -1 %RETURN %FINISH Select Constant Area %FINISHELSESTART {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 %FINISHELSESTART {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} %FINISHELSESTART {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) %FINISHELSEIF Owntype=Bytes %START Cbyte(Integer Value) Warn("Truncation") %UNLESS 0<=Integer Value<=255 %FINISHELSEIF OwnType=Reals %OR OwnType=Lreals %START Dump Real(OwnType) %FINISHELSEIF OwnType=Strings %START Dump Text(Decl Size-1) %FINISHELSEIF OwnType=Records %START Cword(0) %FOR J = 1,1,Decl Size>>1 %FINISHELSE 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 %FINISHELSESTART %IF Ostate=Con %THEN Select Constant Area %ELSE %C Select Own Area %IF Init Flag>0 %START {array} %CYCLE N = N-1 %EXITIF N<0 Adump %REPEAT %FINISHELSESTART {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 %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) %FINISHELSESTART 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) %FINISHELSESTART {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('}'): %EXITIF Finish Params#0; %CONTINUE c('~'): %EXITIF 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) %EXITIF Section=0 Printch(Dir Section); Put Text(Section Id); Section Id = "" %REPEAT Newline Ocode(Nl) *lm_4,15,16(10) *bcr_15,15 %ENDOFPROGRAM