!########################################### !# S-assembler for VAX SIMULA system # !# Peter S. Robertson # !# Rob Pooley # !# Mar. 1982 # !########################################### ! ***** G E N E R A L S T R U C T U R E ***** ! .-------------. .-------------. ! | | | | ! | |--directives->| | ! S-code--->| S-assembler | | S-generator |----object file----> ! | |----object--->| | ! | | | | ! `-------------' `-------------' ! ^ ! | ! | ! modules ! %externalroutinespec open input(%integer stream, %string(31) file) ! %externalroutinespec open output(%integer stream, %string(31) file) {Declared here to aid debugging} %owninteger Token = 0, {Current input byte} Pending = 0 {Next input byte} %externalroutine SIMULA2(%string(15) File Mod Name,%integer Magic Line, Stop Line, Magic 3) !Environment constants %integer tf %constant %integer Max Stacked = 50, {descriptor pool size} Max Vars = 10000, {definitions in VAR} Max Label = 200, {internal labels} Max Modules = 63, {inserted modules} Max Externals = 127 {external refs} %constant %integer True = \0, False = 0 !Input/Output stream definitions %constant %integer Report = 0, {Report/diagnostic output} Obj = 1, {object code output} Dir = 2, {directives output} Moduleo= 3, {module definition output} Source = 1, {Scode source input} Modulei= 2 {module library input} %own %integer Current Stream = Obj !Final phase control codes %constant %integer Obj select = 1, Dir select = 1, Obj locate = 2, Dir Spec = 2, Obj complete = 3, Dir complete = 3, Obj byte = 4, Dir new area = 4, Obj word = 5, Dir end area = 5, Obj longword = 6, Dir add area = 6, Obj relinst = 7, Dir insert = 7, ObjDir call = 8, Obj switch = 9, Dir label = 9, ObjDir jump = 10, Obj line = 11, Dir module = 11, Obj link = 12, ObjDir Oaddr = 13, ObjDir Oaddrc= 14, ObjDir Paddr = 15, Obj RelR11 = 16, ObjDir Locals= 17, ObjDir Mask = 18, Obj IntrfaceEp=19 !Scode items %constant %integer SC record = 1, SC caaddr = 17, SC coaddr = 18, SC prefix = 3, SC cgaddr = 19, SC attr = 4, SC cpaddr = 20, SC cdot = 21, SC rep = 6, SC Craddr = 22, SC alt = 7, SC nobody = 23, SC fixrep = 8, SC anone = 24, SC endrecord = 9, SC onone = 25, SC crecord = 10, SC gnone = 26, SC text = 11, SC nowhere = 27, SC cchar = 12, SC true = 28, SC cint = 13, SC false = 29, SC csize = 14, SC profile = 30, SC creal = 15, SC known = 31, SC clreal = 16, SC system = 32 %constant %integer SC external = 33, SC range = 49, SC import = 34, SC global = 50, SC export = 35, SC init = 51, SC exit = 36, SC constspec = 52, SC endprofile = 37, SC const = 53, SC routinespec = 38, SC delete = 54, SC routine = 39, SC fdest = 55, SC local = 40, SC bdest = 56, SC endroutine = 41, SC save = 57, SC module = 42, SC restore = 58, SC existing = 43, SC bseg = 59, SC tag = 44, SC eseg = 60, SC body = 45, SC skipif = 61, SC endmodule = 46, SC endskip = 62, SC labelspec = 47, SC if = 63, SC label = 48, SC else = 64 %constant %integer SC endif = 65, SC pushc = 81, SC endifc = 66, SC pushlen = 82, SC precall = 67, SC dup = 83, SC asspar = 68, SC pop = 84, SC assrep = 69, SC empty = 85, SC call = 70, SC setobj = 86, SC fetch = 71, SC getobj = 87, SC refer = 72, SC access = 88, SC deref = 73, SC fjump = 89, SC select = 74, SC bjump = 90, SC remote = 75, SC fjumpif = 91, SC locate = 76, SC bjumpif = 92, SC index = 77, SC switch = 93, SC inco = 78, SC goto = 94, SC deco = 79, SC tinito = 95, SC push = 80, SC tgeto = 96 %constant %integer SC tseto = 97, SC convert = 113, SC add = 98, SC sconvert = 114, SC sub = 99, SC insert = 115, SC mult = 100, SC zeroarea = 116, SC div = 101, SC initarea = 117, SC rem = 102, SC compare = 118, SC neg = 103, SC lt = 119, SC and = 104, SC le = 120, SC or = 105, SC eq = 121, SC xor = 106, SC ge = 122, SC imp = 107, SC gt = 123, SC eqv = 108, SC ne = 124, SC not = 109, SC eval = 125, SC dist = 110, SC info = 126, SC assign = 111, SC line = 127, SC update = 112, SC setswitch = 128 %constant %integer SC ass call = 136, SC program = 130, SC call tos = 137, SC main = 131, SC dinitarea = 138, SC endprogram = 132, SC nosize = 139, SC dsize = 133, SC popall = 140, SC sdest = 134, SC repcall = 141, SC rupdate = 135, SC interface = 142 !Register control bits %constant %integer F Reg = 1<<5, {floating register} D Reg = 2<<5, {double register} Any = 4<<5, {any register} Plus 5 = 8<<5, {not R0 to R5} No Check= 16<<5 {disable consistency check} !Register definition %constant %integer No Reg = 0 %constant %integer R0 = 1, R1 = 2, R2 = 3, R3 = 4, R4 = 5, R5 = 6, R6 = 7, R7 = 8, R8 = 9, R9 = 10, R10 = 11, R11 = 12, R12 = 13, R13 = 14, R14 = 15, R15 = 16 %constant %integer %array Actual(no reg:R15) = -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15 !VAX register aliases %constant %integer AP = R12, {Argument Pointer} FP = R13, {Frame Pointer - Display} SP = R14, {Stack Pointer} PC = R15 {Program Counter} !Single-length floating-point registers %constant %integer F0 = R0 ! F Reg, F1 = R2 ! F Reg, F2 = R4 ! F Reg, F3 = R6 ! F Reg, F4 = R8 ! F Reg, F5 = R10! F Reg !Double-length floating-point registers %constant %integer D0 = R0 ! D Reg, D1 = R1 ! D Reg, D2 = R2 ! D Reg, D3 = R3 ! D Reg, D4 = R4 ! D Reg, D5 = R5 ! D Reg, D6 = R6 ! D Reg, D7 = R7 ! D Reg, D8 = R8 ! D Reg, D9 = R9 ! D Reg %integer Noload = 0 !Pseudo registers %constant %integer Any I = Any, {any integer register} Any F = Any ! F Reg, {any floating register} Any D = Any ! D Reg, {any double register} Any Plus = Any ! Plus 5, {any register above R5} Any Pl F = Any ! Plus 5 ! F Reg, {floating reg above R5} Any Pl D = Any ! Plus 5 ! D Reg {double reg above R5} %constant %integer R Mask = x'1f', R Mask2 = R Mask!x'10000000' %constant %short Mask Base = X'C800' {Entry mask with only R11 saved} %owninteger Tried = 0 %integer Regs Used = Mask Base {To contain actual mask} %constant %string(3) %array Sreg(-1:15) = "", "R0", "R1", "R2", "R3", "R4", "R5", "R6", "R7", "R8", "R9", "R10","R11", "AP", "FP", "SP", "PC" !Internal operation flags %constant %integer Unary = 1<<4, Addsub = 1<<5, Complex = 1<<6, Commutative = 1<<7, Cop1 = 1<<8, Cop2 = 1<<9, Cop12 = cop1 ! cop2, No Null = 1<<10 !Internal operation codes %constant %integer Negate = 1, Complement = 2, Add = 3, Subtract = 4, Multiply = 5, Divide = 6, Remainder = 7, And = 8, Or = 9, Xor = 10, Maxoper = 10 %constant %short %array Oper Flags(Negate:Maxoper) = Unary!NoNull {negate}, Unary!NoNull {complement}, AddSub!Commutative!Cop1 {add}, AddSub!Cop1 {subtract}, Commutative!Cop2 {multiply}, 0 {divide}, NoNull {remainder}, Commutative!Cop2!Complex {and}, Commutative!Cop2 {or}, Commutative!Cop2 {xor} %constant %integer %array Null Value(Negate:Maxoper) = 0(4), 1,1,0,true,false,false !Types External Machine Dense %constant %integer Bool = 1, Byte = Bool, Char = 2, Int = 3, Longword = Int, Sint = 4, Word = Sint, Real = 5, Floating = Real, Lreal = 6, Double = Lreal, Aaddr = 7, Oaddr = 8, Gaddr = 9, Paddr = 10, Raddr = 11, Size = 12 %const %byte %array Type Reg(Bool:Size) = Any I(4), Any F, Any D, Any I(*) %const %short %array Type Plus Reg(Bool:Size) = Any Plus(4), Any Pl F, Any Pl D,Any Plus(*) %constant %short %array Map Oper(SC add:SC not) = add, subtract, multiply, divide, remainder, negate, and, or, xor, 0, 0, complement %constshortarray Size of Type(Bool:Size) = 1, 1, 4, 2, 4, 8, 4, 4, 8, 4, 4, 4 %recordformat %c Tag Fm(%byte Tag Type, Flags, %short Type, Module, {Could be a byte?} Chain, ( %longreal Rvalue %or %integer Displacement,%short Size,Base Size,X Tag,Item Size,Reps %or %short Import, Export, Exit )) !Tag types %constant %integer Constant Type = 1, Global Type = 2, Local Type = 3, Import Type = 4, Export Type = 5, Exit Type = 6, {All <= Exit may be Pushed} Record Type = 7, Label Type = 8, Profile Type = 9, Stacked Profile Type = -1, Routine Type = 10, Attribute Type = 11, Switch Type = 12, Type Type = 13 !VAR flags %constant %integer Defined Bit = 1, {Tag has been defined} Spec Bit = 2, {Tag has had a specification} Type Bit = 4, {Tag refers to a type} Indefinite = 8, {Tag has an indefinite repetition} External = 16, {Tag has an external tag} Inserted = 32, {Tag came from INSERT} Peculiar = 64, {known, system or external} Known = 128 {known routine} %constant %integer Interface Bit = Indefinite {Marks profile of INTRHA} ! Operand Stack Definitions ! ************************* %recordformat Data Fm(%byte Mode, Acru, Oper, Index, %short Type, Flags, Base, Size, (%longreal Rvalue %or %integer Offset, Extra %or %short Import), %record(data fm)%name A, Link) %recordformat Stack Fm((%record(datafm) Data %or %byte Mode, Acru, Oper, Index, %short Type, Flags, Base, Size, (%longreal Rvalue %or %integer Offset, Extra %or %short Import), %record(stackfm)%name A, Link), %record(stackfm)%name Using, Stp) !USING - link for the using chain, a list of active descriptors. !A - pointer to Aaddr component descriptor !Note that Gaddr objects are in two pieces: ! 1 - V describing the Oaddr component ! 2 - V_A describing the Aaddr component !The record DATA is used so as to be able to move the relevant !parts of descriptors without corrupting the USING list !Flags %constant %integer Val = 0, Defer = 1, Ref = 1, NoNot = 2, NoneF = 4, BoolFl= 8, Reg Dumped = 16, Marked Bit = 32 !Internal data forms %constant %integer Constant = 0, VinR = 1, {variable in register} VinS = 2, {variable in store: BASE+DISP} AVinS = 3, {address of V IN S} AinS = 4, {address in store: BASE+DISP} AutoI = 5, {auto increment} AutoD = 6, {auto decrement} AinR = 7 {address in register} %recordformat Stack Env Fm(%integer Active Registers, %record(stackfm)%name Using, Asl, Stack, %integer %array Activity(No reg:R15), Dumped Activity(No Reg:R15), Used(No reg:R15), %record(stackfm)%array Stacked(1:max stacked)) !This record describes the complete environment of the stack and is !used to take stack copies at IF and SKIPIF q.v. !ACTIVE REGISTERS - number of outstanding claims !USING - chain of active descriptors in STACKED !ASL - chain of free descriptors in STACKED !STACK - the stack. !ACTIVITY - table of outstanding claims on specific registers ! 0 = free, -1 = locked !USED - code address of when register was last used !STACKED - descriptor pool !Label data %constant %integer Fdef = -4, Fref = 1, Bdef = 2, Bref = -3 %integer Pushset = 0 { Flag to prevent export parameter being loaded } %integer Inverted = 0, {flag for comparison inversion} Reversed = 0, {flag for condition test reversal} Free Label = 0 {external label tags} !Global variables %integer Tagn, {current tag number} Typen, {Current type tag} Type Size, {Total size of current type} Type Item Size, {Repetition size of current type} Rep, Top Tag = 31 %record(Tagfm)%name Tagv, {current tag var} Defv, {current var being defined} RD, {current record being defined} Typev {current type} {areas} %constant %integer Global Area = -3, {read-write} Export Area = -2, {read-write} Constant Area = -1, {read only} Code Area = -4 {executable code} %constant %short %array Base Map(Constant Type:Exit Type) = Constant Area {Constant Type}, R11 {Global Type}, Fp {Local Type}, Ap {Import Type}, Export Area {Export Type}, Fp {Exit Type} %owninteger Free Area = -4 {execute} !Area addressing %integername Ca {current address} %integer Local Displacement = 0, Global Displacement = 0, Export Displacement = 0, Constant Displacement = 0, Code Displacement = 0, Diags Size = 0 %integer Current Area = 0 %record(stackfm)%name Tos {Top of Stack} %record(stackfm)%name Sos {Second on Stack} %owninteger Depth {Number of descriptors on current stack} %ownlongreal Real Literal = 0 %owninteger Integer Literal = 0 !Scode processing !Monitoring %ownintegerarray Switch(0:7) = 0(*) %integername Control == Switch(0), Monitor Input == Switch(1), Monitor Output == Switch(2) %owninteger Current Line = 0, Previous Nl = 1, In Routine = 0 !Environment and descriptor handling %owninteger Tag Limit = Max Vars+1, Spec = 0, Module Number = 0, External No = 0, T3 Used = 0, Main Ep = 0 %recordformat Modulefm(%short Base, %string(13) File) %record(Modulefm)%array Module(1:Max Modules) %string(11)%array External Id(1:Max Externals) %constant %record(*)%name Null == (0) %own %record(stackfm) Zero = 0, {for S^0 operands} Spv = 0, {for SP operands} Atsp = 0, {for (SP) operands} Minus Sp = 0, {for -(SP) operands} Sp Plus = 0, {for (SP)+ operands} Rv0 = 0, {for register 0 operands} Cm31 = 0, {for -31 literal operands} Display = 0, {object display} Overflow = 0 {register overflow} %record(stack env fm) Base E {global environmen} %record(Stack Env Fm)%name E==Base E %record(Stack Fm)%name Parms { head of parameter list } %record(Tagfm)%array Var(0:max vars) !Object code data {Special Operations} %constant %integer X And = -1, X Rem = -2 !Operand Flags %Constant %Integer Op1 = 1<<24, Op2 = 1<<25, Op3 = 1<<26, Op4 = 1<<27, Op5 = 1<<28 %Constant %Integer O1 = 8, O2 = 8+3, O3 = 8+3+3, O4 = 8+3+3+3, O5 = 8+3+3+3+3 %Constant %Integer BB = 1, LL = 3, WW = 2, FF = 4, DD = 5, AB = 6, QQ = 7 %Constant %Integer Addb3 = 1, Addd2 = 2, Addd3 = 3, Addf2 = 4, Addf3 = 5, Addl2 = 6, Addl3 = 7, Addw2 = 8, Addw3 = 9, Ashq = 10, Beql = 11, Bgeq = 12, Bgtr = 13, Bicb2 = 14, Bicb3 = 15, Bisb2 = 16, Bisb3 = 17, Bleq = 18, Blss = 19, Bneq = 20, Brb = 21, Calls = 22, Casel = 23, Clrb = 24 %Constant %Integer Clrd = 25, Clrf = 26, Clrl = 27, Clrw = 28, Cmpb = 29, Cmpc3 = 30, Cmpd = 31, Cmpf = 32, Cmpl = 33, Cmpw = 34, Cvtbl = 35, Cvtbw = 36, Cvtdf = 37, Cvtrdl= 38, Cvtdw = 39, Cvtfd = 40, Cvtrfl= 41, Cvtfw = 42, Cvtlb = 43, Cvtld = 44, Cvtlf = 45, Cvtlw = 46, Cvtwb = 47, Cvtwd = 48 %Constant %Integer Cvtwf = 49, Cvtwl = 50, Decb = 51, Decl = 52, Decw = 53, Divb3 = 54, Divd2 = 55, Divd3 = 56, Divf2 = 57, Divf3 = 58, Divl2 = 59, Divl3 = 60, Divw2 = 61, Divw3 = 62, Ediv = 63, Incb = 64, Incl = 65, Incw = 66, Jmp = 67, Locc = 68, Mcomb = 69, Mnegb = 70, Mnegd = 71, Mnegf = 72 %Constant %Integer Mnegl = 73, Mnegw = 74, Movab = 75, Movb = 76, Movc3 = 77, Movc5 = 78, Movd = 79, Movf = 80, Movl = 81, Movq = 82, Movw = 83, Movzbl = 84, Movzwl = 85, Mulb3 = 86, Muld2 = 87, Muld3 = 88, Mulf2 = 89, Mulf3 = 90, Mull2 = 91, Mull3 = 92, Mulw2 = 93, Mulw3 = 94, Nop = 95, Pushl = 96 %Constant %Integer Ret = 97, Subb3 = 98, Subd2 = 99, Subd3 = 100, Subf2 = 101, Subf3 = 102, Subl2 = 103, Subl3 = 104, Subw2 = 105, Subw3 = 106, Tstb = 107, Tstd = 108, Tstf = 109, Tstl = 110, Tstw = 111, Xorb2 = 112, Xorb3 = 113 %Constant %Integer %array Op Map(0:113) = 0, {Addb3} x'81' ! Op3 ! bb<>i)&15).S %repeat %result = S %end { of HtoS } %routine Select Out(%integer stream) {Select Out} {==================================} {selects output stream and remembers it for diagnostics} current stream = stream select output(current stream) %end %routine Flush Line {Flush Line} {=================} !outputs a newline iff the last monitored output was not newline NEWLINE %if previous nl = 0 previous nl = 1 %end %routinespec Print Tag(%integer T) %routine Print Record(%record(stackfm)%name V) {Print Record} {============================================} %constant %string(5) %array Forms(Constant:AinR) = "Const", "VinR ", "VinS ", "AVinS", "AinS ", "AutoI", "AutoD","AinR" %constant %string(3)%array ops(Negate:Maxoper) = "NEG", "NOT", "ADD", "SUB", "MUL", "DIV", "REM", "AND", " OR", "XOR" printstring("NULL") %and %return %if v == null %if V_mode = VAL %then printstring("VAL") %c %else %if V_mode = REF %then printstring("REF") %C %else printstring("???") print tag(v_type) space %if constant <= V_Acru <= AinR %then printstring(forms(V_Acru)) %C %else printstring("?????") printstring(" Offset:"); write(V_Offset, 0) %if V_base < 0 %start printstring("++"); write(-v_base, 0) %else printstring("(".sreg(actual(v_base&R Mask)).")") %finish printstring(" Extra:"); write(V_extra, 0) printstring(" Flags:"); write(V_flags, 0) printstring(" Size:"); write(V_Size,0) printstring(" Index:(".sreg(actual(V_index&R Mask)).")") %return %if v_oper = 0 newline spaces(5) printstring(ops(v_oper)); write(v_oper, 6) space; print record(v_link) %end %routine Monitor(%record(stackfm)%name V, %string(63) heading) {Monitor} {============================================================} select output(Report) flush line spaces(3) printstring(heading); printsymbol(':') write(depth,2) spaces(12-length(heading)) print record(v) flush line select output(current stream) %end %routinespec dump using %routine List Reg Usage {=====================} %integer i select output(report) %for i=1,1,16 %cycle printstring(" Register") write(i-1,3) printstring(" Usage = ") write(E_Activity(i),10) printstring(" (Hex) ".htos(E_Activity(i))) %repeat newline printstring(" Total registers in use = ") write(E_Active Registers,4) newline %end { of List Reg Usage } %routine Dump Const Disp {Dump Constant Displacement} {======================} Select Output (Report) Printstring("Constant Displacement :"); Write(Constant Displacement , 4) Newline Select Output (Current Stream) %end %routine dump opstack {===================} %record(stack fm)%name t t == E_Stack %if t==Null %then printstring(" Operand stack empty ") %while t##null %cycle monitor(t,"") t == t_Stp %repeat %end %routine Fail(%string(63) Message) {Fail} {=================================} %integer Warn = 0 select output(Report) Flush Line %if Charno(Message, Length(Message)) = '?' %start length(message) = length(message)-1 printstring("*Warning -- ") Warn = 1 %else printstring("*Simula assembler fails -- ") %finish printstring(Message) printstring(" at source line"); write(current line, 1) newline printstring("Using list:-") newline Dump Using newline selectoutput(Report) printstring("Opstack dump") newline Dump Opstack newline %if Warn = 0 %start List Reg Usage %signal 0,1 %finish Select Output(Current Stream) %end %routine Monitor Register(%string(31) Text, %integer R) {Monitor Register} {=====================================================} select output(Report) flush line spaces(3) printstring(text); spaces(20-length(text)) %if r&F reg # 0 %then printsymbol('F') %C %else %if r&D reg # 0 %then printsymbol('D') %C %else printsymbol(' ') %if r&any # 0 %start printstring("any") %else printstring(sreg(actual(r&rmask))) %finish newline select output(current stream) %end %routine Print Token(%integer C) {Print Token} {===============================} !output the standard mnemonic for the token C. %constant %string(11) %array STOKEN(1:142) = "record", "?????", "prefix", "attr", "???????", "rep", "alt", "fixrep", "endrecord", "c-record", "text", "c-char", "c-int", "c-size", "c-real", "c-lreal", "c-aaddr", "c-oaddr", "c-gaddr", "c-paddr", "c-dot", "r-addr", "nobody", "anone", "onone", "gnone", "nowhere", "true", "false", "profile", "known", "system", "external", "import", "export", "exit", "endprofile", "routinespec", "routine", "local", "endroutine", "module", "existing", "tag", "body", "endmodule", "labelspec", "label", "range", "global", "init", "constspec", "const", "delete", "fdest", "bdest", "save", "restore", "bseg", "eseg", "skipif", "endskip", "if", "else", "endif", "endifc", "precall", "asspar", "assrep", "call", "fetch", "refer", "deref", "select", "remote", "locate", "index", "inco", "deco", "push", "pushc", "pushlen", "dup", "pop", "empty", "setobj", "getobj", "access", "fjump", "bjump", "fjumpif", "bjumpif", "switch", "goto", "t-inito", "t-geto", "t-seto", "add", "sub", "mult", "div", "rem", "neg", "and", "or", "xor", "imp", "eqv", "not", "dist", "assign", "update", "convert", "sconvert", "insert", "zeroarea", "initarea", "compare", "?lt", "?le", "?eq", "?ge", "?gt", "?ne", "eval", "info", "line", "setswitch", "?????", "program", "main", "endprogram", "dsize", "sdest", "rupdate", "asscall", "call-tos", "dinitarea", "nosize", "popall", "repcall", "interface" flush line %if 1 <= C <= 142 %start printstring(stoken(c)) %else %if 143 <= C <= 255 printstring("Reserved token:") write(c, 1) %else printstring("Illegal token:") write(c, 1) %finish previous nl = 0 %end %routine Print Tag(%integer t) {Print Tag} {============================} %constant %string(7)%array PREDEF(1:12) = "BOOL", "CHAR", "INT", "SINT", "REAL", "LREAL", "AADDR", "OADDR", "GADDR", "PADDR", "RADDR", "SIZE" space %if 1 <= t <= 12 %start printstring(predef(t)) %else %if 13 <= t <= 31 printstring("Reserved tag:") write(t, 1) %else printstring("Tag:") write(t, 1) %finish previous nl = 0 %end %routine Vax Code(%integer W, N) {Vax Code} {==============================} %integer mode, reg, v %owninteger expected = 0, xarea = 0, xca = 0 %constinteger PC = 15 %owninteger extra, state=0, p, key, limit %string(15) temp %ownstring(3) prefix %ownstring(72) operand, current, val %ownstring(15) front = "" %conststring(6)%array opcode(0:255) = "halt ","nop ","rei ","bpt ","ret ","rsb ","ldpctx","svpctx", "cvtps ","cvtsp ","index ","crc ","prober","probew","insque","remque", "bsbb ","brb ","bneq ","beql ","bgtr ","bleq ","jsb ","jmp ", "bgeq ","blss ","bgtru ","blequ ","bvc ","bvs ","bgequ ","blssu ", "addp4 ","addp6 ","subp4 ","subp6 ","cvtpt ","mulp ","cvttp ","divp ", "movc3 ","cmpc3 ","scanc ","spanc ","movc5 ","cmpc5 ","movtc ","movtuc", "bsbw ","brw ","cvtwl ","cvtwb ","movp ","comp3 ","cvtpl ","cmpp4 ", "editpc","matchc","locc ","skpc ","movzwl","acbw ","movaw ","pushaw", "addf2 ","addf3 ","subf2 ","subf3 ","mulf2 ","mulf3 ","divf2 ","divf3 ", "cvtfb ","cvtfw ","cvtfl ","cvtrfl","cvtbf "," ","cvtlf ","acbf ", "movf ","cmpf ","mnegf ","tstf ","emodf ","polyf ","cvtfd "," ", "adawi "," "," "," "," "," "," "," ", "addd2 ","addd3 ","subd2 ","subd3 ","muld2 ","muld3 ","divd2 ","divd3 ", "cvtdb ","cvtdw ","cvtdl ","cvtrdl","cvtbd ","cvtwd ","cvtld ","acbd ", "movd ","cmpd ","mnegd ","tstd ","emodd ","polyd ","cvtdf "," ", "ashl ","ashq ","emul ","ediv ","clrq ","movq ","movaq ","pushaq", "addb2 ","addb3 ","subb2 ","subb3 ","mulb2 ","mulb3 ","devb2 ","divb3 ", "bisb2 ","bisb3 ","bicb2 ","bicb3 ","xorb2 ","xorb3 ","mnegb ","caseb ", "movb ","cmpb ","mcomb ","bitb ","clrb ","tstb ","incb ","decb ", "cvtbl ","cvtbw ","movzbl","movzbw","rotl ","acbb ","movab ","pushab", "addw2 ","addw3 ","subw2 ","subw3 ","mulw2 ","mulw3 ","divw2 ","divw3 ", "bisw2 ","bisw3 ","bicw2 ","bicw3 ","xorw2 ","xorw3 ","mnegw ","casew ", "movw ","cmpw ","mcomw ","bitw ","clrw ","tstw ","incw ","decw ", "bispsw","bicpsw","popr ","pushr ","chmk ","chme ","chms ","chmu ", "addl2 ","addl3 ","subl2 ","subl3 ","mull2 ","mull3 ","divl2 ","divl3 ", "bisl2 ","bisl3 ","bicl2 ","bicl3 ","xorl2 ","xorl3 ","mnegl ","casel ", "movl ","cmpl ","mcoml ","bitl ","clrl ","tstl ","incl ","decl ", "adwc ","sbwc ","mtpr ","mfpr ","movpsl","pushl ","moval ","pushal", "bbs ","bbc ","bbss ","bbcs ","bbsc ","bbcc ","bbssi ","bbcci ", "blbs ","blbc ","ffs ","ffc ","cmpv ","cmpzv ","extv ","extzv ", "insv ","acbl ","aoblss","aobleq","sobgeq","sobgtr","cvtlb ","cvtlw ", "ashp ","cvtlp ","callg ","calls ","xfc "," "," "," " %constbyteintegerarray oplimit(0:255) = 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 6, 5, 3, 3, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 6, 4, 6, 5, 6, 5, 6, 3, 3, 4, 4, 5, 5, 6, 6, 1, 1, 2, 2, 3, 3, 3, 4, 4, 4, 3, 3, 2, 4, 2, 1, 2, 2, 2, 3, 2, 3, 2, 3, 2, 2, 2, 2, 2, 0, 2, 4, 2, 2, 2, 1, 5, 3, 2, 0, 2, 0, 0, 0, 0, 0, 0, 0, 2, 3, 2, 3, 2, 3, 2, 3, 2, 2, 2, 2, 2, 2, 2, 4, 2, 2, 2, 1, 5, 3, 2, 0, 3, 3, 4, 4, 1, 2, 2, 1, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 2, 2, 2, 1, 1, 1, 1, 2, 2, 2, 2, 3, 4, 2, 1, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 2, 2, 2, 1, 1, 1, 1, 2, 2, 2, 2, 1, 1, 2, 1, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 2, 2, 2, 2, 6, 3, 2, 2, 0, 0, 0, 0 %constbyteintegerarray opkey(0:256*6-1) = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 1, 2, 1, 0, 0, 2, 1, 2, 1, 0, 0, 4, 4, 4, 4, 4, 4, 1, 4, 2, 1, 4, 0, 1, 2, 1, 0, 0, 0, 1, 2, 1, 0, 0, 0, 1, 4, 0, 0, 0, 0, 1, 4, 0, 0, 0, 0, 11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0, 11, 0, 0, 0,+0, 0,11, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0, 11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0, 2, 1, 2, 1, 0, 0, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 0, 0, 2, 1, 2, 1, 2, 1, 2, 1, 1, 2, 1, 0, 2, 1, 2, 1, 2, 1, 2, 1, 1, 2, 1, 0, 2, 1, 2, 1, 2, 1, 2, 1, 1, 0, 0, 0, 2, 1, 1, 0, 0, 0, 2, 1, 1, 1, 0, 0, 2, 1, 1, 1, 0, 0, 2, 1, 1, 2, 1, 0, 2, 1, 1, 2, 1, 0, 2, 1, 1, 1, 2, 1, 2, 1, 1, 1, 2, 1, 12, 0, 0, 0, 0, 0,12, 0, 0, 0, 0, 0, 2, 4, 0, 0, 0, 0, 2, 1, 0, 0, 0, 0, 2, 1, 1, 0, 0, 0, 2, 1, 1, 0, 0, 0, 2, 1, 4, 0, 0, 0, 2, 1, 2, 1, 0, 0, 2, 1, 1, 1, 0, 0, 2, 1, 2, 1, 0, 0, 1, 2, 1, 0, 0, 0, 1, 2, 1, 0, 0, 0, 2, 4, 0, 0, 0, 0, 2, 2, 2,12, 0, 0, 2, 4, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 1, 0, 0, 0, 0, 4, 2, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 1, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4,12, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 1, 4, 4, 4, 0, 4, 2, 1, 0, 0, 0, 4, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 8, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 8, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 8, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 8, 0, 0, 0, 8, 1, 0, 0, 0, 0, 8, 2, 0, 0, 0, 0, 8, 4, 0, 0, 0, 0, 8, 4, 0, 0, 0, 0, 1, 8, 0, 0, 0, 0, 2, 4, 0, 0, 0, 0, 4, 8, 0, 0, 0, 0, 8, 8, 8,12, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 8, 1, 8, 4, 8, 0, 8, 2, 1, 0, 0, 0, 8, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 4, 4, 0, 0, 0, 1, 8, 8, 0, 0, 0, 4, 4, 4, 8, 0, 0, 4, 8, 4, 4, 0, 0, 8, 0, 0, 0, 0, 0, 8, 8, 0, 0, 0, 0, 8, 4, 0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 4, 0, 0, 0, 0, 1, 2, 0, 0, 0, 0, 1, 4, 0, 0, 0, 0, 1, 2, 0, 0, 0, 0, 1, 4, 4, 0, 0, 0, 1, 1, 1,12, 0, 0, 1, 4, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4, 1,11, 0, 0, 0, 4,11, 0, 0, 0, 0, 4,11, 0, 0, 0, 0, 4, 1, 1, 4, 0, 0, 4, 1, 1, 4, 0, 0, 4, 1, 1, 4, 0, 0, 4, 1, 1, 4, 0, 0, 4, 1, 1, 4, 0, 0, 4, 1, 1, 4, 0, 0, 4, 4, 1, 1, 0, 0, 4, 4, 4,12, 0, 0, 4, 4,11, 0, 0, 0, 4, 4,11, 0, 0, 0, 4,11, 0, 0, 0, 0, 4,11, 0, 0, 0, 0, 4, 1, 0, 0, 0, 0, 4, 2, 0, 0, 0, 0, 1, 2, 1, 1, 2, 1, 4, 2, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 4, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 %switch st(0:3), ops(0:15) %string(2)%fn hex(%integer x) {hex} {===========================} %conststring(1)%array xsym(0:15) = "0","1","2","3","4","5","6","7", "8","9","A","B","C","D","E","F" %string(1) U, L U = Xsym(X>>4&15) L = Xsym(X&15) %result = U.L %end %string(6)%fn Addr(%integer N) {Addr} {============================} %result = hex(n>>16).hex(n>>8).hex(n) %end %routine dump line {Dump Line} {================} select output(Report) flush line spaces(20-length(val)) printstring(val) val = "" space printstring(front); front = " " space printstring(current); current = "" newline select output(current stream) %end %while n > 0 %cycle n = n-1 v = w&255 w = w>>8 xca = xca+1 ->st(state) st(0): %if xca-1 # expected %or current area # xarea %start xarea = current area expected = ca xca = ca+1 front = "A".hex(xarea>>8).hex(xarea)." " %else front = " " %finish front = front.addr(xca-1) current = opcode(v); operand = ""; prefix = "" p = v*6 key = 0 limit = oplimit(v) val = " ".hex(v) ->complete %if limit = 0 state = 1 key = 1 %continue st(1):val = hex(v).val %if opkey(p) > 10 %start state = 2 extra = opkey(p)-10; ->st2 %finish mode = v>>4&15 reg = v&15 extra = 0 ->ops(mode) ops(0):ops(1):ops(2):ops(3): operand = "S^".hex(v).operand; ->complete ops(4):operand = "[".sreg(reg)."]".operand; %continue ops(5):operand = sreg(reg).operand; ->complete ops(8): ops(9): ops(6): ops(7):prefix = "" %if reg = pc %and mode >= 8 %start prefix = "I^#" temp = "" extra = opkey(p) prefix = "@#" %and extra = 4 %if mode = 9 %else temp = "(".sreg(reg).")" temp = temp."+" %if mode >= 8 temp = "-".temp %if mode = 7 temp = "@".temp %if mode = 9 %finish operand = temp.operand ->complete %if extra = 0 state = 2; %continue ops(10):ops(11): prefix = "B^"; extra = 1; ->rest ops(12):ops(13): prefix = "W^"; extra = 2; ->rest ops(14):ops(15): prefix = "L^"; extra = 4 rest: prefix = "@".prefix %if mode&1 # 0 %if reg # pc %start operand = "(".sreg(reg).")".operand %finish state = 2 %continue st(2):val = hex(v).val st2: operand = hex(v).operand extra = extra-1 %continue %if extra > 0 operand = prefix.operand complete: Dump Line %if length(current)+length(operand) > 40 current = current." ".operand operand = "" %if key = limit %start dump line state = 0 expected = xca %continue %finish key = key+1 p = p+1 current = current."," state = 1 %repeat %end !Basic input procedures %routine Next Token {Next Token} {=================} !gets the next item from the input. !the assembler runs one byte ahead of the input stream in order !to permit efficient look-ahead (in PENDING) token = pending readsymbol(pending) %if Monitor Input # 0 %start select output(Report) write(token, 1) previous nl = 0 select output(current stream) %finish %end %routine Get Token {Get Token} {================} !gets the next Scode token from the input, and Reports it if required. %owninteger More = 1 %on 9 %start Fail("Input Ended") %if More = 0 More = 0 Pending = 0 %else token = pending; readsymbol(pending) %finish %if monitor input # 0 %start select output(Report) print token(token) select output(current stream) %finish %end %integerfunction Number {=====================} !Return the next two bytes as an unsigned 16-bit number %integer n n = pending readsymbol(token); readsymbol(pending) n = n<<8!token %if monitor input # 0 %start select output(Report) write(n, 1); previous nl = 0 select output(current stream) %finish %result = n %end %string(31)%function String 31 {============================} %integer n, s %string(31) text text = "" n = pending {string length} %while n > 0 %cycle n = n-1 readsymbol(s) s = s-'a'+'A' %if 'a' <= s <= 'z' text = text.tostring(s) %if length(text) # 31 %repeat readsymbol(pending) %if Monitor Input # 0 %start select output(Report) printstring(" """.text.""""); previous nl = 0 select output(current stream) %finish %result = text %end !Final pass communication %routine Ocode(%integer item) {Ocode} {===========================} !send ITEM to the object stream, leaving that stream selected select out(Obj) printsymbol(item) %end %routine Dcode(%integer item) {Dcode} {===========================} !send ITEM to the directive stream, leaving that stream selected select out(DIR) printsymbol(item) %end %routine Put Long(%integer Item) {==============================} !output item as four bytes on the current output stream %integer i %for i=24,-8,0 %cycle printsymbol(Item>>i&255) %repeat %end { of Put Long } %routine Put(%integer item) {Put} {=========================} !output item as two bytes on the current output stream printsymbol(item>>8&255) printsymbol(item&255) %end %routine Put Byte(%integer V) {Put Byte} {===========================} Vax Code(v, 1) %if Monitor Output # 0 printsymbol(OBJ byte) printsymbol(v&255) ca = ca+1 %end %routine Put Word(%integer V) {Put Word} {===========================} Vax Code(v, 2) %if Monitor Output # 0 printsymbol(OBJ word) printsymbol(v&255) printsymbol(v>>8&255) ca = ca+2 %end %routine Put Longword(%integer V) {Put Longword} {===============================} Vax Code(v, 4) %if Monitor Output # 0 printsymbol(OBJ longword) printsymbol(v&255) printsymbol(v>>8&255) printsymbol(v>>16&255) printsymbol(v>>24&255) ca = ca+4 %end %routine Put Floating(%longreal V) {Put Floating} {================================} put longword(integer(addr(v))) %end %routine Put Double(%longreal V) {Put Double} {==============================} put longword(integer(addr(v))) put longword(integer(addr(v)+4)) %end %routine Put String(%string(63) S) {Put String} {================================} %integer N printsymbol(Length(S)) printsymbol(Charno(S, N)) %for N = 1,1,Length(S) %end !Area control %routine Select Area(%integer Area Id,Size, %integername Base) {Select Area} {=======================================================} !Subsequently, all data output will be placed in the specified area. !BASE specifies the current displacement into the area. %return %if Current Area = Area Id %and Size = 0 Current Area = Area Id ca == base dcode(DIR select); put(area id) ocode(OBJ select); put(area id); Put Long(Size) %end %routine Locate Ca(%integer Area Id, %integername Base) {Locate Ca} {=====================================================} !Adjust CA to point to DISPLACEMENT on from the start of the given area %if Area Id # Current Area %start Select Area(Area Id,0, Base) %else Ca == Base %finish Printsymbol(OBJ locate); Put Long(Ca) %end %routine New Area(%integer Area Id, %integername Base) {New Area} {====================================================} !Create a new area and select it Dcode(DIR new area); Put(Area Id) Free Label = Free Label+1; Put(Free Label) Base = 0 Locate Ca(area id, base) %end %routine End Area {End Area} {===============} !Complete the definition of the current area !Note that CA must hold the current size of the area dcode(DIR end area); Put Long(ca) select out(Obj) %end %routine Add Area(%integer Area id, Size) {Add Area} {=======================================} !Add the given area at the current point (CA) in the current area. !The area must have been completed (using END AREA). dcode(DIR add area); put(area id); Put Long(Ca); Put Long(Size) Select Out(Obj) Ca = Ca+Size Select Area(Current Area, Size, Ca) %end %routinespec Define Reference(%integer Type, Label, CC) %routine Dump Constant(%integer Type, Area, %integername At) {Dump Constant} {=============================================} %switch T(Bool:Size) %integer Old Area %integername Old Ca Old Area = Current Area Old Ca == Ca %if Area > 0 %start Locate Ca(-Area, At) %else %if Area = 0 {append in current area} Locate Ca(Current Area, At) %else Locate Ca(Constant Area, At) %finish Fail("Unknown type in Dump Constant") %unless Bool<=Type<=Size ->T(Type) T(Bool): T(Char): Put Byte(Integer Literal); ->Done T(Paddr): Define Reference(ObjDir Paddr,Integer Literal,-1) T(Int): T(Aaddr): T(Raddr): T(Size): Put Longword(Integer Literal); ->Done T(Sint): Put Word(Integer Literal); ->Done T(Real): Put Floating(Real Literal); ->Done T(Lreal): Put Double(Real Literal); ->Done T(Oaddr): T(Gaddr): Ocode(7) { rel inst } Put(-Area) Put Longword(Integer Literal) Put Longword(0) %unless Type = Oaddr Done: Select Area(Old Area, 0, Old Ca) %end { of Dump Constant } %routine Dump External(%integername At) {Dump External} {=====================================} !Write a constant which is an external tag to the constant area %integername Old Ca %integer Old Area Old Ca == Ca Old Area = Current Area Locate Ca(Constant Area,At) Printsymbol(Obj Relinst) Put(Tagv_Module<<2) Put Longword(Tagv_Displacement) Locate Ca(Old Area,Old Ca) %end { of Dump External } !Post processing of entry masks and local name space %routine Fix Mask(%integer Label) {===============================} Dcode(ObjDir Mask) Put(Label) Put Long(Ca) Ocode(ObjDir Mask) Put(Label) Put(Regs Used&(\1)) { do not save R0 } %end { of Fix Mask } %routine Fix Locals(%integer Label) {=================================} Dcode(ObjDir Locals) Put(Label) Put Long(Ca) Ocode(ObjDir Locals) Put(Label) Put(Local Displacement) %end { of Fix Locals } !Descriptor processing %routinespec Release(%integer Register) !These procedures work on the current environment E. !The free descriptors from the pool STACKED are linked together !on a list headed by E_ASL, those in use are held on the list !headed by E_USING. The reason for the USING list is to permit !HAZARD to find any descriptors using a particular register when !that register is needed for other purposes. %record(stackfm)%map Descriptor {=============================} !Returns a free descriptor, having moved it from ASL to USING. !The record is cleared. %record(stackfm)%name work Fail("No free descriptors") %if E_asl == null work == E_asl; E_asl == work_using work_data = 0 work_using == E_using; E_using == work %result == work %end %routine Clear(%record(stackfm)%name V) {Clear} {=====================================} %if V_Base # 0 %start Release(V_Base) %finish Release(V_Index) %if V_Index # 0 %end %routine Dispose(%record(stackfm)%name V) {Dispose} {=======================================} !Return the given descriptor to the free list, releasing any !registers it uses in the process. %record(stackfm)%name u, w, last monitor(v, "Dispose") %if control&1 # 0 Fail("Disposing complex descriptor?") %if V_oper # 0 %or V_A ## Null Clear(V) u == E_using %if u == v %start E_using == u_using {cheap, remove the first} %else {more expensive, search for it} last == u {for adding the remainder later} E_using == null %cycle Fail("Descriptor not claimed") %if u == null {not there} w == u_using u_using == E_using; E_using == u {onto using list} %exit %if w == v {found it} u == w {try the next} %repeat last_using == w_using {add on the remainder} %finish v_using == E_asl E_asl == v %end %routine Drop(%record(stackfm)%name V) {Drop} {====================================} V_base = no reg; V_index = no reg dispose(V) %end %routine Return(%record(stackfm)%name V) {Return} {======================================} Return(V_Link) %and V_Link == Null %if V_Oper >= Add V_Oper = 0 Clear(V) Drop(V) %end %integer %function Stack Depth (%record(Stack Env Fm) %name Env) {==============================================================} %integer i = 0 %record(Stack Fm) %name S S == Env_Stack %while S ## Null %cycle i = i + 1 S == S_Stp %repeat %result = i %end { of Stack Depth} %routine Stacked Descriptor {Stacked Descriptor} {=========================} Tos == Descriptor Tos_stp == E_stack; E_stack == Tos Depth = Depth + 1 %end %record(stackfm)%map Literal(%integer n) {======================================} %record(stackfm)%name w w == descriptor w_Mode = Constant w_Type = Int w_Offset = N monitor(w, "Literal") %if control&1 # 0 %result == w %end %routine Promote Sos {Promote Sos} {==================} %if E_Stack ## Null %and E_Stack_Stp ## Null %start Tos == E_Stack_Stp E_Stack == Tos %finish %else Fail("Stack underflow") Depth = Depth - 1 %end %routine Set Sos {Set Sos} {==============} %if E_Stack ## Null %and E_Stack_Stp ## Null %start Sos == E_Stack_Stp %finish %else Fail("Stack underflow") %end %routine Pop and Set {Pop and Set} {==================} %if E_Stack ## Null %and E_Stack_Stp ## Null %start Sos == E_Stack_Stp E_Stack == Sos %finish %else Fail("Stack Underflow") Depth = Depth - 1 %end %routine Stack Integer(%integer Type) {Stack Integer} {===================================} Stacked Descriptor Tos_Offset = Integer Literal Tos_Type = Type Tos_Mode = Val Tos_Acru = Constant %end %routine Stack Real(%integer Type) {Stack Real} {================================} Stacked Descriptor Tos_Type = Type Tos_Mode = Val Tos_Acru = Constant Tos_Rvalue = Real Literal %end { of Stack Real } %routine Stack External(%integer Type) {Stack External} {====================================} ! Create a new Tos which is a descriptor for an external tag of "Type" Stacked Descriptor Tos_Type = Type Tos_Acru = AVinS Tos_Base = -(Tagv_Module<<2) Tos_Offset = Tagv_Displacement Monitor(Tos,"External") %if control&2#0 %end { of Stack External } %predicate Const(%record(stackfm)%name V) {Const} {=======================================} %false %if v_Acru # constant %or v_oper # 0 %false %if v_type # int %and v_type # sint %and v_type # sint %true %end %routine Copy Stack(%record(stack env fm)%name From, To) {Copy Stack} {=======================================================} !Take a copy of the environment FROM and put it in TO. !The routine is complicated by the fact that for efficiency !the environment contains pointer variables which point into the !environment itself, and these need to be relocated into the new !environment. The environments are held this way because !they will be used far more often than they will be copied. %integer p %record(stackfm) %name f, t, u, st, sf %record(stackfm)%map New P = P+1 %result == To_Stacked(P) %end p = 0 u == null st == null; sf == from_stack to = from {move in the fixed junk} %while sf ## null %cycle f == sf t == New t = f %if T_A ## Null %start T_A == New T_A = F_A T_A_Using == U; U == T_A %finish t_stp == st; st == t t_using == u; u == t {add to using list} %while f_link ## null %cycle f == f_link T_Link == New t == t_link t = f %if T_A ## Null %start T_A == New T_A = F_A T_A_Using == U; U == T_A %finish t_using == u; u == t %repeat sf == sf_stp %repeat to_using == u !reverse the stack copy (created backwards) t == null %while st ## null %cycle f == st_stp st_stp == t t == st st == f %repeat to_stack == t !complete the asl to_asl == null %while p # max stacked %cycle p = p+1; t == to_stacked(p) t_using == to_asl; to_asl == t %repeat Fail("Empty descriptor pool in copy stack") %if to_asl==null %end { of Copy Stack } %routine Clear Stack(%record(stack env fm)%name E) {Clear Stack} {================================================} E = 0 copy stack(E, E) {to set up ASL etc.} E_Activity(no reg) = -1 {lock dedicated registers} E_Activity(R11) = -1 E_Activity(AP) = -1 E_Activity(FP) = -1 E_Activity(SP) = -1 E_Activity(PC) = -1 %end !Register handling procedures %routine Claim(%integer Register) {Claim} {===============================} !note that REGISTER is currently in use !Double-length floating-point registers are pairs of general registers. !When registers are claimed the appropriate entry in ACTIVITY is incremented !to be decremented later by RELEASE. An extra 256 is added to keep track !of floating-point pairs. -1 is used in ACTIVITY to mark general registers !which have pre-defined uses and cannot be altered (e.g. PC, SP). !CLAIM and RELEASE accept these registers in order to simplify !register management. !USE records the point of last use of the register to maintain a !L.R.U. scheme for register allocation: see REGISTER. %integer %name A, A1 %integer R %return %if Register <= 0 R = Register&Rmask Fail("Dubious register") %unless R <= R15 {claim noreg is a convenient no-op} monitor register("Claim", register&(\No Check)) %if control&1 # 0 a == E_activity(r); E_used(r) = ca; Regs Used = Regs Used!(1<<(r-1)) %if register&D reg # 0 %start {claim a pair} Fail("PC misused") %if register = PC a1 == E_activity(r+1); E_used(r+1) = ca; Regs Used = Regs Used!(1<>24 + A1>>24 %continue %if X=0 %and A0>256 %continue %if X=1 %and A0<256 %and A1>256 %continue %if X=1 %and A0>256 %and A1<256 %if A = 0 %thenstart Rv == Descriptor Rv_Acru = VinR E_Dumped Activity(Rx) = E_Activity(Rx) %if X=1 %thenstart E_Dumped Activity(Rx+1) = A1 E_Activity(Rx+1) = 0 R = R!D Reg!No Check %finish E_Activity(Rx) = 0 Claim(R) Rv_Base = R&(\No Check) Overflow_Offset = (Rx-2)*4 - 124 %if X=0 %then Plant2(Movl,Rv,Overflow) %else Plant2(Movq,Rv,Overflow) Rv_Flags = Reg Dumped E_Activity(Rx) = E_Activity(Rx)!x'10000000' %if X=1 %then E_Activity(Rx+1) = E_Activity(Rx+1)!x'10000000' %result == Rv %finish %repeat Fail("No free dump cells") %result == Null %end { of Free some Regs } %record(stackfm)%map Register(%integer Which) {===========================================} %record(stackfm)%name RV %integer p, limit, x, r, rx %integer A0, A1, A %constant %byte %array C(1:29) = R6,R7,R8,R9,R10,R4,R5,R3,R2,R1, R6,R7,R8,R9,R10,R4,R5,R3,R2,R1, D6, D7, D8, D9, D5, D2, D3, D4, D1 rv == descriptor rv_Acru = VinR x = 0 %if which&Plus 5 # 0 %start %if which&(D Reg!F Reg) = 0 %start rv_type = int; p = 0; Limit = 5 %else %if which&F Reg # 0 rv_type = real; p = 10; limit = 12 %else rv_type = lreal; p = 20; limit = 25 x = 1 %finish %else %if which&(d reg!f reg) = 0 %start {integer} rv_type = int; p = 0; limit = 10 %else %if which&f reg # 0 {floating} rv_type = real; p = 10; limit = 20 %else {double} rv_type = lreal; p = 20; limit = 29 x = 1 %finish %finish %if which&any = 0 %start {specific register required} rv_base = which; claim(which); %result == rv %finish %while p # limit %cycle p = p+1 rx = C(p); r = rx&rmask a0 = E_activity(r); %continue %if a0 < 0 a1 = E_activity(r+x); %continue %if a1 < 0 a = a0+a1 %if a = 0 %start rv_base = rx; claim(rx); %result == rv %finish %repeat Dispose(Rv) %result == Free Some Regs(1,Which) %end %record(stackfm)%map Register Pair {================================} %record(stackfm)%name Rv %integer R,i %constintegerarray Pair(1:9) = R6, R7, R8, R9, R5, R4, R3, R2, R1 %for i = 1,1,9 %cycle R = Pair(i) %if E_Activity(R) = 0 %and E_Activity(R+1) = 0 %start Rv == Descriptor Rv_Base = R!D Reg; Claim(R!D Reg) Rv_Acru = VinR Rv_Type = Gaddr %result == Rv %finish %repeat %result == Free Some Regs(2,Any) %end { of Register Pair } !code generation procedures %routine Operand(%record(stackfm)%name V, %integer Type) {Operand} {======================================================} !TYPE is the data type required by the instruction !This routine is complicated by the fact that operands are !not self-defining; they are affected by the instruction using them!!!! %integer abase, ind, form, disp, Index %switch F(Constant:AinR) monitor(V, "Operand") %if control&2 # 0 Form = V_Acru Index = V_Index Fail("Dubious operand") %unless V_Oper = 0 %and V_A == Null %and Constant <= Form <= AinR Disp = V_Offset Put Byte(Actual(Index)+x'40') %if Index # 0 %if V_Base < 0 %start {Relocatable} Put Byte(x'9F') Printsymbol(Obj Relinst); put(-V_Base) Fail("Faulty relocation") %if Form # VinS %and Form # AVinS Put Longword(Disp) %return %finish Abase = Actual(V_Base&Rmask) Fail("Dubious base register") %if V_Base&(Freg!Dreg)#0 %and Form#VinR %and Form#AinR ->F(form) F(constant):Fail("Misplaced index") %if Index # 0 %if V_Flags&NoneF=0 %and Type#AB %and Oaddr<=V_Type<=Raddr %then -> relocate %if type = FF %or type = DD %start Fail("Spurious operand type") %if DD # Dense(V_type) # FF %if disp&x'FFFFBC0F' = 0 %and disp&X'4000' # 0 %and V_extra = 0 %start {can use short immediate} put byte(disp>>4&b'00111111') %return %finish %else %if 0 <= disp <= 63 %start put byte(disp); %return %finish %finish relocate: put byte(x'8F') %if Oaddr<=V_Type<=Gaddr %thenstart Printsymbol(Obj Relinst) Put(-Constant Area) %finishelsestart %if Paddr<=V_Type<=Raddr %thenstart Printsymbol(ObjDir Paddr) Put(Disp) Put Longword(0) %return %finish %finish %if type = LL %or type = FF %start put longword(disp) %else %if type = WW put word(disp) %else %if type = BB put byte(disp) %else %if type = DD %or Type = QQ put longword(disp) put longword(V_extra) %finish %else Fail("Spurious operand") %return F(AVinS): Fail("Not an address") %if type # AB form = VinS !and fall through to ..... F(VinS): %if V_Base # Ap %and disp = 0 %start {->VinR} put byte(x'60'+abase) %return %finish F(AinS): ind = abase ind = abase+x'10' %if form = AinS Disp = Disp + 4 %if V_Base = Ap { one long word back on stack, to allow for arg cnt } Disp = -Disp %if V_Base = Fp { decremental addressing on stack for locals } Disp = Disp-4 %if V_Base=Fp %and V_Size=8 { Movq will be used } %if 1<=V_Size<=2 %and V_Base=Fp %then Disp = Disp + V_Size %if -128 <= disp <= 127 %thenstart put byte(x'A0'+ind) put byte(disp&255) %finishelsestart %if x'FFFF8000' <= disp <= x'00007FFF' %thenstart put byte(x'C0'+ind) put word(disp) %finishelsestart put byte(x'E0'+ind); put longword(disp) %finish %finish %return F(AinR): Fail("Complex descriptor for AinR") %if Disp#0 F(VinR): Fail("Misplaced index") %if index # 0 put byte(x'50'+abase) %return F(AutoI): %if Disp = 0 %start Put Byte(Abase+x'80') %return %finish F(AutoD): %if Disp = 0 %start Put Byte(Abase+x'70') %return %finish Fail("non-zero displacement") %return %end %predicate Same(%record(stackfm)%name A, B) {=========================================} %true %if A_Offset = B_Offset %and A_Base = B_Base %and A_Acru = B_Acru %and A_Index = B_Index %false %end %routinespec Plant4(%integer Op, %record(stackfm)%name V1, V2, V3, V4) %routine Plant0(%integer Op) {Plant0} {==========================} {zero operand planting} Op = Op Map(Op) Fail("Wrong number of operands") %if Op&(Op1!Op2!Op3!Op4!Op5) # 0 Put Byte(Op&255) %end %routine Plant1(%integer OP, %record(stackfm)%name V1) {Plant1} {====================================================} {single operand instruction planting} op = op map(op) Fail("Wrong number of operands") %if op&op1 = 0 put byte(op&255) operand(v1, op>>o1&7) %end %routine Plant2(%integer OP, %record(stackfm)%name V1, V2) {Plant2} {========================================================} {double operand instruction planting} %integer X %switch Opt(0:15) X = Op Opt Map(Op) ->Opt(X>>5) %if X # 0 %and V1_Flags&BoolFl=0 Normal: op = op map(op) Fail("Wrong number of operands") %if op&op2 = 0 put byte(op&255) operand(v1, op>>o1&7) operand(v2, op>>o2&7) %return Opt(1): %if V2_Acru=AutoD %and V2_Base=Sp %thenstart %if Op=Movl %thenstart Plant1(Pushl, V1) %return %finish %if Op=Movb %thenstart Plant2(Movzbl,V1,V2) %return %finish %if Op=Movw %thenstart Plant2(Movzwl,V1,V2) %return %finish %finish ->Normal %unless V1_Acru = Constant x = x&31 %if x <= 2 %start {integer op} %if V1_Offset = 0 %start Plant1(Clearop(x), V2) %else %if V1_Offset < 0 V1_Offset = -V1_Offset Plant2(Mop(x), V1, V2) %finish %else ->Normal %else {real op} %if V1_Rvalue = 0 %start Plant1(Clearop(x), V2) %else %if V1_Rvalue < 0 V1_Rvalue = -V1_Rvalue Plant2(Mop(x), V1, V2) %finish %else ->Normal %finish %return Opt(2): ->Normal %unless V1_Acru = Constant %and |V1_Offset| = 1 X = X&31 X = X!!2 %if V1_Offset < 0 Plant1(Incdecop(x), V2) %return Opt(3): %if V2_Acru = Constant %and V2_Offset = 0 %start Plant1(Testop(x&15), V1) %return %finish ->Normal %unless V1_Acru = Constant %and V1_Offset = 0 Plant1(Testop(x&15), V2) Reversed = Reversed!!7 %return Opt(*): Fail("Bad 2 optimisation") %end %routine Plant3(%integer OP, %record(stackfm)%name V1, V2, V3) {Plant3} {============================================================} {triple operand instruction planting} %record(stackfm)%name Temp %integer Cvt, X %switch Opt(1:7) %if Op=Movc3 %start %if V2_Base=Fp %start V2_Offset=V2_Offset+V1_Offset-4 %else %if V3_Base = Fp %then V3_Offset = V3_Offset+V1_Offset-4 %finish %finish %if op < 0 %start {special operation} %if Op = X And %start %if V1_Flags&NoNot = 0 %start Plant2(Mcomb, V1, Minus Sp) V1 == Sp Plus %finish Op = Bicb3 %else %if Op = X Rem %if V2_Type = Longword %start Cvt = Movl %else %if V2_Type = Word Cvt = Cvtwl %finish %else Fail("Bad operand") Plant2(Cvt, V2, Minus Sp) Plant1(Clrl, Minus Sp) Plant3(Ashq, Cm31, At Sp, At Sp) %if V1_Type = Word %start Plant2(Cvtwl, V1, Minus Sp) V1 == Sp Plus %else Fail("Bad operand") %if V1_Type # Longword %finish Plant4(Ediv, V1, Sp Plus, Rv0, V3) %return %finish %else Fail("Unknown special operation") %finish x = Op Opt Map(Op) ->Opt(x>>5) %if x # 0 Normal: op = op map(op) Fail("Wrong number of operands") %if op&op3 = 0 put byte(op&255) operand(v1, op>>o1&7) operand(v2, op>>o2&7) operand(v3, op>>o3&7) %return Opt(3): %if V1_Acru = Constant %and V1_Offset < 0 %start V1_Offset = -V1_Offset Op = Aop(x&15); x = Op Opt Map(Op) %finish ->Opt(1) Opt(2): %if V1_Acru = Constant %and V1_Offset < 0 %start V1_Offset = -V1_Offset Op = Sop(X&15); x = Op Opt Map(Op) %else %if V2_Acru = Constant %and V2_Offset < 0 V2_Offset = -V2_Offset Temp == V1; V1 == V2; V2 == Temp Op = Sop(X&15); x = Op Opt Map(Op) %finish Opt(1): ->Normal %unless Same(V2, V3) Plant2(Two op(x&31), V1, V2) %return Opt(*): Fail("Bad 3 optimisation") %end %routine Plant4(%integer Op, %record(stackfm)%name V1, V2, V3, V4) {Plant4} {================================================================} {four operand instruction planting} Op = Op Map(Op) Fail("Wrong number of operands") %if Op&Op4 = 0 Put Byte(Op&255) Operand(V1, Op>>O1&7) Operand(V2, Op>>O2&7) Operand(V3, Op>>O3&7) Operand(V4, Op>>O4&7) %end %routine Plant5(%integer op, %record(stackfm)%name V1, V2, V3, V4, V5) {Plant5} {====================================================================} op = Op Map(op) Fail("Wrong number of operands") %if op&op5 = 0 put byte(op&255) operand(v1, op>>o1&7) operand(v2, op>>o2&7) operand(v3, op>>o3&7) operand(v4, op>>o4&7) operand(v5, op>>o5&7) %end %routine Plant Skip(%integer cc, n) {Plant Skip} {=================================} %constbytearray Skipop(0:27) = {normal} Brb, Blss, Bleq, Beql, Bgeq, Bgtr, Bneq, {reversed} Brb, Bgtr, Bgeq, Beql, Bleq, Blss, Bneq, {inverted} 0, Bgeq, Bgtr, Bneq, Blss, Bleq, Beql, {reversed & inverted} 0, Bleq, Blss, Bneq, Bgtr, Bgeq, Beql Put Byte(Op Map(Skipop(cc+Inverted+Reversed))&255) Put Byte(n) Inverted = 0 Reversed = 0 %end %routinespec Operate(%integer op, %record(stackfm)%name Lhs, Rhs) %routine Address(%record(stackfm)%name V) {Address} {=======================================} {reduce the address components of V into a form acceptable to an instruction} {this can be made more efficient by allowing use of @X[R] operands} %record(Stack Fm) Reg %record(stackfm)%name R, A %integer Type = V_Type, Size = V_Size, Bias = 0 %integer Acru %if V_Oper # 0 %start Loadup(V) V_Size = Size %return %finish A == V_A; V_A == Null {Aaddr component} %if A ## Null %start %if A_Oper # 0 %start %if A_Link_Acru = Constant %and A_Oper = Add %start Bias = A_Link_Offset Dispose(A_Link); A_Link == Null A_Oper = 0 %else Load(A, Any I) %finish %finish V_Offset = V_Offset+Bias %if A_Acru = Constant %start V_Offset = V_Offset+A_Offset %else Load(A, Any I) R == Register(Any I) V_Index = A_Base Plant2(Movab, V, R) Clear(V) Acru = V_acru V_Data = R_Data Drop(R) V_Acru = Acru %finish Drop(A) %finish %if V_Acru = AVinS %start %if V_Type=Gaddr %thenstart R == Register Pair Reg = 0 Reg_Base = R_Base&R Mask+1 Reg_Acru = VinR Plant1(Clrl,Reg) %finishelse R == Register(Any I) Plant2(Movab, V, R) Clear(V) V_Data = R_Data Drop(R) V_Acru = AinR V_A == Null %finish V_Type = Type V_Size = Size %end %routine Load(%record(stackfm)%name V, %integer R) {Load} {================================================} %record(stackfm)%name W, Reg %integer Oper, Type %switch Op(0:Maxoper) Oper = V_Oper; V_oper = 0 %if Oper = 0 %and V_Acru = VinR %start %return %if R&Any # 0 %or R = V_Base %finish W == V_Link; V_Link == Null Address(W) %if Oper >= Add Address(V) Type = V_Type %if Type = Gaddr %start Fail("Gaddr operation") %if Oper # 0 Reg == Register Pair %else Reg == Register(R) %finish Reg_Type = Type Fail("Record operation") %if Type > Size %or (W ## Null %and W_Type > Size) ->Op(Oper) Op(Negate): Plant2(Negop(Type), V, Reg); ->Set Op(Complement): Plant2(Mcomb, V, Reg); ->Set Op(Add): Plant3(Addop(Type), W, V, Reg); ->Set Op(Subtract): Plant3(Subop(Type), W, V, Reg); ->Set Op(Multiply): Plant3(Mulop(Type), W, V, Reg); ->Set Op(Divide): Plant3(Divop(Type), W, V, Reg); ->Set Op(Remainder): Plant3(X Rem, W, V, Reg); ->Set Op(Or): Plant3(Bisb3, w, v, Reg); ->Set Op(And): Plant3(X And, W, V, Reg); ->Set Op(Xor): Plant3(Xorb3, W, V, Reg); ->Set Op(0): Plant2(Loadop(type), V, Reg) Set: Clear(V) V_Data = Reg_Data Dispose(W) %unless W == Null Drop(Reg) %end %routine Load Up(%record(stackfm)%name V) {Load Up} {=======================================} %if v_type = lreal %start load(v, any d) %else %if v_type = real load(v, any f) %else load(v, any) %finish %end %routine Operate(%integer Operation, %record(stackfm)%name Lhs, Rhs) {Operate} {==================================================================} %integer lhs var = 1, rhs var = 1, with var = 1 %record(stackfm)%name with %integer op, key, Opflag, Linkflag %routine Constant Operation(%integer Op, %record(stackfm)%name L, R) {Constant Operation} {==================================================================} %switch Cop(Negate : Maxoper) ->Cop(Op) Cop(Negate): %if Real<=L_Type<=Lreal %then L_Rvalue = -L_Rvalue %c %else L_Offset = -L_Offset %return Cop(Complement): L_Offset = ~L_Offset; %return Cop(Subtract): %if Real<=L_Type<=Lreal %then L_Rvalue = L_Rvalue-R_Rvalue %c %else L_Offset = L_Offset-R_Offset %return Cop(Add): %if Real<=L_Type<=Lreal %then L_Rvalue = L_Rvalue+R_Rvalue %c %else L_Offset = L_Offset + R_Offset %return Cop(Multiply): %if Real<=L_Type<=Lreal %then L_Rvalue = L_Rvalue*R_Rvalue %c %else L_Offset = L_Offset*R_Offset %return Cop(Divide): Fail("Zero divide") %if R_Offset=0 %if Real<=L_Type<=Lreal %then L_Rvalue = L_Rvalue/R_Rvalue %c %else L_Offset = L_Offset//R_Offset %return Cop(Remainder): Fail("Zero divide") %if R_Offset = 0 L_Offset = rem(L_Offset, R_Offset); %return Cop(And): L_Offset = L_Offset&R_Offset; %return Cop(Or): L_Offset = L_Offset!R_Offset; %return Cop(Xor): L_Offset = L_Offset!!R_Offset; %return %end %routine Swop {Swop} {===========} %integer temp var %record(datafm) temp temp var = lhs var; lhs var = rhs var; rhs var = temp var temp = lhs_data; lhs_data = rhs_data; rhs_data = temp %end Opflag = Oper Flags(Operation) %if Opflag&unary # 0 %start %if lhs_oper = 0 %start %if lhs_Acru = constant %start constant operation(operation, lhs, Null) %return %finish %else {unary(a oper b)} lhs_oper = 0 %and %return %if lhs_oper = operation %if Oper Flags(lhs_oper)&unary # 0 %start {-not or not-} with == literal(1) %if operation = negate %then operate(add, lhs, with) %C %else operate(subtract, lhs, with) %return %finish load up(lhs) %finish lhs_oper = operation %return %finish lhs var = 0 %if CONST(lhs) rhs var = 0 %if CONST(rhs) swop %if lhs var = 0 %and Opflag&commutative # 0 %if operation = subtract %and rhs var = 0 %start {convert A-const into A+(-const)} operation = add rhs_Offset = -rhs_Offset %finish %if lhs_oper # 0 %start op = lhs_oper Link Flag = Oper Flags(op) %if Link Flag&unary # 0 %start %if operation = add %and op = negate %start {(-a)+b -> b-a lhs_oper = 0 swop lhs_oper = subtract; lhs_link == rhs lhs_flags = lhs_flags!defer %return %finish %else with == lhs_link with var = 0 %if CONST(with) %finish %if with var!rhs var = 0 %start { (a op const) op const } key = (Opflag!Link Flag)&cop12 %if key = cop1 %or (key&cop2 # 0 %and operation = op) %start {can fold it out} constant operation(operation, with, rhs) dispose(rhs) %if with_Offset = Null Value(op) %and Link Flag&No Null = 0 %start {e.g. a+0} lhs_oper = 0; dispose(with) %finish %return %finish %finish load up(lhs) %finish %if lhs var!rhs var = 0 %start; {const op const} constant operation(operation, lhs, rhs) dispose(rhs) %return %finish %if rhs_oper # 0 %start %if rhs_oper = negate %and Opflag&addsub # 0 %start rhs_oper = 0 operation = add+subtract-operation %else load up(rhs) %finish %finish %if rhs var = 0 %start %if rhs_Offset = Null Value(operation) %and Opflag&No Null = 0 %start dispose(rhs) lhs_flags = lhs_flags&(\defer) %return %finish %finish lhs_oper = operation lhs_link == rhs lhs_flags = lhs_flags!defer %end %routine Define Label(%integer Label) {Define Label} {===================================} D Code(Dir Label) Put(Label) Put Long(Ca) Select Out(Obj) %end %routine Define Reference(%integer Type, Label, CC) {Define Reference} {=================================================} D Code(Type) {Paddr,Jump or Call} Put(Label) Put Long(Ca) Printsymbol(CC) %if CC >= 0 O Code(Type) Put(Label) Printsymbol(CC) %if CC >= 0 %end %routine Process Label(%integer Index, CC, Mode) {Process Label} {==============================================} %constintegerarray Not(0:6) = 0, 4, 5, 6, 1, 2, 3 %recordformat Labelfm(%short Index, Label, Link, At) %ownrecord(Labelfm)%array Label(1:Max Label) %ownshort Label Asl = -1, Label List = 0 %record(labelfm)%name L %shortname P %integer N %if Label Asl < 0 %start Label(n)_Link = N+1 %for N = 1, 1, Max Label-1 Label(Max Label)_Link = 0 Label Asl = 1 %finish %if Index < 0 %start {final check} %return %if Label List = 0 L == Label(Label List) Fail("Missing label ".Itos(L_Index)." from line ".Itos(L_At)) %finish {Search for the label index} P == Label List %cycle %if P = 0 %start {not found} Fail("Label not defined") %if Mode < 0 Fail("Too many labels") %if Label Asl = 0 N = Label Asl L == Label(N); Label Asl = L_Link L_Index = Index L_Link = Label List; Label List = N Free Label = Free Label+1 L_Label = Free Label %exit %finish L == Label(P) %if L_Index = Index %start {Found} Fail("Label redefinition") %if Mode > 0 N = P P = L_Link; L_Link = Label Asl; Label Asl = N %exit %finish P == L_Link %repeat %if Mode&1 = 0 %start {?Def} Define Label(L_Label) %else {?Ref} %if Inverted=14 %then CC = Not(CC) Define Reference(ObjDir Jump, L_Label, CC) Plant Skip(cc, 0) {dummy} %finish L_At = Current Line {in case of errors} %end %routinespec Compare(%integer Cond, Stackit) !Scode input procedures %routine Set Tag(%integer Use) {Set Tag} {============================} !input the next tag and set TAGV and TAGN %string(31) Id %if use = 0 %start {input the tag} readsymbol(token) tagn = pending<<8+token readsymbol(pending) %if Tagn = 0 %start readsymbol(Token) Tagn = Pending<<8+Token readsymbol(Pending) Id = String31 %finish %finish %else tagn = use Fail("Too many tags") %if tagn > tag limit %while tagn > top tag %cycle top tag = top tag+1 VAR(top tag) = 0 %repeat tagv == VAR(tagn) %if monitor input # 0 %start select output(Report) print tag(tagn) select output(current stream) %finish %end %routine New Tag(%integer Type) {New Tag} {=============================} !Input the next tag, check it is not currently defined !and set its tagtype to TYPE set tag(0); defv == tagv Fail("Undefined tag") %if tagv_flags&defined bit # 0 tagv_flags = tagv_flags!defined bit tagv_tag type = type %end %routine Spec Tag(%integer Wanted) {Spec Tag} {================================} !Input the next tag and check that, if it already exists, !it is of the wanted type. set tag(0); defv == tagv %if tagv_flags&defined bit = 0 %start {it's a new tag} tagv_flags = tagv_flags!defined bit tagv_tagtype = wanted spec = 0 %else %if tagv_flags&spec bit # 0 {defined by a spec} tagv_flags = tagv_flags-spec bit Fail("Definition does not match spec") %if wanted # 0 %and tagv_tagtype # wanted spec = 1 %finish %else Fail("Redefinition of tag") %end %routine Tag(%integer Wanted) {Tag} {===========================} !Input the next tag and check that it's defined. set tag(0) Fail("Undefined tag") %if tagv_flags&defined bit = 0 Fail("Wrong type of tag") %if Wanted # 0 %and Wanted # Tagv_Tagtype %end %routine Type {Type} {===========} %integer Lower, Upper set tag(0) Fail("Not a type") %if tagv_flags&type bit = 0 Typev == Tagv Typen = Tagv_Type {NOT Tagn - beware of INSERT} Type Size = Typev_Size Type Item Size = Typev_Item Size %if Typen = Int %and Pending = SC Range %start Get Token {skip rage} Lower = Number Upper = Number %finish %end %routine Simple Type {Simple Type} {==================} Type Fail("Not a simple type") %if Typen > Size %end !Constant input %integer %function I String {Istring} {=========================} %integer n, length length = pending-1 readsymbol(token) n = 0 %if token = '-' %start {handle negative constants separately} { to prevent funnies with minus infinity} Fail("Faulty integer syntax") %if length < 1 %cycle readsymbol(token); Fail("Not a digit") %unless '0' <= token <= '9' n = n*10 - (token-'0') length = length-1 %repeat %until length = 0 %else {positive constants} readsymbol(token) %and length = length-1 %if token = '+' {just noise} Fail("Faulty integer syntax") %if length < 0 %cycle Fail("Faulty integer syntax") %unless '0' <= token <= '9' n = n*10 + (token-'0') %exit %if length = 0 readsymbol(token); length = length-1 %repeat %finish readsymbol(pending) {to keep one ahead} %if monitor input # 0 %start select output(Report) printstring(" I:"); write(n, 0); previous nl = 0 select output(current stream) %finish %result = n %end %longreal %function R String {{R String} {==========================} %longreal n, sign, power %integer length, exp, esign length = pending-1 readsymbol(token) %while token = ' ' %cycle {??????????????????????} readsymbol(Token); length = length-1 %repeat %if token = '-' %start sign = -1 readsymbol(token); length = length-1 %else sign = 1 readsymbol(token) %and length = length-1 %if token = '+' {just noise} %finish Fail("Faulty real syntax") %if length < 0 n = 0 %cycle -> Dot %if Token='.' -> Ampersand %if Token='&' { no fraction, just exponent } Fail("Not a digit") %unless '0' <= token <= '9' n = n*10+ (token-'0') ->done %if length = 0 %cycle {??????????????????????} readsymbol(token) length = length-1 %repeat %until Token # ' ' %repeat %until token = '.' Dot: power = 0.1 %cycle ->done %if length = 0 {trailing dot is permitted} readsymbol(token); length = length-1 %exit %if token = '&' Fail("Not a digit") %unless '0' <= token <= '9' n = n+(token-'0')*power power = power*0.1 %repeat Ampersand: exp = 0 readsymbol(token); length = length-1 %if token = '-' %start esign = -1 readsymbol(token); length = length-1 %else esign = 1 readsymbol(token) %and length = length-1 %if token = '+' {more noise} %finish !Note that calculating the exponent assumes that minus infinity is illegal! Fail("Faulty real syntax") %if length < 0 %cycle Fail("Not a digit") %unless '0' <= token <= '9' exp = exp*10 + (token-'0') %exit %if length = 0 readsymbol(token) length = length-1 %repeat n = n * 10.0^(exp*esign) DONE: n = n*sign readsymbol(pending) %if monitor output # 0 %start select output(Report) print fl(n, 7); previous nl = 0 select output(current stream) %finish %result = n %end !Main Scode processing %routinespec Assign(%record(Stack Fm)%name Lhs, Rhs) %routine Eval {Eval} {===========} {perform any delayed operations indicated by DEFER} %record(stackfm)%name V, P P == E_stack %while P ## null %cycle V == P; P == P_stp %continue %if V_flags&defer = 0 !must be computed Loadup(V) %repeat %end %routinespec Fetch %routine Compile If(%integer Statement) {Compile If} {=====================================} %constintegerarray Not(1:6) = 4, 5, 6, 1, 2, 3 %record(Stack Env Fm) If Stack, Else Stack %owninteger Ifs Set = 100 %integer Else set, R, Loaded %record(Stack Fm)%name Ntos, Otos, R1, R2, Temp %record(Stack Fm) V %integer Cc, If Index, Else Index %integer Initial Depth , Final Depth %record(Stack Env Fm)%name Old Stack Old Stack == E R = -1 Loaded = 0 Else set = 0 Cc = Relation Ifs Set = Ifs Set + 2 If Index = Ifs Set Else Index = Ifs Set + 1 Otos == Tos_Stp_Stp %while Otos##Null %cycle %if Otos_Mode=Val %and Size>=Otos_Type>0 %thenstart Loadup(Otos) %finish Otos == Otos_Stp %repeat Noload = 1 Compare(Cc,0) Noload = 0 %if Tos##Null %thenstart Cc = Not(Cc) %unless Tos_Flags&NoNot#0 %finishelse Cc = Not(Cc) Process Label(If Index,Cc,Fref) { Skip if condition false } Dump OpStack %and Monitor(Tos,"If stk") %if control&1#0 Copy Stack(E, If Stack) { save if stack } Initial Depth = Stack Depth (E) Get Token %while Token # SC Else %and Token # SC Endif %cycle %if Statement = 0 %then Compile Instruction %else Program Element Get Token %repeat Final Depth = Stack Depth (E) %if Token=Sc Else %thenstart %if Final Depth#Initial Depth %thenstart {else branch} Loaded = 1 Deal with Sint(Tos) %if Tos_Type<=Size %then Tos_Size = Size of Type(Tos_Type) %c %else Tos_Size = Var(Tos_Type)_Size V_Data = Minus Sp_Data V_Type = Tos_Type V_Size = Tos_Size %if V_Size<4 %then Tos_Flags = Tos_Flags!BoolFl V_Mode = Ref Assign(V, Tos) Release(Tos_Base) Tos_Base = Sp; Tos_Offset = 0 Tos_Acru = AutoI Tos_Flags = 0 Ntos == Tos_Stp %finishelse Ntos == Tos %while Ntos##Null %cycle %if Ntos_Mode=Val %and Size>=Ntos_Type>0 %thenstart Loadup(Ntos) %finish Ntos == Ntos_Stp %repeat Else set = 1 Dump Opstack %and Monitor(Tos,"Else stk") %if control&1#0 Final Depth = Stack Depth (E) Copy Stack(E,Else Stack) { Save else stack } Old Stack == E E == If Stack Depth = Initial Depth { depth as well } Tos == E_Stack { If-stack } %if Tos ## Null %thenstart { } Set Sos %unless E_Stack_Stp==Null{ } %finish { } Process Label(Else Index,0,Fref) { Jump around else statements } Process Label(If Index,0,Fdef) { Label for start of else statements } Get Token %while Token # SC Endif %and Token # SC Endifc %cycle %if Statement = 0 %then Compile Instruction %else Program Element Get Token %repeat %if Token = SC Endifc %start Simple Type %finish %if Final Depth # Initial Depth %thenstart Deal with Sint(Tos) %if Tos_Type<=Size %then Tos_Size = Size of Type(Tos_Type) %c %else Tos_Size = Var(Tos_Type)_Size V_Data = Minus Sp_Data V_Size = Tos_Size %if V_Size<4 %then Tos_Flags = Tos_Flags!BoolFl V_Type = Tos_Type V_Mode = Ref Assign(V, Tos) Release(Tos_Base) Tos_Base = Sp; Tos_Offset = 0 Tos_Acru = AutoI Tos_Flags = 0 Ntos == Tos_Stp Otos == Else Stack_Stack_Stp %finishelsestart Ntos == Tos Otos == Else Stack_Stack %finish %finishelsestart Ntos == Tos Otos == If Stack_Stack %finish %while Otos##Null %cycle %if Otos_Mode=Val %and (Ntos_Base#Otos_Base %c %or Ntos_Mode=Ref) %thenstart %if E_Activity(Otos_Base&R Mask)#0 %thenstart { must free register before loading } R1 == Register(Otos_Base) %if Otos_Base&D Reg=0 %thenstart R2 == Register(Any I) Plant2(Movl,R1,R2) { value transfered to R2_Base } %finishelsestart R2 == Register(Any D) Plant2(Movq,R1,R2) %finish Temp == Tos %while Temp##Null %cycle %if Temp_Base=Otos_Base %thenstart Temp_Base = R2_Base Claim(R2_Base) Release(Otos_Base) %finish Temp == Temp_Stp %repeat Dispose(R1) Dispose(R2) %finish Load(Ntos,Otos_Base) { into same location } %finish Ntos == Ntos_Stp Otos == Otos_Stp %repeat E == Old Stack Tos == E_Stack Sos == Tos_Stp %if Else Set=0 %then Process Label(If Index,0,Fdef) %c %else Process Label(Else Index,0,Fdef) { Generate appropriate label } Dump Op Stack %and Monitor( Tos,"Mrg stk") %if Control&1#0 %end {Compile If} %routine Compile Segment {Compile Segment} {==========================================} %record(Stack Env Fm)%name Old Stack %record(Stack Env Fm) Seg Stack %integer Area, Old Area, New Ca %integername Old Ca Old Area = Current Area; Old Ca == Ca Free Area = Free Area - 1 Area = Free Area New Area(Area, New Ca) Old Stack == E E == Seg Stack Clear Stack(E) Put Longword(0);Put Longword(0) %cycle Get Token %exit %if Token = SC Eseg Program Element %repeat E == Old Stack Tos == E_Stack End Area Select Area(Old Area, 0, Old Ca) %end !****************************************************************************** !* Stack Instructions and Assignment ( Chapter 5 ) !****************************************************************************** %routine Push {Push} {===========} %integer M Tag(0) Fail("Wrong tag type for PUSH") %if Tagv_Tagtype > Exit Type Stacked Descriptor Tos_Mode = Ref Tos_Acru = VinS Tos_Type = Tagv_Type Tos_Base = Base Map(Tagv_Tagtype) %if Tagv_Module # 0 %and Tos_Base < 0 %start {it's external} M = Tagv_Module<<2 %if Tos_Base = Export Area %start M = M!1 %else %if Tos_Base # Constant Area Fail("Bad external") %finish Tos_Base = -M %finish Tos_Offset = Tagv_Displacement Tos_Size = Tagv_Size Tos_A == Literal(0) Monitor(Tos, "Push") %if Control&1 # 0 %end %routine Dup {Dup} {==========} %if Tos_Base=Sp %and Tos_Acru=AutoI %then Loadup(Tos) Stacked Descriptor Tos_Data = Tos_Stp_Data ! Dump Opstack %and Monitor(Tos, "Dup") %if control&1 # 0 Claim(Tos_Base); Claim(Tos_Index) Set Sos %if Sos_A##Null %start Tos_A == Descriptor Tos_A_Data = Sos_A_Data Claim(Tos_A_Base) %finish %end %routine Swop Top {Swop Top} {===============} Sos == E_Stack; Fail("Empty stack") %if Sos == Null Tos == Sos_Stp; Fail("Stack Underflow") %if Tos == Null Sos_Stp == Tos_Stp Tos_Stp == Sos E_Stack == Tos %end %routine Pop {Pop} {==========} %record(Stackfm)%name S,R S == E_Stack Fail("Popping empty stack") %if S == Null %if S_A ## Null %start r == E_Using %cycle %if R == S_A %thenstart Dispose(S_A) %exit %finish R == R_Using %repeat %until R == Null S_A == Null %finish S_Oper = 0 Dispose(S) E_stack == S_stp Tos == E_Stack Depth = Depth - 1 %end %routine Popall {Popall} {=============} %record(stackfm)%name S %integer N Next Token N = 0 Eval S == E_Stack %while S ## Null %cycle Pop S == E_Stack N = N + 1 %repeat Fail("Stack wrong size in Popall") %if N # Token E_Active Registers = 0 E_Activity(N) = 0 %for N=R0,1,R10 %end %routine Dump Using {=================} %record(stackfm)%name r r == E_Using %if r==Null %then printstring(" Using list empty ") %while r##Null %cycle monitor(r,"Using:") r == r_Using %repeat %end { of Dump Using } %routine Empty {Empty} {============} %integer N %record(stackfm)%name P Fail("Non-empty stack") %unless E_stack == Null Fail("Descriptors in use") %unless E_using == Null Fail("Registers in use") %unless E_active registers = 0 %end %routine Assign(%record(stackfm)%name Lhs, Rhs) {Assign} {=============================================} %switch Op(0:Maxoper) %record(stackfm)%name W,T,Old Reg,New Reg %integer Oper, Type, RType, Unalnd %if Rhs_Acru = AinR %start Lhs_Type = Oaddr Rhs_Type = Oaddr %finish Type = Lhs_Type Fail("Not Ref in assign") %if Lhs_mode # Ref Oper = Rhs_Oper; Rhs_Oper = 0 W == Rhs_Link; Rhs_Link == Null Address(Lhs) Address(Rhs) Address(W) %unless W == Null %unless Type = Rhs_Type %start {Check type compatibility and convert if necessary} %if Type = Sint %and Rhs_Type = Int %start %if Oper = 0 %start %if Rhs_Acru # Constant %start Plant2(Cvtlw, Rhs, Lhs) %return %finish %else Claim(R0) Plant2(Cvtlw, Rhs, Rv0) Clear(Rhs) Rhs_Data = Rv0_Data %finish %else %if Type = Int %and Rhs_Type = Sint %if Oper = 0 %start %if Rhs_Acru # Constant %start Plant2(Cvtwl, Rhs, Lhs) %return %finish %else Claim(R0) Plant2(Cvtwl, Rhs, Rv0) Clear(Rhs) Rhs_Data = Rv0_Data %finish %finish %else Fail("Types differ in assign") %finish {end of type checking} %if Type>Size %start {record assignment, use MOVC3} Fail("Record operation") %if Oper # 0 %return %if Rhs_Base=Lhs_Base=Sp { pushing an item already on stack } {Assume records <= 64Kb} %if Lhs_Size = 8 %then Type = Gaddr %elsestart Unalnd = Lhs_Size W == Literal((Unalnd+3)&(\3)) %if Lhs_Acru = AutoD %thenstart Fail("Unpleasant autodecrement") %if Lhs_Base # Sp Lhs == At Sp Plant2(Subl2, W, Spv) %finish T == E_Using %while T ## Null %cycle %if R0<=T_Base<=R5 %start {Move to avoid overwriting by Movc3} %if Bool<=T_Type<=Size %then RType = Type Plus Reg(T_Type) %c %else RType = Any Plus New Reg == Register(RType) Old Reg == Register(T_Base) Plant2(Movl,Old Reg,New Reg) Dispose(Old Reg) Release(T_Base) T_Base = New Reg_Base Claim(T_Base) Dispose(New Reg) %finish T == T_Using %repeat W_Offset = Unalnd { remove alignment } %if Rhs_Acru=AutoI %thenstart Fail("Unpleasant autoincrement") %if Rhs_Base#Sp Rhs_Data = At Sp_Data Plant3(Movc3, W, Rhs, Lhs) W_Offset = (W_Offset+3)&(\3) Plant2(Addl2,W,SpV) %finishelse Plant3(Movc3, W, Rhs, Lhs) Dispose(W) %return %finish %finish {end of record assignment} ->Op(Oper) Op(0): Plant2(Moveop(Type), Rhs, Lhs); ->Done Op(Negate): Plant2(Negop(Type), Rhs, Lhs); ->Done Op(Complement):Plant2(Mcomb, Rhs, Lhs); ->Done Op(Add): Plant3(Addop(Type), W, Rhs, Lhs); ->Done Op(Subtract): Plant3(Subop(Type), W, Rhs, Lhs); ->Done Op(Multiply): Plant3(Mulop(Type), W, Rhs, Lhs); ->Done Op(Divide): Plant3(Divop(Type), W, Rhs, Lhs); ->Done Op(Remainder): Plant3(X Rem, W, Rhs, Lhs); ->Done Op(Or): Plant3(Bisb3, W, Rhs, Lhs); ->Done Op(And): Plant3(X And, W, Rhs, Lhs); ->Done Op(Xor): Plant3(Xorb3, W, Rhs, Lhs); ->Done Done: Dispose(W) %unless W == Null %end !***************************************************************************** !* Addressing Instructions ( Chapter 6 ) !****************************************************************************** %routine Fetch {Fetch} {============} %if Tos_Mode = Ref %start Tos_Mode = Val Tos_Flags = Tos_Flags!Defer %finish %end %routine Refer {Refer} {============} Type Fail("Not Gaddr for Refer") %if Tos_Type # Gaddr Load(Tos,Any) Tos_Base = Tos_Base&R Mask2 E_Activity(Tos_Base&R Mask) = E_Activity(Tos_Base&R Mask)&R Mask2 E_Activity(Tos_Base&R Mask+1) = E_Activity(Tos_Base&R Mask+1)&R Mask2 Tos_A == Register(Tos_Base&R Mask+1) E_Active Registers = E_Active Registers + 1 Release(Tos_A_Base) Tos_Type = Typen Tos_Acru = VinS Tos_Mode = Ref Tos_Size = Typev_Size %end %routine Deref {Deref} {============} %record(stackfm)%name A, Rob, Rat Fail("Not Ref for Deref") %if Tos_Mode # Ref Rob == Register Pair Rob_Base = Rob_Base&R Mask2 Rat == Register(Rob_Base&R Mask+1); Release(Rat_Base) A == Tos_A; Tos_A == Null Address(Tos) Address(A) Plant2(Movab, Tos, Rob) Rob_Base = Rob_Base!D Reg Plant2(Movl, A, Rat) Dispose(A); Clear(Tos) Tos_Data = Rob_Data; Drop(Rob) Tos_A == Literal(0) Drop(Rat) Tos_Mode = Val Tos_Acru = VinR Tos_Type = Gaddr %end %routine Select {Select} {=============} %record(stackfm)%name R,L %integer Disp Tag(Attribute Type) Fail("Not Ref in select") %if Tos_Mode # Ref %if Tos_Base = FP %thenstart Disp = ((Tos_Size+3)&(\3)) - Tagv_Displacement - Tagv_Size L == Literal(Disp) %finishelse L == Literal(Tagv_Displacement) Tos_Type = Tagv_Type Tos_Size = Tagv_Size %if Tos_A==Null %then Tos_A == L %else Operate(Add,Tos_A,L) Monitor(Tos, "Select") %if Control&1 # 0 %end %routine Remote {Remote} {=============} %record(Stack Fm)%name L Tag(Attribute Type) Load(Tos, Any I) Tos_Acru = VinS Tos_Mode = Ref Tos_Type = Tagv_Type Tos_Size = Tagv_Size L == Literal(Tagv_Displacement) %if Tos_A==Null %then Tos_A == L %else Operate(Add,Tos_A,L) Monitor(Tos, "Remote") %if Control&1 # 0 %end %routine Index {Index} {============} %record(stackfm)%name Otos == Tos Promote Sos Deal with Sint(Otos) Fail("Not Int for index") %if Otos_Type # Int Fail("Not Ref for Index") %if Tos_Mode # Ref %if Var(Tos_Type)_Size>0 %then Tos_Size =Var(Tos_Type)_Size %c %else Tos_Size = Var(Tos_Type)_Item Size Monitor(Tos,"Index Sos") %and Monitor(Otos,"Index Tos") %if Control&1#0 Operate(Multiply, Otos, Literal(Tos_Size)) {Scale the index} %if Tos_A == Null %start Tos_A == Otos %else Operate(Add, Tos_A, Otos) %finish %end %routine Inco {Inco} {===========} %record(stackfm)%name Otos == Tos Promote Sos Fail("Not Size in Inco") %if Otos_Type # Size Fail("Not Oaddr in Inco") %if Tos_Type # Oaddr Operate(Add, Tos, Otos) %end %routine Deco {Deco} {===========} %record(stackfm)%name Otos == Tos Promote Sos Fail("Not Size in Deco") %if Otos_Type # Size Fail("Not Oaddr in Deco") %if Tos_Type # Oaddr Operate(Subtract, Tos, Otos) %end %routine Dist {Dist} {===========} %record(stackfm)%name Otos == Tos Promote Sos Fail("Not Oaddr in Dist") %if Tos_Type # Oaddr %or Otos_Type # Oaddr Operate(Subtract, Tos, Otos) Load(Tos, Any I) Tos_Type = Size %end %routine Dsize {Dsize} {============} Type Fail("Not a structured type") %if Typev_Tagtype # Record Type Fail("No indefinite repetition") %if Typev_Flags&Indefinite = 0 Fail("Not Int for Dsize") %if Tos_Type # Int Operate(Multiply, Tos, Literal(Typev_Item Size)) Operate(Add, Tos, Literal(Typev_Base Size)) Load(Tos, Any I) Tos_Type = Size %end %routine Locate {Locate} {=============} %record(Stackfm)%name Otos, Reg1, Reg2 Otos == Tos Promote Sos Fail("Not Aaddr for Locate") %if Otos_Type # Aaddr %if Tos_Type=Oaddr %thenstart Reg1 == Register Pair Reg2 == Register((Reg1_Base&R Mask)+1); Release(Reg2_Base) Address(Tos) Plant2(Movl,Tos,Reg1) Clear(Tos) Tos_Data = Reg1_Data Drop(Reg1) Address(Otos) Plant2(Movl, Otos, Reg2) Drop(Reg2) Tos_Type = Gaddr Dispose(Otos) %finishelsestart %if Tos_Type=Gaddr %thenstart Address(Otos) Loadup(Tos) Reg2 == Register((Tos_Base&R Mask)+1); Release(Reg2_Base) Plant2(Addl2,Otos,Reg2) Drop(Reg2) Dispose(Otos) %finishelse Fail("Not O- or G-Addr in locate") %finish %end !****************************************************************************** ! Save/Restore ( Chapter 7 ) !****************************************************************************** { A save object looks like:- } { ------ --------- ---- ---- ---- ---- ---- ---- { | Size | Current | M1 | M2 | ---- | Mn | V1 | V2 | --- | Vn | { ------ --------- ---- ---- ---- ---- ---- ---- { L B B B B L L L { The length of the save object = 4 + 1 + n + 4*n } %integer Extra Temp %routine Pushlen {=================} %record(Stack Fm)%name t Pushset = 1 Dump Op Stack %if control&1#0 %if Tos##Null %thenstart %if Tos_Type=Bool %and Tos_Acru=AutoI %then Loadup(Tos) %if Tos_Stp##Null %thenstart Sos == Tos_Stp %if Sos_Type=Bool %and Sos_Acru=AutoI %then Loadup(Sos) %finish %finish Extra Temp = 0 T == Parms %while T##Null %cycle %if T_Flags&Marked Bit#0 %then %exit Extra Temp = Extra Temp + T_Size T == T_Stp %repeat monitor(Parms,itos(extra temp)) %if control&1#0 Put Word(x'8FBB') { Pushregs } Put Word(x'07FE') { Mask, R1 to R10 } Extra Temp = Extra Temp + 40 Integer Literal = Extra Temp + (Extra Temp//4) + 5 Stack Integer(Size) %end { of Pushlen } %routine Restore(%integer Length) {Restore} {===============================} %record(Stack Fm) Val %record(Stack Fm)%name L, Check Fail("Not Oaddr in restore") %unless Tos_Type=Oaddr Load(Tos,R6) Val = 0 Val_Base = Tos_Base Val_Acru = VinS Val_Offset = 5 + (Length//4) L == Literal(Length) Plant2(Subl2,L,SpV) Plant3(Movc3,L,Val,At Sp) Put Byte(x'BA'); Put Byte(x'8F') Put Word(x'07FE') Check == E_Stack %while Check_Flags&Marked Bit=0 %cycle Fail("Mismatched restore") %if Check==Null Check == Check_Stp %repeat Check_Flags = Check_Flags&(\Marked Bit) %if Length>67 %thenstart Check == Parms %while Check_Flags&Marked Bit=0 %cycle Fail("Mismatched Parms") %if Check==Null Check == Check_Stp %repeat Check_Flags = Check_Flags&(\Marked Bit) %finish Dispose(L) Pop %end { of Restore } %routine Save(%integer Statement) {Save} {===============================} %bytearray Marked(R1:R10) ,Marked2(15:60) %integer i,Offset,Last %record(Stack Fm) Size,Current,Marks,Vals %record(Stack Fm)%name Check,Len,N Marks %record(Tag Fm)%name Check2 Fail("Not Oaddr in Save") %unless Tos_Type=Oaddr %for i=15,1,60 %cycle Marked2(i)=0 %repeat %for i=R1,1,R10 %cycle Marked(i) = 0 %repeat Pushset = 0 Load(Tos,R6) { R6 contains @ of the save object } Size = 0 Size_Base = Tos_Base Size_Acru = VinS { Size describes the first longword of the Save object } Len == Literal(Extra Temp) N Marks == Literal(Extra Temp//4) Vals = Size Vals_Offset = 5 + (Extra Temp//4) Current = Size; Current_Offset = 4 Marks = Size Marks_Offset = 5 Plant2(Movl,N Marks,Size) { Set Size to n for Tseto & Tgeto } Plant1(Clrb,Current) { Clear Current } Plant3(Movc3,Len,At Sp,Vals) { Move in the temporary area } Plant2(Addl2,Len,Spv) { Delete the temporary area } Plant5(Movc5,Zero,Marks,Zero,N Marks,Marks) { Zero the Mark bytes: may not be needed if RTS is changed } Pop ! Begin Marking for Stack Check == E_Stack i = 0 %while Check ## Null %cycle %if Check_Flags&Marked Bit#0 %then %exit Fail("Complex type in save?") %if Check_Type>31 %and Check_Mode=Val %if (Oaddr<=Check_Type<=Gaddr %or Check_Mode=Ref) %and Check_Acru#Constant %c %and R11>Check_Base>R0 %and Marked(Check_Base)=0 %thenstart i = i + 1 Marks_Offset = Check_Base+3 N Marks_Offset = i Plant2(Movb,N Marks,Marks) Marked(Check_Base) = 1 %finish Check == Check_Stp %repeat E_Stack_Flags = E_Stack_Flags!Marked Bit ! Begin Marking for Parms Offset = 0 Check == Parms %while Check##Null %cycle %if Check_Flags&Marked Bit#0 %then %exit %if Oaddr<=Check_Type<=Gaddr %thenstart i = i+1 N Marks_Offset = i Marks_Offset = Offset+15 Plant2(Movb,N Marks,Marks) %finishelsestart %if Check_Type>31 %thenstart { Complex type } Last = Check_Type+1 Check2 == Var(Last) %while Check2_Tag Type=Attribute Type %cycle Marks_Offset = Offset + 15 + (Check2_Displacement//4) %if Oaddr<=Check2_Type<=Gaddr %and Marked2(Marks_Offset)=0 %thenstart i=i+1 Marked2(Marks_Offset) = 1 N Marks_Offset = i Plant2(Movb,N Marks,Marks) %finish Last = Last + 1 Check2 == Var(Last) %repeat %finish %finish Offset = Offset + (Check_Size//4) Check == Check_Stp %repeat %if Parms##Null %then Parms_Flags = Parms_Flags!Marked Bit Dispose(Len) Dispose(N Marks) Offset = Extra Temp %cycle Get Token %if Token=Sc Restore %then Restore(Offset) %and %exit %if Statement = 0 %then Compile Instruction %else Program Element %repeat %end { of Save } %routine Tinito {Tinito} {=============} Fail("Not oaddr in T-inito") %if Tos_Type # Oaddr Load(Tos, Any I); Tos_Acru = VinS Tos_Offset = 4 Plant1(Clrb, Tos) Pop %end %routine Tgeto {Tgeto} {============} %record(stackfm) Size, Current, Marks %record(Stack Fm)%name Val Fail("Not Oaddr in T-geto") %if Tos_Type # Oaddr Load(Tos, Any I) Size = 0; Size_Base = Tos_Base; Size_Acru = VinS Current = Size; Current_Offset = 4 Marks = Size; Marks_Offset = 5 Val == Register(Any I) Plant2(Movab,Marks,Val) Plant2(Addl2,Size,Val) Val_Acru = VinS Plant1(Incb, Current) Plant3(Locc, Current, Size, Marks) Plant Skip(3 {Eq}, 8) Tos_Data = Rv0_Data Tos_Type = Oaddr Plant3(Subl3, Tos, Size, Tos) Val_Index = R0 Claim(R0) Plant2(Movl, Val, Tos) Dispose(Val) Claim(R0) Release(Size_Base) %end %routine Tseto {Tseto} {============} %record(stackfm)%name Otos, Val %record(Stackfm) Size, Current, Marks Otos == Tos Promote Sos Fail("Not Oaddr in T-seto") %if Tos_Type # Oaddr %or Otos_Type # Oaddr Load(Tos, Any I) Address(Otos) Size = 0; Size_Base = Tos_Base; Size_Acru = VinS Current = Size; Current_Offset = 4 Marks = Size; Marks_Offset = 5 Val == Register(Any I) Plant2(Movab,Marks,Val) Plant2(Addl2,Size,Val) Val_Acru = VinS Plant3(Locc, Current, Size, Marks) Tos_Data = Rv0_Data Plant3(Subl3, Tos, Size, Tos) Val_Index = R0 Claim(R0) Plant2(Movl, Otos, Val) Dispose(Otos) Dispose(Val) Release(Size_Base) Claim(R0) Pop %end !****************************************************************************** ! Dynamic quantity handling ( Chapter 8 ) !****************************************************************************** %routine Setobj {Setobj} {=============} %record(stackfm)%name Otos == Tos %integer X Promote Sos Fail("Not Int in Setobj") %if Otos_Type # Int Fail("Not Oaddr in Setobj") %if Tos_Type # Oaddr Load(Otos, Any I) X = Otos_Base Otos_Data = Display_Data Otos_Index = X Assign(Otos, Tos) Dispose(Otos) Pop %end %routine Getobj {Getobj} {=============} Fail("Not Int in Getobj") %if Tos_Type # Int Load(Tos, Any I) Display_Index = Tos_Base Tos_Data = Display_Data Load(Tos, Any I) Tos_Type = Oaddr %end %routine Access {Access} {=============} %integer oindex Next Token; Oindex = Token Stacked Descriptor Tos_Data = Display_Data Tos_Index = 0 Tos_Offset = (Oindex-16)*4 Load(Tos,Any I) Tos_Type = Oaddr Tos_Mode = Ref Select Tos_Acru = Vins %end { of Access } %integerfn Relation {Relation} {=================} Get Token Fail("Not a relation") %unless SC lt <= Token <= SC ne %result = Token-SC lt+1 %end %routine Compare(%integer Cond, Stackit) {Compare} {======================================} %integer T %record(stackfm)%name Len, BLit %constbytearray Bits(0:Size) = b'1001000' {record}, b'1001000' {bool}, b'1111110' {char}, b'1111110' {int}, b'1111110' {sint}, b'1111110' {real}, b'1111110' {lreal}, b'1001000' {aaddr}, b'1111110' {oaddr}, b'1001000' {gaddr}, b'1001000' {paddr}, b'1001000' {raddr}, b'1111110' {size} %record(stackfm)%name Otos == Tos Eval %if Noload=0 Inverted = 0 Promote Sos %if Tos_Mode=Ref %and Tos_Type>Size %thenstart Tos_Type = Var(Tos_Type)_Type %finish %if Otos_Base = Sp %and Otos_Acru = AutoI %then Loadup (Otos) %if Tos_Base = Sp %and Tos_Acru = AutoI %then Loadup (Tos) T = Tos_Type %if T # Otos_Type %start Deal with Sint(Tos) Deal with Sint(Otos) T = Tos_Type Fail("Types differ in Compare") %unless T = Otos_Type %finish Fail("Unresolved type in Compare?") %if T = 0 %or Var(T)_Flags&Indefinite # 0 T = 0 %if T > Size Fail("Illegal relation for compare") %if Bits(T)&(1< Size %return %if C_Type = ToType Op = Convert Op((C_Type-1)*12+ToType) Fail("Incompatible types for Convert") %if Op = 0 %if Op = 255 %thenstart {Gaddr -> Aaddr} A == C_A; C_A == Null Clear(C) C_Data = A_Data A_Oper = 0; Drop(A) %finishelsestart %if Op = 254 %thenstart {Gaddr -> Oaddr} A == C_A; C_A == Null Return(A) %finishelsestart %if Op=Cvtlb %thenstart { must avoid overflow } Loadup(C) R == Register(Any I) Plant2(Movzbl,C,R) Clear(C) C_Data = R_Data Drop(R) %finishelsestart %if Op # Nop %thenstart R == Register(Type Reg(ToType)) Address(C) Plant2(Op, C, R) Clear(C) C_Data = R_Data Drop(R) %finish %finish %finish %finish C_Type = ToType %end %routine Deal with Sint(%record(stackfm)%name V) {Deal with Sint} {==============================================} Convert(V , Int) %if V_Type = Sint %end %routine Convert Instruction(%integer Which) {Convert Instruction} {==========================================} %record(stackfm)%name C %if Which < 0 %start Set Sos C == Sos %else C == Tos %finish Simple Type Convert(C, Typen) %end %routine Precall(%integer Stacked) {Precall} {================================} {The syntax makes this rather unpleasant} %integer Profile, N, i, Parm Count %record(tagfm)%name PT, Param %record(stackfm)%name ParamN, T, Prof %routine Check Import and Set Export {==================================} %record(tagfm)%name V %record(stackfm)%name Reg0,Reg1 Fail("Profile not in TOS") %if Tos_Type # Stacked Profile Type Fail("Not enough import parameters") %if Tos_Import # 0 %if Pt_Export # 0 %start V == Var(Pt_Export) Reg0 == Register(R0) %if Pushset=0 %thenstart { not the call following Pushlen } %if V_Type<=Size %thenstart Reg0_Acru = VinS Reg0_Type = V_Type Reg0_Size = Size of Type(V_Type) Loadup(Reg0) Dispose(Tos_A) %if Tos_A ## Null Clear(Tos) Tos_Data = Reg0_Data Claim(Tos_Base) Dispose(Reg0) %return %finish Reg1 == Register(Any I) Plant2(Movl,Reg0,Reg1) Tos_Base = Reg1_Base Dispose(Reg1) %finishelse Tos_Base = R0 Tos_Mode = Val Tos_Offset = 0 Tos_Acru = VinS %if V_Type>Size %or Tos_Base=R0 Tos_Type = V_Type Dispose(Reg0) Claim(Tos_Base) %else Pop %finish %end %routine Call {Call} {===========} %integer i %record(Stack Fm)%name Temp %for i=1,1,Parm Count %cycle Temp == Parms Parms == Parms_Stp Dispose(Temp) %repeat Parm Count = 0 Tag(Routine Type) ParamN == Literal(N) Plant1(Calls, ParamN) %if Tagv_Flags&Peculiar # 0 %start %unless 0 < Tagv_Displacement <= External No %start Fail("Corrupt external ".Itos(Tagv_Displacement)) %finish Put Byte(x'9F') Printsymbol(Obj Link); Put(Tagv_Displacement) Put Longword(0) %else %if Tagv_Flags&Inserted # 0 Put Byte(x'9F') Printsymbol(Obj Relinst); Put(Tagv_Module<<2) {code ref} Put Longword(Tagv_Displacement) %else Define Reference(ObjDir Call, Tagv_Displacement, -1) Put Word(x'00AF') {dummy} %finish Check Import and Set Export %end { of Call } %routine Call Tos {Call Tos} {===============} %integer i %record(Stack Fm)%name Temp Fail("Not Raddr in Call-tos") %if Tos_Type # Raddr %for i=1,1,Parm Count %cycle Temp == Parms Parms == Parms_Stp Dispose(Temp) %repeat Parm Count = 0 ParamN == Literal(N) Address(Tos) %if Tos_Mode=Ref %thenstart Tos_Mode = Val Tos_Type = Int Load Up(Tos) Tos_Type = Raddr Tos_Acru = VinS %finish Plant1(Calls, ParamN); Operand(Tos, Ab) Pop Check Import and Set Export %end { of Call Tos } %routine Ass Par(%record(stackfm)%name Prof,%byte Repset) {Ass Par} {=======================================================} %record(Tagfm)%name Param %record(Stackfm)%name Dest, Otos Fail("Not Profile in parameter assignment") %unless Prof_Type = Stacked Profile Type %if Prof_Import # 0 %start Param == Var(Prof_Import) %if Repset=0 %thenstart N = N + (Param_Size+3)>>2 Prof_Import = Param_Chain %finish Dest == Descriptor Dest_Type = Param_Type Dest_Size = Param_Size Dest_Mode = Ref Dest_Acru = AutoD Dest_Offset = 0 Dest_Base = Sp Assign(Dest, Tos) Dispose(Dest) Otos == Tos { Add to Parms list, rather than POPping } Promote Sos Otos_Stp == Parms Parms == Otos Parms_Size = Var(Parms_Type)_Size Parms_Flags = Parms_Flags & (\Marked Bit) Parm Count = Parm Count + 1 %finish %else Fail("Too many import parameters") %end { of Ass Par } %routine Ass Rep {Ass Rep} {==============} %byte Repset = 1 %integer i, Fixed, Reps, Type %record(Stackfm)%name Last, Rep Rep == E_Stack Fixed = Token Type = Rep_Type Type = Int %if Type=Sint %for i = 1,1,Fixed %cycle {Check types and find repetition} Deal with Sint(Rep) Fail("Types mismatched in Assrep") %unless Rep_Type = Type Rep == Rep_Stp %repeat Reps = Var(Rep_Import)_Size//Size of Type(Type) - Fixed Last == Descriptor Last_Data = At Sp_Data Last_Offset = -Reps*Size of Type(Type) Plant2(Movab,Last,SpV) Dispose(Last) Rep_A == Literal(0) %if Rep_A == Null %for i = 1,1,Fixed %cycle {now make the assignments} Repset = 0 %if i=Fixed Ass Par(Rep,Repset) %repeat %end { of Ass Rep } Parm Count = 0 %if Stacked<0 %start {Repcall} Next Token N = Token %finish Tag(0) Profile = Tagn Pt == Tagv Fail("Not a profile") %unless Pt_tagtype = Profile Type %if Stacked<0 %start {Repcall} Prof == Descriptor Prof_Type = Stacked Profile Type Prof_Import = Pt_Import T == E_Stack T == T_Stp %for i=1,1,N-1 Prof_Stp == T_Stp T_Stp == Prof Token = N Stacked = 0 Ass Rep %else Stacked Descriptor Tos_Type = Stacked Profile Type Tos_Import = Pt_Import %finish {Deal with Parameters} Swop Top %if Stacked > 0 N = 0 %cycle %if Stacked = 0 %start Get Token %if Token = SC Call %start Call %exit %finish %cycle Compile Instruction Get Token %repeat %until Token = SC Asspar %or Token = SC Assrep %or Token = SC Call Tos Call Tos %and %exit %if Token = SC Call Tos %if Token = SC Assrep %start Next Token Ass Rep %continue %finish %finish Stacked = 0 Set Sos Deal with Sint(Sos) Ass Par(Sos,0) %repeat Dispose(ParamN) %end %routine Switch Jump {Switch Jump} {==================} %record(stackfm)%name Limit %integer Size, N Newtag(Switch Type) Size = Number Tagv_Size = Size Fail("Not Int in switch") %if Tos_Type # Int Address(Tos) Limit == Literal(Size) Plant3(Casel, Tos, Zero, Limit) Dispose(Limit) Free Label = Free Label+1 Tagv_Displacement = Free Label D Code(Dir Label) Put(Free Label) Put Long(Ca) Select Out(Obj) Put Word(0) %for N = Size-1, -1, 0 Pop Empty %end %routine Fjump(%integer Condition) {Fjump} {================================} %integer Destination Noload = 1 Next Token; Destination = Token %if Condition # 0 %then Compare(Condition, 0) %else Empty Noload = 0 Process Label(Destination, Condition, Fref) %end %routine Bjump(%integer Condition) {Bjump} {================================} %integer Destination Noload = 1 Next Token; Destination = Token %if Condition # 0 %then Compare(Condition, 0) %else Empty Noload = 0 Process Label(Destination, Condition, Bref) %end %routine Fdest {Fdest} {============} %integer Destination Next Token; Destination = Token Process Label(Destination, 0, Fdef) Empty %end %routine Bdest {Bdest} {============} %integer Destination Next Token; Destination = Token Process Label(Destination, 0, Bdef) Empty %end %routine Sdest {Sdest} {============} %integer Which Tag(Switch Type) Which = Number Fail("Sdest out of range") %if Which > Tagv_Size Printsymbol(Obj Switch) Put(Tagv_Displacement) Put(Which) Empty %end { of Sdest } %routine Resolved Structure {Resolved Structure} {=========================} {Typev, Type Size & Type Item Size already set} %integer Count, Check Size %if Pending = SC fixrep %thenstart Get Token {skip fixrep} Count = Number Fail("Not an indefinite repetition") %if Typev_Flags&Indefinite = 0 Check Size = Type Item Size*Count + Typev_Base Size {%if Check Size>Typev_Size %then} Type Size = Check Size %finishelsestart ! Fail("Unresolved indefinite repetition") %if Typev_Flags&Indefinite # 0 %finish %end { of Resolved Structure } %routine Quantity Descriptor(%record(tagfm)%name V, %integername Displacement) {Quantity Descriptor} {============================================================================} %integer Count Type { Sets Typev,Typen,Type Size,Type Item Size } Resolved Structure %if Typen > Size Count = 1; Rep = 0 %if Pending = SC Rep %thenstart Get Token {Skip rep} Count = Number Rep = Type Size %finish V_type = Typen V_size = Type Size*Count V_Item Size = Rep V_Reps = Count %if Count=0 %then V_Flags = V_Flags!Indefinite ! %if Typen = SINT %then Displacement = (Displacement+1)&(\1) %elsestart {Halfword boundary} ! %if Typen # BOOL %and Typen <= Size %and Typen # Char%then Displacement = (Displacement+3)&(\3) {Word Boundary} ! %finish V_Displacement = Displacement Displacement = Displacement+V_size %end { of Quantity Descriptor } %routine Attribute Definition(%integername Displacement) {Attribute Definition} {======================================================} %record(Tag Fm)%name Att Rep = 0 %cycle Get Token %return %if Token # SC Attr Newtag(Attribute Type) { Sets Tagv, Tagn } Att == Tagv Quantity Descriptor(Att, Displacement) %if Att_Flags&Indefinite#0 %then Rd_Base Size = Att_Displacement %repeat %end { of Attribute Definition } %routine Record Descriptor {Record Descriptor} {========================} %integer Displacement, Max Displacement, Here Newtag(Record Type) RD == Tagv RD_Type = Tagn {Self ref} %if Pending = SC Prefix %thenstart {Prefix part} Get Token {Skip prefix token} Type { Sets Typev,Typen,Type Size,Type Item Size } Resolved Structure {Check it's suitable} Displacement = Type Size {Start after the prefix} %finishelse Displacement = 0 {Start from the beginning} Attribute Definition(Displacement) {Common part} Max Displacement = Displacement Here = Displacement %while Token = SC Alt %cycle {Alternate parts} Displacement = Here Attribute Definition(Displacement) Max Displacement = Displacement %if Displacement > Max Displacement %repeat ! Displacement = (Max Displacement+3)&(\3) {Round it up} RD_size = Displacement RD_Item size = Rep RD_flags = RD_flags!Type Bit RD_Flags = RD_Flags!Indefinite %if Rep # 0 Fail("Endrecord missing") %unless Token = SC Endrecord %end %integerfn External Ref(%string(31) Id) {External Ref} {=====================================} Dcode(Dir Spec) External No = External No+1 External Id(External No) = Id Put(External No) Put String(Id) Select Out(Obj) %result = External No %end %predicate replaced(%string(31) Kid) %constinteger No Replaced = 6 %conststring(31)%array Id Replaced(1:No Replaced) = "OUT2BY","IN2BYT","COSINU","TANGEN","ARCSIN","ARCCOS" %integer i %for i = 1,1,No Replaced %cycle %if Kid = Id Replaced(i) %then %true %repeat %false %end { of Replaced } %routine Compile Profile {Compile Profile} {======================} %record(tagfm)%name Pv %owninteger Intfce Ep Set=0 %integer Body, P, Q %integer Import Displacement = 0 %shortname Link %string(31) Nature, Id Newtag(Profile Type) Pv == Tagv Get Token %if Token = SC Known %start Newtag(Routine Type) Body = Tagn Tagv_Flags = Tagv_Flags!Spec Bit!Known Id = String 31 %if Replaced(Id) %thenstart { Generate external reference to RTE } Tagv_Flags = Tagv_Flags!Peculiar Tagv_Displacement = External Ref("SIM$".Id) %finishelsestart Free Label = Free Label + 1 Tagv_Displacement = Free Label %finish Get Token %finishelsestart %if Token = SC System %thenstart Newtag(Routine Type); Body = Tagn Tagv_Flags = Tagv_Flags!Peculiar Id = String 31 Tagv_Displacement = External Ref("SIM$".Id) Get Token %finishelsestart %if Token = SC External %thenstart Newtag(Routine Type); Body = Tagn Nature = String 31 Id = String 31 Get Token Tagv_Flags = Tagv_Flags!Peculiar Tagv_Displacement = External Ref(id) fail(itos(tagv_displacement)."External labs?") %finishelsestart %if Token=SC Interface %thenstart Id = String31 Get Token %if Intfce Ep Set=0 %thenstart {only the first Intrfce Pro} Tagv_Flags = Tagv_Flags!Interface Bit Intfce Ep Set = 1 %finish %finish %finish %finish %finish {Construct the import list} Link == Pv_Import %while Token = SC Import %cycle Newtag(Import Type) Link = Tagn; Link == Tagv_Chain Quantity Descriptor(Tagv, Import Displacement) Import Displacement = (Import Displacement+3)&(\3) Get Token %repeat Link = 0 {now reverse the displacements: Ugh!} P = Pv_Import Q = Import Displacement %while P # 0 %cycle Tagv == Var(P); P = Tagv_Chain Q = Q-((Tagv_Size+3)&(\3)) { word aligned } Tagv_Displacement = Q %repeat %if Token = SC Export %start Newtag(Export Type) Pv_Export = Tagn Quantity Descriptor(Tagv, Export Displacement) Get Token %else %if Token = SC Exit Newtag(Exit Type) Pv_Exit = Tagn Tagv_Type = Paddr Tagv_Item Size = 4 Tagv_Size = 4 Tagv_Displacement = -16 Get Token %finish Fail("'Endprofile' missing") %unless Token = SC Endprofile %end %routine Info Setting {Info String} {===================} %string(31) Info %integer Switch Index, Setting %if Token = SC Info %start Info = String31 %else %if Token = SC Line Current Line = Number Diags Size = Diags Size + 6 %if Magic Line >= 0 %and Current Line >= Magic Line %start Control = 255 Monitor Input = 1 Monitor Output = 255 %finish %if Stop Line>0 %and Current Line>Stop Line %then Fail("Termination requested") Printsymbol(Obj Line); Put(Current Line) %else %if Token = SC Setswitch Next Token; Switch Index = Token Next Token; Setting = Token %else Fail("Faulty info") %finish %end %routine Compile Const Spec {Compile Const Spec} {=========================} Newtag(Constant Type) Tagv_Flags = Tagv_Flags!Spec Bit Quantity Descriptor(Tagv, Constant Displacement) %end %routine Compile Const {Compile Const} {====================} %integer Disp %record(Tagfm)%name Cv Spectag(Constant Type); Cv == Tagv %if Spec # 0 %thenstart Disp = Cv_Displacement Quantity Descriptor(Cv,Disp) %finishelse Quantity Descriptor(Cv, Constant Displacement) Value(Cv_Reps, Constant Area, Cv_Displacement, Cv_Size//Cv_Reps) %end %routine Compile Skip(%integer Statement) {Compile Skip} {=======================================} %record(Stack Env Fm)%name Old Stack %record(stack env fm) saved stack %integer CC, Skip Index,i %owninteger Skips Set = 1000 Skip Index = Skips Set Skips Set = Skips Set + 1 CC = Relation Noload = 1 Compare(3,0) { Compare equal } Noload = 0 Process Label(Skip Index,Cc,Fref) Copy Stack(E,Saved Stack) Old Stack == E E == Saved Stack Tos == E_Stack Sos == Tos_Stp %cycle Get Token %exit %if Token = SC Endskip %if Statement = 0 %then Compile Instruction %else Program Element %repeat Copy Stack(Saved Stack,E) E == Old Stack Tos == E_Stack Sos == Tos_Stp Process Label(Skip Index,0,Fdef) %end { of Compile Skip } %routine Compile Goto {Compile Goto} {===================} %record(stackfm)%name Reg Fail("Not Paddr in Goto") %if Tos_Type # Paddr %if Tos_Base>=0 %and Tos_Acru=VinS %thenstart Tos_Type = Int Load(Tos,Any) Tos_Type = Paddr %finish Tos_Acru = Vins %if Tos_Base=0 %thenstart printsymbol(13) Put(Tos_Offset) Put Byte(Op Map(Jmp)) Put Byte(x'9f') Put Longword(Tos_Offset) Pop %return %finish Plant1(Jmp, Tos) Pop Empty %end %routine Compile Delete {Compile Delete} {=====================} %integer D Tag D Tag = Number Fail("Delete in routine") %if In Routine # 0 Top Tag = D Tag-1 %end %routine Compile Label Spec {Compile Label Spec} {=========================} Newtag(Label Type) Tagv_Flags = Tagv_Flags!Spec Bit Free Label = Free Label+1 Tagv_Displacement = Free Label %end %routine Compile Label {Compile Label} {====================} Spectag(Label Type) %if Spec = 0 %start Free Label = Free Label+1 Tagv_Displacement = Free Label %finish Define Label(Tagv_Displacement) %end %routine Compile Routine Spec {Compile Routine Spec} {===========================} Newtag(Routine Type) Free Label = Free Label+1 Tagv_Displacement = Free Label Tagv_Flags = Tagv_Flags!Spec Bit Tag(Profile Type) %end %routine Routine Element {Routine Element} {======================} %if Token = SC Local %start Newtag(Local Type) Quantity Descriptor(Tagv, Local Displacement) %else Compile Instruction %finish %end %routine Compile Routine {Compile Routine} {======================} %record(Stack Fm) %name R,L %record(tagfm)%name Exp %record(stackfm)%name Res,Adr,Sp Desc %integer Export Param = -1 %integer TT = Top Tag %integer Body, Profile, New Ca, Area, Old Area %integer Local Label, Mask Label {labels for post processing} %integername Old Ca Fail("Nested routine") %if In Routine # 0 Regs Used = Mask Base In Routine = 1 Old Area = Current Area; Old Ca == Ca Free Area = Free Area-1 Area = Free Area New Area(Area, New Ca) Local Displacement = 4 Spectag(Routine Type); Body = Tagn %if Spec = 0 %or Tagv_Flags&Peculiar # 0 %start Tagv_Flags = Tagv_Flags&(\(Peculiar!Known)) Free Label = Free Label+1 Tagv_Displacement = Free Label %finish Mask Label = Tagv_Displacement Define Label(Tagv_Displacement) Tag(Profile Type); Profile = Tagn %if Tagv_Flags&Interface Bit#0 %start Ocode(Obj IntrfaceEp) Put(Mask Label) %finish Export Param = Var(Tagv_Export)_Displacement %if Tagv_Export#0 Put Word(X'0000') {entry mask, filled in by SIM3 eventually} Free Label = Free Label + 1 Local Label = Free Label SP Desc == Descriptor SP Desc = At SP SP Desc_Offset = X'70F0' { SP Desc describes the end of local name space } Define Label(Local Label) { to fill in the offset in Sim3 } Plant2(Movab,SP Desc,SpV) { update SP to point past locals } Dispose(SP Desc) Ocode(Obj RelR11) R == Register(R11) L == Literal(x'70F0F0F0') Plant2(Movl,L,R) Dispose(R) Dispose(L) %cycle Get Token %exit %if Token = SC Endroutine Routine Element %repeat %if Export Param # -1 %start Res == Register(R0) Stacked Descriptor Tos_Acru = VinS Tos_Base = Export Area Tos_Offset = Export Param Tos_Type = INT Tos_Mode = Ref Plant2(Movab,Tos,Res) Pop Dispose(Res) %finish Plant0(Ret) Fix Locals(Local Label) Fix Mask(Mask Label) End Area Locate Ca(Old Area, Old Ca) In Routine = 0 Top Tag = TT Process Label(-1, 0, 0) {check all is resolved} %end %routine Zero Area {Zero Area} {================} %record(Stack Fm) Maxlength, Dist %record(stackfm)%name Otos == Tos Maxlength_Data = Zero_Data; Maxlength_Offset = x'7FFF' Dist_Data = Maxlength_Data; Dist_Offset = -21 Promote Sos Fail("Not Oaddr in Zero Area") %if Otos_Type # Oaddr %or Tos_Type # Oaddr Address(Otos) Address(Tos) Loadup(Tos) Loadup(Otos) Plant2(Subl2,Tos,Otos) Tos_Acru = VinS Plant2(Cmpl,Otos,Maxlength) Plant Skip(2, 24) Plant5(Movc5, Zero, Tos, Zero, Maxlength, Tos) Tos_Acru = VinR Plant2(Addl2, Maxlength, Tos) Plant2(Subl2, Maxlength, Otos) Tos_Acru = VinS Put Word(x'df11') Plant1(Tstw,Otos) Plant Skip(2,6) Plant5(Movc5,Zero, Tos, Zero, Otos, Tos) Tos_Acru = VinR Dispose(Otos) %end %routine Init Area {Init Area} {================} Type Resolved Structure %if Typen > Size Fail("Not Oaddr at Initarea") %unless Tos_Type = Oaddr Load(Tos, Any I) %end %routine D Init Area {D Init Area} {==================} %routine Remove(%record(stackfm)%name V) {Remove} {======================================} Remove(V_Link) %and V_Link == Null %and V_Oper = 0 %if V_Oper >= Add Remove(V_A) %and V_A == Null %if V_A ## Null Dispose(V) %end Type Fail("Bad type for Dinitarea") %unless Typev_Flags&Indefinite # 0 Fail("Not Int at Dinitarea") %if Tos_Type # Int Remove(Tos) Pop Fail("Not Oaddr at DInitArea") %if Tos_Type # Oaddr Load(Tos, Any I) %end %routine Compile Instruction {Compile Instruction} {==========================} %switch I(1:142) ->I(Token) I(SC info): I(SC line): I(SC setswitch): Info Setting; %return I(SC Constspec): Compile Const Spec; %return I(SC const): Compile Const; %return {Record Descriptor} I(SC Record): Record Descriptor %return {Stack Instruction} I(SC Push): Push; %return I(SC Pushc): Value(1, 0, 0, -1); %return I(SC Pushlen): Pushlen; %return I(SC Dup): Dup; %return I(SC Pop): Pop; %return I(SC Popall): Popall; %return I(SC Empty): Empty; %return {Addressing Instruction} I(SC Fetch): Fetch; %return I(SC Refer): Refer; %return I(SC Deref): Deref; %return I(SC Select): Select; %return I(SC Remote): Remote; %return I(SC Index): Index; %return I(SC Inco): Inco; %return I(SC Deco): Deco; %return I(SC Dist): Dist; %return I(SC Dsize): Dsize; %return I(SC Locate): Locate; %return {Temp Control} I(SC Tinito): Tinito; %return I(SC Tgeto): Tgeto; %return I(SC Tseto): Tseto; %return {Arithmetic Instruction} I(SC Add): I(SC Sub): I(SC Mult): I(SC Div): I(SC Rem): I(SC And): I(SC Or): I(SC Xor): Pop and Set %if Token >= SC And %start {and, or, xor} Fail("Not bool") %if Tos_Type # Bool %else Deal with Sint(Sos) Deal with Sint(Tos) %finish Fail("Types differ") %if Sos_Type # Tos_Type Operate(Map Oper(Token), Sos, Tos) Tos == Sos %return I(SC Imp): Pop and Set Fail("Bad type for Imp") %if Sos_Type # Tos_Type # Bool Operate(Complement, Sos, Null) %if Sos_Flags&NoNot = 0 Operate(Or, Sos, Tos) Tos == Sos %return I(SC Eqv): Pop and Set Fail("Bad type for Eqv") %if Sos_Type # Tos_Type # Bool Operate(Xor, Sos, Tos) Tos == Sos Operate(Complement, Tos, Null) %return I(SC Neg): I(SC Not): Deal with Sint(Tos) Operate(Map Oper(Token), Tos, Null) %return I(SC Compare): Compare(Relation, 1); %return {Jump Instruction} I(SC Switch): Switch Jump; %return I(SC Fjumpif): FJump(Relation); %return I(SC Fjump): FJump(0); %return I(SC Sdest): Sdest; %return I(SC Fdest): Fdest; %return I(SC Bjumpif): BJump(Relation); %return I(SC Bjump): BJump(0); %return I(SC Bdest): Bdest; %return {If Instruction} I(SC If): Compile If(0); %return {Segment Instruction} I(SC Bseg): Compile Segment; %return {Area Initialisation} I(SC Zeroarea): Zero Area; %return I(SC Initarea): Init Area; %return I(SC Dinitarea): D Init Area; %return {Line Instruction} {Routine Specification} I(SC Routinespec):Compile Routine Spec; %return {Assign Instruction} I(SC Assign): Set Sos Assign(Sos, Tos) Pop; Pop %return I(SC Update): Set Sos Assign(Sos, Tos) Pop %return I(SC Rupdate): Set Sos Assign(Tos, Sos) Pop %return {Protect Instruction} I(SC Save): Save(0); %return {Access Instruction} I(SC Setobj): Set Obj; %return I(SC Getobj): Get Obj; %return I(SC Access): Access; %return {Convert Instruction} I(SC Convert): Convert Instruction(1); %return I(SC SConvert): Convert Instruction(-1); %return {Skip Instruction} I(SC Skipif): Compile Skip(0); %return {Call Instruction} I(SC Precall): Precall(0); %return I(SC Asscall): Precall(1); %return I(SC Repcall): Precall(-1); %return {Eval Instruction} I(SC Eval): Eval; %return I(*): write(token,4);fail("Unknown Instruction") %end %routine Program Element {Program Element} {======================} %if Token = SC Constspec %start Compile Const Spec %else %if Token = SC Profile Compile Profile %else %if Token = SC Const Compile Const %else %if Token = SC Skipif Compile Skip(1) %else %if Token = SC Save Save(1) %else %if Token = SC Goto Compile Goto %else %if Token = SC Delete Compile Delete %else %if Token = SC Labelspec Compile Label Spec %else %if Token = SC Label Compile Label %else %if Token = SC Routine Compile Routine %else %if Token = SC If Compile If(1) %else %if Token = SC Bseg Compile Segment %else %if Token = SC Insert Compile Insert %else Compile Instruction %finish %end %routine Compile Main {Compile Main} {===================} %record(Stack Fm)%name R,L %integer Mask Label Dump Module Id(File Mod name."_SIM") Local Displacement = 4 Free Label = Free Label+1 Main Ep = Free Label Define Label(Main Ep) Mask Label = Free Label Put Word(X'0000') { entry mask, filled in by SIM3 } Ocode(Obj RelR11) r == Register(R11) L == Literal(x'70F0F0F0') Plant2(Movl,L,r) r = At Sp r_Base = Fp r_Acru = VinS Plant2(Movl,L,r) Plant2(Movl,L,L) Dispose (R) Dispose (L) r == Null %cycle Get Token %exit %if Token = SC Endprogram Program Element %repeat Plant0(Ret) %if Magic3 = 1 Fix Mask(Mask Label) %end %routine Visible {Visible} {==============} %if Token = SC Record %start Record Descriptor %else %if Token = SC Profile Compile Profile %else %if Token = SC Routinespec Compile Routine Spec %else %if Token = SC Labelspec Compile Label Spec %else %if Token = SC Constspec Compile Const Spec %else %if Token = SC Insert Compile Insert %else Info Setting %finish %end %routine Dump Module Id(%string(31) Module) {Dump Module Id} {==============================================} Dcode(Dir Module) Put String(Module) Select Out(Obj) %end %routine Compile Module {Compile Module} {=====================} %string(31) Module Id, Check Code Module Id = String 31 %if Module Id->Module Id.(".").Check Code %then -> Next {dummy jump} Next: Check Code = String 31 Dump Module id(Module Id) %cycle Get Token %if Token = SC Tag %start Tag List(Module Id, Check Code) %exit %finish %if Token = SC Existing %start Get Token %exit %finish Visible %repeat Fail("Body missing") %unless Token = SC Body %cycle Get Token %exit %if Token = SC Endmodule Program Element %repeat %end %routine Value(%integer Repeat, Area, At, Obj Size) {Value} {=======================================} %owninteger Nested = 0 %integer Last Tag, Times %integer Old Area %integername Old Ca %integer Ctoken, N %string(31) Id %switch C(SC Crecord:SC False) %routine Set(%integer Type) {Set} {=========================} %if Area # 0 %start Dump Constant(Type, Area, At) %else %if Type = Real %or Type = Lreal Stack Real(Type) %else Stack Integer(Type) %finish %end %routine Attribute Value {Attribute Value} {======================} {Token already input} %record(tagfm)%name Av %integer Size Fail("Faulty attribute value") %unless Token = SC Attr Tag(Attribute Type) Av == Tagv Type %if control&1#0 %thenstart Selectoutput(report) newline printstring("Item Size ".itos(av_item size)." Size = ".itos(av_size)) selectoutput(current stream) %finish %if Av_Item Size=0 %then Size = Av_Size %else Size = Av_Item Size Value(-1 , Constant Area, At+Av_Displacement, Size) %end { of Attribute Value } Times = -1 %cycle %cycle Times = Times+1 %if SC Crecord <= Pending <= SC False %thenstart Get Token Ctoken = Token ->C(Token) c(SC Crecord): Type %if Times>0 %then At = At + Obj Size %if Nested = 0 %and Obj Size<0 %start { Pushc structured type } Stack Integer(Typen) Tos_Acru = VinS Tos_Offset = Constant Displacement Tos_Base = Constant Area At = Constant Displacement Constant Displacement = Constant Displacement + Tagv_Size %finish Dump Const Disp %if Control&1#0 Nested = Nested+1 Fail("Not a structured type") %if Typev_Tagtype # Record Type Get Token %cycle Attribute Value Get Token %repeat %until Token = SC Endrecord Nested = Nested-1 %exit c(SC Cchar): Next Token Integer Literal = Token Set(Char) %exit c(SC Cint): Integer Literal = I String Set(Int) %exit c(SC Csize): Type Integer Literal = Typev_size Set(Size) %exit c(SC Creal): Real Literal = R String Set(Real) %exit c(SC Clreal): Real Literal = R String Set(Lreal) %exit c(SC Caaddr): Tag(Attribute Type) Integer Literal = Tagv_Displacement Set(Aaddr) %exit c(SC Coaddr): Tag(0) Fail("Not a Global or Constant") %if Tagv_Tagtype > Global Type %if Tagv_Flags&External#0 %and Tagv_Module#0 %thenstart %if Area=0 %then Stack External(Oaddr) %else Dump External(At) %exit %finish Integer Literal = Tagv_Displacement Set(Oaddr) %exit c(SC Cgaddr): Tag(0) %if Tagv_Tag Type=Global Type %thenstart %if Area#0 %thenstart Old Area = Current Area Old Ca == Ca Locate Ca(Constant Area,At) Ocode(Obj Relinst) Put(x'7fff') Put Longword(Tagv_Displacement) Put Longword(0) Locate Ca(Old Area, Old Ca) %finishelsestart Stacked Descriptor Tos_Type = Gaddr Tos_Acru = AVinS Tos_Offset = Tagv_Displacement Tos_Base = R11 %finish %exit %finish %if Tagv_Flags&External#0 %and Tagv_Module#0 %thenstart %if Area=0 %start Stacked Descriptor Tos_Type = Gaddr Tos_Acru = AVinS Tos_Base = -(Tagv_Module<<2) Tos_Offset = Tagv_Displacement %else Dump External(At) Integer Literal = 0 Set(Int) %finish %exit %finish Integer Literal = Tagv_Displacement Set(Gaddr) %exit c(SC Cpaddr): Tag(Label Type) %if Tagv_Flags&External#0 %and Tagv_Module#0 %start %if Area=0 %then Stack External(Paddr) %else Dump External(At) %exit %finish Integer Literal = Tagv_Displacement Set(Paddr) %exit c(SC Cdot): n = 0; Integer Literal = 0 %cycle Tag(n) n = Attribute Type Integer Literal = Integer Literal+Tagv_Displacement Get Token %repeat %until Token # SC Cdot %if Token = SC Caaddr %start Set(Aaddr) %else %if TOKEN = SC Cgaddr Set(Gaddr) %finish %else Fail("'Aaddr' or 'Gaddr' missing") %exit c(SC Craddr): Tag(Routine Type) %if Tagv_Flags&External#0 %and Tagv_Module#0 %start %if Area=0 %then Stack External(Raddr) %else Dump External(At) %exit %finish Integer Literal = Tagv_Displacement Set(Raddr) %exit c(SC nobody): Token = 28 c(SC nowhere): c(SC anone): c(SC onone): Integer Literal = 0 %if Area=0 %thenstart { Create new Tos,i.e. PUSH } Set(Token-17) Tos_Flags = Tos_Flags!NoneF %finishelse Set(Int) { Use Int to avoid relocation } %exit c(SC Gnone): Integer Literal = 0 %if Area=0 %then Set(Gaddr) %and %exit Set(Int); Set(Int); %exit c(SC False): Integer Literal = 0; Set(Bool); %exit c(SC True): Integer Literal = \0; Set(Bool); %exit c(SC Text): n = Number %while N > 0 %cycle N = N-1 Next Token Integer Literal = Token; Set(Char) %repeat %return %finishelsestart %if Pending = SC Nosize %thenstart Integer Literal = 0 Set(Size) Get Token %finishelsestart %if Times = 0 %thenstart Fail("Constant missing") %unless Pending = SC System Get Token {skip system} Id = String 31 %finish %return %finish %finish %repeat Repeat = Repeat - 1 %if Repeat>0 %repeat %until Repeat = 0 Dump Const Disp %if Control&1#0 %end { of Value } %routine Global Definition {Global Definition} {========================} Newtag(Global Type) Quantity Descriptor(Tagv, Global Displacement) %end %routine Global Interface {Global Interface} {=======================} %string(31) System {Token already input} %if Token = SC Record %start Record Descriptor %else %if Token = SC Profile Compile Profile %else %if Token = SC Info Info Setting %else %if Token = SC Global %start Global Definition %else %if Token = SC Const Compile Const %else Info Setting %finish %if Pending = SC System %start Get Token {Skip system} System = string 31 %finish %finish %end %routine Tag List(%string(31)%name File, Check Code) {Tag List} {==================================================} %recordformat dumpfm(%integer X Tag, Tag Type, Flags, Module, Chain, Size, Item Size, Xmod, Type, Reps, Base Size, (%short Import, Export %or %integer Displacement)) %routine Tags(%integer Wanted) {Tags} {============================} %integer Xmodule %record(tagfm)%name W, Dt %record(dumpfm) D %routine Dump(%record(dumpfm)%name V) {Dump} {===================================} %record(Modulefm)%name M Put(V_X Tag) Printsymbol(V_Tag Type) Printsymbol(V_Flags) Put(V_Chain) Put(V_Size) Put(V_Item Size) Put(V_Base Size) Put(V_Reps) %if V_Flags&Peculiar # 0 %start Put String(External Id(V_Displacement)) %else Put(V_Import) Put(V_Export) %finish Printsymbol(V_Xmod) %if V_Xmod # 0 %start M == Module(V_XMod) Put(V_Type-100) Put String(M_File) %else Put(V_Type) %finish %end %integerfn External Tag(%integer Tagn) {External Tag} {====================================} %record(tagfm)%name T XModule = 0 %result = 0 %if Tagn = 0 T == Var(Tagn) %if T_Flags&External = 0 %start %result = Tagn %if Tagn <= Size {pre-defined} {It's still internal} %if Token # SC Tag %start {no more left} Fail("External tag has internal component?") %else Tags(Tagn) %finish Wanted = 0 %if Wanted # Bool %and W_Flags&External # 0 %finish XModule = T_Module %result = T_X Tag+100 {keep it clear of pre-defined tags} {see COMPILE INSERT} %end W == Var(Wanted) %cycle Tag(0) Wanted = 0 %if Tagn = Wanted Dt == Tagv Dt_X Tag = Number Get Token Fail("Duplicate external") %if Dt_Flags&External # 0 Dt_Flags = Dt_Flags!External D_Module = Dt_Module D_X Tag = Dt_X Tag D_Tag Type = Dt_Tag Type D_Flags = Dt_Flags D_Chain = Dt_Chain D_Size = Dt_Size D_Item Size = Dt_Item Size D_Base Size = Dt_Base Size D_Reps = Dt_Reps D_Displacement = Dt_Displacement D_Type = External Tag(Dt_Type) D_Xmod = XModule D_Chain = External Tag(D_Chain) %if D_Tag Type = Profile Type %start D_Import = External Tag(D_Import) D_Export = External Tag(D_Export) %finish Dump(D) %return %if Wanted = 0 %repeat %until Token # SC Tag %return %if Wanted = Bool {All resolved} Fail("External tag has internal component?") %end Fail("Multiple Tag list") %if T3 Used # 0 T3 Used = 1 Open Output(Moduleo, "T3.bin-b") Select Out(Moduleo) Put String(File) Put String(Check Code) Tags(Bool) Put(x'FFFF') {End Marker} printsymbol(x'FF') {For bouncing off} Close Output Select Out(Obj) %end %routine Compile Insert {Compile Insert} {=====================} %string(31) Module Id, Check Code, Check %integer Tagbase, Taglimit %integer Old Pending, n, Old Monitor %integerfn Relocated(%integer Tag) {================================} %result = Tag %if Tag < 100 Tag = Tag+Tagbase-100 ! Fail("Inserted tag out of range") %if Tag > Taglimit %result = Tag %end %routine Input(%integer Xn) {Input} {=========================} %integer T, B, Tn %string(31) File Tn = Xn+Tagbase; Fail("External Tag out of range") %if Tn > Taglimit Set Tag(Tn) Next Token; Tagv_Tagtype = Token Next Token; Tagv_Flags = Token!Inserted Tagv_X Tag = Xn Tagv_Chain = Relocated(Number) Tagv_Module = Module Number Tagv_Size <- Number Tagv_Item Size <- Number Tagv_Base Size <- Number Tagv_Reps <- Number %if Tagv_Flags&Peculiar # 0 %start Tagv_Displacement = External Ref(String 31) %else Tagv_Import <- Number Tagv_Export <- Number %finish Next Token; B = Token T = Number {Type} %if B # 0 %start File = String 31 B = Module Number %cycle B = B-1; Fail("Module ".file." not inserted") %if B <= 0 %repeat %until Module(B)_File = File T = T+Module(B)_Base %else T = Relocated(T) %finish Tagv_Type = T %end Module Id = String 31 %if Module Id->Module Id.(".").Check Code %then -> Next {dummy jump} Next: Check Code = String 31 Tagbase = Number Taglimit = Number Module Number = Module Number+1 Fail("Too many inserted modules") %if Module Number > Max Modules Module(Module Number)_Base = Tagbase Module(Module Number)_File = ModuleId Dcode(Dir Insert); Put String(Module id) Select Out(Obj) Open Input(ModuleI, ModuleId.".Mdb-b") select input(ModuleI) Old Pending = Pending readsymbol(Pending) {Prime it} Old Monitor = Monitor Input Monitor Input = 0 %if Monitor Input < 2 Check = String 31 %if Check # Check Code %start Fail("Modules Differ?") %finish %cycle n = Number %exit %if N = x'FFFF' {End marker} {Zero is a valid external tag - Damn} Input(N) %if Tagv_Tag Type = Profile Type %start Tagv_Import = Relocated(Tagv_Import) Tagv_Export = Relocated(Tagv_Export) %finish %if Monitor Input # 0 %start select output(Report) flush line select output(Current Stream) %finish %repeat select input(Source) Pending = Old Pending {Restore old value} Monitor Input = Old Monitor %end %routine Init {Init} {===========} %record(tagfm)%name Global {Init already input} %cycle Tag(Global Type); Global == Tagv Type Value(0, Global Area, Global_Displacement, 0) Get Token %repeat %until Token # Sc Init %end %routine Compile Interface Module {Compile Interface Module} {===============================} %string(31) Module Id, Check Code get token Fail("'Module' missing") %unless token = SC Module module id = string 31 check code = string 31 Dump Module Id(Module Id) %cycle Get Token; %exit %if Token = SC Tag Global Interface %repeat Tag List(Module id, Check Code) Fail("'Body' missing") %unless Token = SC Body %cycle Get Token %exit %if Token # SC Init Init %repeat Fail("'Endmodule' missing") %unless Token = SC Endmodule %end %routine Compile Program {Compile Program} {======================} %string(31) Phead readsymbol(pending); Fail("'Program' missing") %unless pending = SC program get token Phead = string 31 get token %if token = SC main %start Compile Main %else%if token = SC module %cycle Compile Module Get Token %repeat %until Token = SC Endprogram %else %if token = SC global Compile Interface Module Get Token Fail("Endofprogram missing") %if Token # SC Endprogram %finish %else Fail("Unknown type of program body") Empty %end !***** I N I T I A L I S A T I O N ***** %if Magic Line = 0 %start Control = 255 Monitor Input = 255 Monitor Output = 255 %finish Parms == Null Sp Plus _Type = Longword; Sp Plus _Acru = AutoI; Sp Plus _Base = Sp Minus Sp_Type = Longword; Minus Sp_Acru = AutoD; Minus Sp_Base = Sp At Sp _Type = Longword; At Sp _Acru = VinS; At Sp _Base = Sp SpV _Type = Longword; SpV _Acru = VinR; SpV _Base = Sp Rv0 _Type = Longword; Rv0 _Acru = VinR; Rv0 _Base = R0 Cm31 _Type = Longword; Cm31_offset = -31 Display _Type = Oaddr ; Display_Acru = VinS; Display_Base = R11 Display _Offset = -16*4; Display_Mode = Ref Overflow = Display; Overflow_Offset = -26*4 clear stack(E) !***** P R E - D E F I N E D T Y P E S ***** Var(0)_Flags = External %for tagn = bool, 1, Size %cycle tagv == var(tagn) tagv = 0 tagv_tagtype = Type Type tagv_type = tagn {self ref} tagv_Xtag = tagn tagv_flags = type bit!defined bit tagv_size = 4 %repeat {set non-longword sizes in bytes} Var(Bool) _size = 1 Var(Char) _size = 1 Var(Sint) _size = 2 Var(Lreal)_size = 8 Var(Gaddr)_size = 8 New Area(Global Area, Global Displacement) New Area( Export Area, Export Displacement) New Area(Constant Area, Constant Displacement) New Area(Code Area, Code Displacement) select input(Source) Compile Program Select Area(Code Area, 0, Code Displacement ); End Area Select Area(Constant Area, 0, Constant Displacement); End Area Select Area( Export Area, 0, Export Displacement); End Area Select Area( Global Area, 0, Global Displacement); End Area dcode(DIR complete); Put(Export Displacement); Put(Global Displacement) Put Long(Diags Size) Put(T3 Used) ocode(OBJ complete); Put(Main Ep) Process Label(-1, 0, 0) {check for dangling labels} %end %endoffile