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