! Some instances of the following records failed to identify fields: Q_ V_ S_ AVAR_ B_ C_ W_ F_ R_ CHAIN_ TARGET_ L_
{###################################}
{# Copyright (C) 1988 #}
{# 3L Limited #}
{# #}
{# All rights reserved #}
{###################################}
{Pass 2 for ARM IMP}
externalstring(7) P2 Version = "004"
! To Do:
!
!Revision history:
!
! 004 7-Sep-88 PSR Made DALLOC forget Sp and
! made FORGET forget locked regs {C-136}
! 003 22-Jun-88 PSR Changes to compile native on A310
! Made diag string 127 instead of 31
! 002 23-Feb-88 PSR Changed to ARM calling stack frame
! 001 4-FEB-88 PSR Started additions for ACORN DEBUG
! - Record diags dumped in reverse order (that of declaration)
! 0.9 15-Jan-88 PSR Removed the %name %array ILABELS by means of
! another recordformat.
! ******* release 1.2 sent to Acorn & Validated *******
! 2-Nov-87 PSR Put FORGET DESTINATION in JUMP BACKWARDS to permit
! unassigned checking of control
! catching unassigned FOR control variables
! - Made MULTIPLY call LOAD PROTECTED in case destination
! register is already in use. (SCR/87/448)
! 9-Oct-87 PSR Made R14 preferable when hazarding to prevent
! corrupting a parameter (e.g. for REAL EXP). (SCR/87/449)
! - Added check for "Subroutines nested too deeply" (SCR/87/447)
! 0.8 5-Oct-87 PSR Removed optimisation for C1*(V1+C2) :: overflow!
! - Added check for the cases: (I<<n) + Real
! and: Real + (I<<n) (SCR/87/407)
! - MULTIPLY was corrupting INVERTED as it used the COMPARE
! mechanism to generate the in-line code for *. This
! mis-compiled 0 >= A*B (SCR/87/409)
! - Fixed OPERATE which was converting A<<C - D into
! D - A<<C. It now uses RSB instead. (SCR/87/408)
! - Corrected a problem in FLOAT which made -10 into -2.0
! (SCR/87/411)
! - Added explicit check for setting bit out of range in
! BUILD SET. (SCR/87/423)
! 0.7 19-sep-87 PSR Corrected problem with hazard all after PASS PARAMETERS
! corrupting one (or more) of the parameter registers
! (SCR/87/392)
! - Set comparison changed to fix miscompilation of
! IF [] >= [something] which was returning a zero/non-zero
! condition code but testing for a >= or <= code (SCR/87/398)
! - Added internally-generated NO-OP 128+'0' + <tag>
! - made WORK AREAS an indefinitely expanding list. (SCR/87/400)
! - Corrected bugs in ABS(ABS(X)), ABS(-X), and ABS(¬X).
! (SCR/87/401, SCR/87/422)
! 0.6 16-Sep-87 PSR Test version for BSI visit
! - Made BUILD SET save & restore oper & link to fix
! problems with S := [1..x]-[y]; (SCR/87/388)
! - Set the WORK SET bit on the temp created by BUILD SET
! - Problem with passing longreals as parameters. The LDM
! in PPARAMS.INC was not preceded by the necessary HAZARDS
! - ABS(X) used unsafe MOVS to set condition code,
! would not work if CC already set incorrectly.
! 0.5 7-Aug-87 NPH [SCR/87/324] Set value to Default value in Update Line
!
! 0.5 4-Aug-87 NPH [SCR/87/325] If saved, Wsp must be saved after a Dalloc
! Quick soln : save it again if it has been saved.
!
! 30-Jul-87 PSR PESSIMISE got the wrong displacement when temps were
! a long way away from FP
! Was also a problem with STAB.
! 8-Jul-87 PSR Forget destination not forgetting after R_a(n) = ...
! - Stopped optimising X&255 -> byte load when checkable
! 0.4 24-Jun-87 PSR The event trap routine was forgetting everything
! AFTER it had planted the LDR Wsp .... This was wrong
! it the save area was too far away for a simple load.
! This gave rise to an address error in Pascal Pass1 after
! a *FATAL ERROR report.
! 0.3 14-Jun-87 PSR Fixed ALL CONST when first string isn't constant
! - Fixed PRINTSTRING("")
! 0.2 28-Mar-86 PSR Tightened up setting condition-code values
! - remembered ZERO after in-line loops
! - added optimisation to remember constants after IF x=const
! - improved handling of SHORTS (esp in S&16_FFFF)
! - optimised X op Y shift Const, X shift const op Y
! - corrected problem with OWNs living at 0(SB)
! - corrected problem causing Record=0 to clear by bytes.
! 0.01 24-Mar-86 PSR Released to Acorn
! 0.01 27-Jan-86 PSR Cloned from SUN pass2 v0.39
owninteger Diag = 0,
Debug = 0, {#0 if -DEBUG specified} {001}
Current Line = 0 {here to aid diagnostics}
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,
MonBang = 1<<9
constinteger Infinity = (-1)>>1,
Minus Infinity = ¬Infinity
constinteger Max Vars = 2000, Var Top = Max Vars>>6,
Max Labels = 8000, Max Label = Max Labels!255,
Max Work Areas = 500, Max Work Area = Max Work Areas!15,
Max Nesting = 17,
Max Bound = 7,
Set Size = 256//8
{Types}
constinteger Undefined = 0,
Integers = 1,
Shorts = 2,
Halves = 3,
Bytes = 4,
Addrs = 5,
Reals = 6,
Lreals = 7,
Strings = 8,
Records = 9,
Generals = 10,
Labels = 11,
Booleans = 12,
Sets = 13
constbytearray Internal Type(Undefined:Sets) =
Undefined, Integers, Shorts, Halves, Bytes, Addrs,
Reals, Lreals,
Strings, Records, Generals, Labels, Bytes, Sets
conststring(7)array TypeId(Undefined:Sets) =
"Unknown", "Integer", "Short ", "Half ", "Byte ", "Addr ",
"Real ", "Lreal ",
"String ", "Record ", "General", "Label ", "Boolean", "Set "
constbytearray Type Fmt (Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,0, 0,1,32
constbytearray Type Code(Undefined:Sets) = 0,1,6,6,5,1,2,8,3,4,0,10,0,0
constbytearray Type Size(Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,12,0,2,Set Size
constbytearray Ucheck (Undefined:Sets) = 0,1,0,0,0,1,1,1,1,0,0,0,0,0
!%from IMP %include Option3l, Stream3l, Spec3l, Interfac,
! Comm23, Attr, Lflags
include "imp/option3l.inc"
include "imp/stream3l.inc"
include "imp/spec3l.inc"
include "imp/interfac.inc"
include "imp/comm23.inc"
include "imp/attr.inc"
include "imp/lflags.inc"
include "opcodes.inc"
externalroutine PASS2(record(Commfm)name Interface)
constinteger Word Length = 4, {in bytes}
Alignment = 3, {word alignment needed}
Alignment Mask = ¬Alignment
externalroutinespec D68000(integer Op, Ca)
externalroutinespec Dump Encoded(integer N)
include "xspecs.inc"
{Register info}
{Integer activities are: 0 = free
{ -1 = locked
{ >0 = claimed that many times
{NOTE: registers are only claimed by LOAD (or the load implied by OPTIMISE}
{ Register Alias}
constinteger None = 0,
R0 = 1,
R1 = 2,
R2 = 3,
R3 = 4,
R4 = 5,
R5 = 6,
R6 = 7,
R7 = 8,
R8 = 9,
R9 = 10, Sb = R9,
R10 = 11, Fp = R10,
R11 = 12, Ip = R11,
R12 = 13, Sp = R12,
R13 = 14, Sl = R13,
R14 = 15, Link = R14,
R15 = 16, Pc = R15,
Any = 17,
F0 = 18,
F1 = 19,
F2 = 20,
F3 = 21,
F4 = 22,
F5 = 23,
F6 = 24,
F7 = 25,
AnyF = 26
{ Register Alias}
constbytearray Actual(0:AnyF) = 0, 0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15, 0,
0, 1, 2, 3, 4, 5, 6, 7, 0
conststring(3)array RegId(0:AnyF) = "",
"R0 ", "R1 ", "R2 ", "R3 ", "R4 ", "R5 ", "R6 ", "R7 ",
"R8 ", "R9 ", "R10", "R11", "R12", "R13", "R14", "R15", "R? ",
"F0 ", "F1 ", "F2 ", "F3 ", "F4 ", "F5 ", "F6 ", "F7 ", "F? "
constbytearray Rtype(0:AnyF) = Undefined, Integers(17), Lreals(9)
recordformat Boundfm(integer Lower, Upper, Mult)
recordformat Afm(integer Dimension,
Total Size,
Zero Displacement,
DV,
Local Frame,
Base,
record(Boundfm)array Bound(1:Max Bound))
constrecord(Afm)name A type == 0 {for NEW}
recordformat Varfm(integer Flags,
byte Base, Prim,
byte Type, Form,
(longreal Rvar or
integer Disp, (integer Extra or record(Afm)name Adata)),
(integer Format or integer Scale),
integer Area)
recordformatspec Stackfm
recordformat Olfm(integer Oper, record(Stackfm)name Link)
recordformat Xfm(integer Xsize, record(Stackfm)name Index)
recordformat Datafm( c
record(Varfm) V,
integer Varno,
record(Varfm)name Fv,
(integer Bias or byte Reg, Label),
record(Stackfm)name Params, Record,
(integer Oper, record(Stackfm)name Link or record(Olfm) Oplink),
(integer Xsize, record(Stackfm)name Index or record(Xfm) X))
recordformat Memberfm(integer Const, Items,
record(Stackfm)name A, B,
record(Memberfm)name Link)
constrecord(Memberfm)name Memberfm Type == 0
recordformat Stackfm( c
record(Varfm) V or
record(Datafm) Data or
integer Flags,
byte Base, Prim,
byte Type, Form,
(longreal Rval or integer Rhigh, Rlow c
or (integer Disp, (integer Extra or record(Afm)name Adata)),
(integer Format or integer Scale),
integer Area,
integer Varno,
(record(Varfm)name Fv or record(Memberfm)name Members),
(integer Bias or byte Reg, Label),
record(Stackfm)name Params, Record,
(integer Oper, record(Stackfm)name Link or record(Olfm) Oplink),
(integer Xsize, record(Stackfm)name Index or record(Xfm) X)),
record(Stackfm)name Using, Stack)
constrecord(Stackfm)name Stackfm Type == 0
recordformat Withfm(integer Key, record(Datafm) Data,
record(Withfm)name Link)
constrecord(Withfm)name Withfm Type == 0
recordformat Workfm(integer Size, Displacement, Validity)
recordformat WorkVfm(record(WorkVfm)name Link,
record(Workfm)array W(0:30))
constrecord(WorkVfm)name WorkVfmType == 0
record(WorkVfm) Work List = 0
integer Work Validity = 1, Last Work = -1
{Flag bits}
constinteger By Ref = 1<< 0, {in FLAGS}
Array = 1<< 1,
Parameter = 1<< 2, {procedure parameter}
Defered = 1<< 3, {needs indirection}
Hazarded = 1<< 4,
Static = 1<< 5,
Arrayname = 1<< 6,
Known Ass = 1<< 7, {cannot be unassigned}
Prim Proc = 1<< 8,
Primitive = 1<< 9, {prim procedure}
Xproc Spec = 1<<10, {external procedure}
Closed = 1<<11, {cannot return}
Internal = 1<<12, {can use JSB}
Call it = 1<<13, {cannot use JSB}
Null Set = 1<<14,
Keep Local = 1<<15,
Nasty Proc = 1<<16, {uses the environment}
Awanted = 1<<17,
Work Set = 1<<18,
Answer = 1<<19,
Checkable = 1<<20,
Pred Call = 1<<21, {is a predicate}
Stored With = 1<<22,
Xdata Spec = 1<<23,
Xproc Def = 1<<24
recordformat Forfm(byte Label, Entry, Reg, CC,
integer Type,
integer AS,
record(Datafm) Control, Final,
record(Forfm)name Link)
constrecord(Forfm)name ForfmType == 0
ownrecord (Forfm)name Fors == 0
ownrecord(Stackfm)name Stack == 0
ownrecord(Stackfm)name Using == 0,
Dasl == 0
recordformat Valuefm(longreal Real or c
integer Integer or c
string(255) String or c
bytearray Fill(0:255))
ownrecord(Valuefm) Value = 0,
Default Value = 0
{Internal operations}
constinteger Real Shift = 21
constinteger NOTx = 1, {Integer operations}
NEGx = 2,
ABSx = 3,
ADDx = 4,
SUBx = 5,
MULx = 6,
DIVx = 7,
EXPx = 8,
ANDx = 9,
ORx = 10,
XORx = 11,
BICx = 12,
ROTx = 13,
LSHx = 14,
RSHx = 15,
REMx = 16,
MODx = 17,
MULHx = 18, {special for halfword multiply}
UDIVx = 19, {unsigned divide}
UREMx = 20, {unsigned rem}
EXTx = 21,
CONCx = 22,
RNEGx = NEGx+Real Shift, {floating-point operations}
RABSx = ABSx+Real Shift,
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) =
"not ", "neg ", "abs ",
"add ", "sub ", "mul ", "div ", "exp ",
"and ", "or ", "xor ", "bic ", "rot ", "lsh ", "rsh ",
"rem ", "mod ",
"ext ", "mulh", "udiv", "urem", "conc",
"negr", "absr",
"addr", "subr", "mulr", "divr", "expr"
{Oper flags}
constinteger Commutative = 1<<0,
InPrim = 1<<1,
Easy = 1<<2,
Selfop = 1<<3,
Unary = 1<<5,
Incdec = 1<<6,
No Assoc = 1<<7,
Weak Assoc = 1<<8, Assoc Mask = No Assoc!Weak Assoc,
Nullop = 1<<9
constshortarray Oper Flags(NOTx:REXPx) =
{NOTx} Unary!Selfop,
{NEGx} Unary!Selfop,
{ABSx} Unary,
{ADDx} Commutative!Easy!Selfop!Nullop!Incdec,
{SUBx} Easy!Selfop!Nullop!Incdec,
{MULx} Commutative!Weak Assoc!Nullop,
{DIVx} No Assoc!Nullop,
{EXPx} InPrim!No Assoc!Nullop,
{ANDx} Weak Assoc!Easy!Nullop!Selfop!Commutative,
{ORx} Weak Assoc!Easy!Nullop!Selfop!Commutative,
{XORx} Weak Assoc!Easy!Nullop!Selfop!Commutative,
{BICx} Weak Assoc!Easy!Nullop!Selfop,
{ROTx} No Assoc!Nullop,
{LSHx} No Assoc!Nullop!Selfop,
{RSHx} No Assoc!Nullop!Selfop,
{REMx} No Assoc,
{MODx} No Assoc,
{EXTx} No Assoc,
{MULHx} No Assoc,
{UDIVx} No Assoc,
{UREMx} No Assoc,
{CONCx} No Assoc,
{RNEGx} No Assoc!Unary!Selfop,
{RABSx} No Assoc!Unary,
{RADDx} No Assoc!Commutative,
{RSUBx} No Assoc,
{RMULx} No Assoc!Commutative,
{RDIVx} No Assoc,
{REXPx} No Assoc!Inprim
constintegerarray Easy Op(ADDx:BICx) =
{ADDx} ADD,
{SUBx} SUB,
{MULx} 0,
{DIVx} 0,
{EXPx} 0,
{ANDx} AND,
{ORx} ORR,
{XORx} EOR,
{BICx} BIC
constintegerarray Null Value(ADDx:RSHx) =
0, {ADDx} 0, {SUBx} 1, {MULx}
1, {DIVx} 1, {EXPx} -1, {ANDx}
0, {ORx} 0, {XORx} 0, {BICx} 0, {ROTx}
0, {LSHx} 0 {RSHx}
{Condition codes}
constinteger EQ = 1, LT = 2, GT = 4, TT = 8, Always = 7,
NE = 6, LE = 3, GE = 5, FF = 9, Never = 0
constbytearray Reverse(Never:FF) = Never,
EQ {EQ}, GT {LT}, GE {LE},
LT {GT}, LE {GE}, NE {NE},
Always, TT {TT}, FF {FF}
constbytearray Negated(Never:FF) = Always,
NE {EQ}, GE {LT}, GT {LE},
LE {GT}, LT {GE}, EQ {NE},
Never, FF {TT}, TT {FF}
{Otypes}
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 Map = -2,
Fn = -1, {negative implies stacked result}
Routine = 0,
True = 1,
False = 2
integer J, NN
owninteger Code = 0, {current I-code symbol}
Pending = 0, {next I-code symbol}
Pending Tag = 0, {optimise 0<=N<=...}
Pending Lit = 0,
Pending Auto N = 0,
Pending Auto = 0,
Pending Auto Ca = 0,
Language Flags = 0,
Stack Check = 0, {entry for external}
Falign = 0 {worst internal alignment}
owninteger Invert = 0,
Unsigned = 0,
Free Label
constinteger Defined = 16_8000 0000,
Label Mask = ¬Defined,
Inverted = 1
recordformat Knowfm(byte Ftype, Reg, Base, Oper,
integer Disp, Area, Opnd, Extra,
record(Knowfm)name Link)
constrecord(Knowfm)name KnowfmType == 0
recordformat Labelfm(integer Lab, record(Knowfm)name Env)
recordformat Ilabelfm(record(Ilabelfm)name Link,
record(Labelfm)array Lab(0:255))
constrecord(Ilabelfm)name Ilabelfm Type == 0
record(Ilabelfm)name Ilabel List == NIL
!0.9! %record(Ilabelfm)%namearray Ilabels(0: Max Label>>8)
{0.9} recordformat IlabelPfm(record(Ilabelfm)name Label)
{0.9} record(IlabelPfm)array Ilabels(0:Max Label>>8)
ownrecord(Knowfm)name Knowing == 0,
Kasl == 0
ownintegerarray Ktimes(0:AnyF) = 0(*)
owninteger Used Time = 0
ownintegerarray Used(0:AnyF) = 0(*)
ownintegerarray Activity(0:AnyF) = 0(*)
owninteger Active Registers = 0
integer Pending Known Register = 0
record(Stackfm) Pending Known
ownstring(127) Alias = "", {003}
Internal Id = "",
External Id = "",
Section Id = ""
owninteger Decl Size,
Vlb, Vub,
Ostate,
OwnType,
OwnForm,
Ownextra,
Constant Type,
Init Flag = 0
record(Varfm)name DefV
record(Varfm) AltV
owninteger Parms
owninteger Section = 0
owninteger Control = 0, {Unass Check}
Unassigned = 0, {#0 for unassigned checks}
Compiling Prim = 0 {#0 when compiling PRIM file}
{Forms}
constinteger Address = 0,
Direct = Address+1,
AutoI = 2, Memorable Limit = AutoI,
AutoD = 3,
Proc = 4,
LabelX = 5,
Indirect = 15 {**only for VARs**}
conststring(6)array FormId(Address:LabelX) = "addr", "value", "()+",
"-()", "proc", "label"
{Prim routines}
constinteger Signal = 1, {%signal}
Cscomp = 2, {compare string & constant}
Sres = 3, {string resolution}
Sw Jump = 4, {switch jump}
Intexp = 5, {integer exponentiation}
RealExp = 6, {real exponentiation}
Genmove = 7, {general string move}
Sconc = 8, {string concatenation}
Scomp = 9, {string comparison}
Sjam = 10, {string jam transfer, length known}
SetIn = 11, {test for R0 IN (R3)}
Resflop = 12, {string resolution fails}
TestNil = 13, {Nil, Unassigned & Disposed}
MakeLocal = 14, {copy array into local space}
Aref = 15, {n-dim array reference}
Dynamic Range= 16, {Check R2 <= R1 <= R3}
Dynamic N = 17, {n-dim array declaration}
Frag1 = 18, {assign resolution fragment 1}
RtMonitor = 19, {invoke run-time monitor}
Set Bit = 20, {bit -> 1 in set}
Captest = 21, {test for capacity exceeded}
Ass Test = 22, {unassigned test}
Trace Line = 23, {line trace debugger}
Frag2 = 24, {assign resolution fragment 2}
Clear Bit = 25, {bit -> 0 in set}
Test New = 26, {fail if variant NEW}
Nil Test = 27, {Test for NIL pointer}
Set Bits = 28, {set multiple bits in SETs}
Set Add = 29,
Set Sub = 30,
Set Inter = 31,
Set GE = 32,
Check Range = 33,
Test MOD = 34, {check for a MOD (<=0)}
Clear Bits = 35, {clear multiple bits in set}
Test Variant = 36,
Prim Mul = 37,
Prim Div = 38,
Test Real = 39, {compare real with zero}
Prim Compare = 40,
Real Intpt = 41,
Modulus = 42
{ Avoid "Program too complex" compiler failure }
const integer Dynamic 1 = 43, {single-dimension dynamic array}
Dynamic 2 = 44, {two-dimensional dynamic array}
Psymbol = 45, {printsymbol}
Set Range = 46, {check set ranges}
ReadCh = 47, {readsymbol in prim}
NextCh = 48, {nextsymbol in prim}
Prim Udiv = 49, {unsigned divide}
Set Zero = 50, {test for null set}
Set Equal = 51, {test for set equality}
Real Int = 52, {int(F0) -> R0}
Real Round = 53, {round(F0) -> R0}
CallP = 54, {call proc parameter}
Enter P = 55, {jump to procedure}
Dalloc = 56 {dynamic allocation & unassign}
constinteger Last Prim = 56
owninteger Enter Proc = 0 {filled in on first use}
constintegerarray Corrupts(Signal:Last Prim) =
{FFFF FFFF A RRRR RRRR RRRR RRRR }
{7654 3210 FEDC BA98 7654 3210 }
2_0000 0000 0 0000 0000 0000 0000, { 1:signal}
2_0000 0000 0 0000 0000 0000 0001, { 2:cscomp}
2_0000 0000 0 0001 0001 1111 1111, { 3:Sres}
2_0000 0000 0 0000 0000 0000 0000, { 4:swjump}
2_0000 0000 0 0000 0000 0010 1111, { 5:intexp}
2_0000 0011 0 0000 0000 0000 0001, { 6:realexp}
2_0000 0000 0 0000 1111 1111 1111, { 7:rtraceproc}
2_0000 0000 0 0000 0000 0011 1100, { 8:Sconc}
2_0000 0000 0 0000 0000 0111 1110, { 9:scomp}
2_0000 0000 0 0000 0000 0000 1111, {10:sjam}
2_0000 0000 0 0000 0000 0000 1001, {11:SetIn}
2_0000 0000 0 0000 0000 0000 0000, {12:ResFlop}
2_0000 0000 0 0000 0000 0000 0111, {13:sconc opt}
2_0000 0000 0 0000 0000 0000 1111, {14:MakeLocal}
2_0000 0000 0 0000 0000 0000 0000, {15:aref}
2_0000 0000 0 0000 0000 0000 0000, {16:Dynamic Range}
2_0000 0000 0 0000 1000 1110 1111, {17:dynamic n}
2_0000 0000 0 0000 0000 1000 0111, {18:Frag1}
2_0000 0000 0 0000 0000 0000 0000, {19:rtmonitor}
2_0000 0000 0 0000 0000 0001 1001, {20:set bit}
2_0000 0000 0 0000 0000 0000 0000, {21:captest}
2_0000 0000 0 0000 0000 0000 0000, {22:asstest}
2_0000 0000 0 0000 1111 1111 1111, {23:traceline}
2_0000 0000 0 0000 0000 0100 1101, {24:Frag2}
2_0000 0000 0 0000 0000 0001 1001, {25:Clear bit}
2_0000 0000 0 0000 0000 0000 0000, {26:Test New}
2_0000 0000 0 0000 0000 0000 0000, {27:Nil test}
2_0000 0000 0 0000 0000 0011 1010, {28:Set Bits}
2_0000 0000 0 0000 1001 1111 1111, {29:Set Add}
2_0000 0000 0 0000 1001 1111 1111, {30:Set Sub}
2_0000 0000 0 0000 1001 1111 1111, {31:Set Inter}
2_0000 0000 0 0000 1001 1111 1111, {32:Set GE}
2_0000 0000 0 0000 0000 0000 0000, {33:Check Range}
2_0000 0000 0 0000 0000 0000 0000, {34:test mod}
2_0000 0000 0 0000 0000 0011 1010, {35:Clear Bits}
2_0000 0000 0 0000 0000 0000 0000, {36:Test Variant}
2_0000 0000 0 0000 0000 0000 0011, {37:prim mul}
2_0000 0000 0 0000 0000 0011 1111, {38:prim div}
2_0000 0000 0 0000 0000 0000 0000, {39:test real}
2_0000 0000 0 0000 0000 0001 1111, {40:primcomp}
2_0000 0010 0 0000 0000 0000 0001, {41:intpt}
2_0000 0000 0 0000 0000 0011 1110, {42:modulus}
2_0000 0000 0 0000 0001 1111 1111, {43:dynamic 1}
2_0000 0000 0 0000 0000 1111 1111, {44:dynamic 2}
2_0000 0000 0 0001 1111 1111 1101, {45:Psymbol}
2_0000 0000 0 0000 0000 0011 1000, {46:Set Range}
2_0000 0000 0 0000 0011 1111 1111, {47:ReadCh}
2_0000 0000 0 0000 0011 1111 1111, {48:NextCh}
2_0000 0000 0 0000 0000 0000 1111, {49:prim udiv}
2_0000 0000 0 0000 0001 1111 1110, {50:set zero}
2_0000 0000 0 0000 1001 1111 1111, {51:set equal}
2_0000 0011 0 0000 0000 0000 0001, {52:Real Int}
2_0000 0001 0 0000 0000 0000 0001, {53:Real Round}
2_0000 0000 0 0000 0000 0000 0000, {54:CallP}
2_0000 0000 0 0000 0000 0000 0000, {55:EnterP}
2_0000 0000 0 0001 1000 0001 0000 {56:Dalloc} {004}
constintegerarray Prim Parameter(Signal:Last Prim) =
{FFFF FFFF A RRRR RRRR RRRR RRRR }
{7654 3210 FEDC BA98 7654 3210 }
2_0000 0000 0 0000 0000 0000 0000, { 1:signal}
2_0000 0000 0 0000 0000 0000 0110, { 2:cscomp}
2_0000 0000 0 0001 1111 0001 1110, { 3:Sres}
2_0000 0000 0 0000 0000 0000 0010, { 4:swjump}
2_0000 0000 0 0000 0000 0000 0110, { 5:intexp}
2_0000 0001 0 0000 0000 0000 0001, { 6:realexp}
2_0000 0000 0 0000 0000 0000 0000, { 7:traceproc}
2_0000 0000 0 0000 0000 0000 1100, { 8:Sconc}
2_0000 0000 0 0000 0000 0000 0110, { 9:scomp}
2_0000 0000 0 0000 0000 0000 0111, {10:sjam}
2_0000 0000 0 0000 0000 0000 0110, {11:SetIn}
2_0000 0000 0 0000 0000 0000 0000, {12:ResFlop}
2_0000 0000 0 0000 0000 0000 0111, {13:sconc opt}
2_0000 0000 0 0000 0000 0000 0111, {14:MakeLocal}
2_0000 0000 0 0000 0000 0000 0000, {15:aref}
2_0000 0000 0 0000 0000 0000 1110, {16:Dynamic Range}
2_0000 0000 0 0000 1000 0000 0110, {17:dynamic n}
2_0000 0000 0 0001 0000 1000 0110, {18:Frag1}
2_0000 0000 0 0000 0000 0000 0000, {19:rtmonitor}
2_0000 0000 0 0000 0001 0000 0010, {20:set bit}
2_0000 0000 0 0000 0000 0000 0000, {21:captest}
2_0000 0000 0 0000 0000 0000 0000, {22:asstest}
2_0000 0000 0 0000 0000 0000 0000, {23:traceline}
2_0000 0000 0 0001 0000 0100 1100, {24:Frag2}
2_0000 0000 0 0000 0001 0000 0010, {25:clear bit}
2_0000 0000 0 0000 0000 0000 0000, {26:Test New}
2_0000 0000 0 0000 0000 0000 0010, {27:Nil test}
2_0000 0000 0 0000 0001 0000 0011, {28:Set Bits}
2_0000 0000 0 0000 1001 0000 0000, {29:Set Add}
2_0000 0000 0 0000 1001 0000 0000, {30:Set Sub}
2_0000 0000 0 0000 1001 0000 0000, {31:Set Inter}
2_0000 0000 0 0000 1001 0000 0000, {32:Set GE}
2_0000 0000 0 0000 0000 0000 1010, {33:Check Range}
2_0000 0000 0 0000 0000 0000 0000, {34:test mod}
2_0000 0000 0 0000 0001 0000 0011, {35:Clear Bits}
2_0000 0000 0 0000 0000 0000 1010, {36:Test Variant}
2_0000 0000 0 0000 0000 0000 0011, {37:prim mul}
2_0000 0000 0 0000 0000 0000 0110, {38:prim div}
2_0000 0000 0 0000 0000 0000 0000, {39:test real}
2_0000 0000 0 0000 0000 0000 0111, {40:primcomp}
2_0000 0000 0 0000 0000 0000 0011, {41:intpt}
2_0000 0000 0 0000 0000 0000 0110, {42:prim div}
2_0000 0000 0 0000 0000 0011 1000, {43:dynamic 1}
2_0000 0000 0 0000 0001 1101 1000, {44:dynamic 2}
2_0000 0000 0 0000 0000 0000 0010, {45:Psymbol}
2_0000 0000 0 0000 0000 0000 0111, {46:Set Range}
2_0000 0000 0 0000 0000 0000 0000, {47:ReadCh}
2_0000 0000 0 0000 0000 0000 0000, {48:NextCh}
2_0000 0000 0 0000 0000 0000 0110, {49:prim udiv}
2_0000 0000 0 0000 0000 0000 0001, {50:set zero}
2_0000 0000 0 0000 0000 0000 0011, {51:set equal]
2_0000 0001 0 0000 0000 0000 0001, {52:Real Int}
2_0000 0001 0 0000 0000 0000 0000, {53:Real Round}
2_0000 0000 0 0000 0000 0000 0000, {54:CallP}
2_0000 0000 0 0000 0000 0000 0000, {55:EnterP}
2_0000 0000 0 0000 0000 0001 0000 {56:Dalloc}
{File data}
constinteger Icode = 1
owninteger Last Dir = 0,
Refs = 0, Blocks = 0
{Areas}
constinteger Code Area = 0<<8,
Own Area = 1<<8,
Constant Area = 2<<8,
Own Array Area = 3<<8
{============================================================}
owninteger Own Base = 0, {current own area address}
Min SB = 0, {backward offset into SB}
Own Array Base = 0,
Constant Base = 0, {current constant area address}
Current Area = Code Area, {currently selected area}
Last Area = 0,
External No = 0
constinteger Base Local = 128
ownintegerarray Frame Use(Base Local:Base Local+Max Nesting) = 0(*)
owninteger Fmark = 0
record(Stackfm) Uapat, Zero, One, SpV
record(Stackfm)array RegV(None:AnyF)
record(Varfm)name For Range == Nil {## Nil if check required}
record(Stackfm) C255 = 0; C255_Disp = 255; C255_Type = Integers
constinteger No Danger = 16_7FFF {>> than 128+depth}
owninteger Jamit= 0, Entry Point = -1,
Danger Level = No Danger {limit of normal globals}
string(127) Include File = ""
integer Dtype {for remembering disag type on arrays}
recordformat Qfm(integer Type, Size, Round, Bias, Dim, Format,
Diags, Dtype, Dform, Ind,
record(Qfm)name Pointed)
recordformat Diag Fm(record(Diagfm)name Link,
record(Varfm)name Var,
integer X, Xtype,
Format,
Ext,
string(127) Id) {003}
constrecord(Diagfm)name Diagfm Type == 0
record(Diagfm)name Diag List == Nil
constinteger Display Limit = 128+17
ownshortarray Display Vector(128:Display Limit) = 0(*)
owninteger Cp = 0
bytearray Code Buffer(0:255)
recordformat Vvfm(record(Vvfm)name Link, record(Varfm)array V(0:63))
constrecord(Vvfm)name VvfmType == 0
record(Vvfm)name Var List == NIL
recordformat Pvfm(record(Vvfm)name P)
record(Pvfm)array Pvar(0:Var Top)
record(Varfm)map Var(integer A)
record(Vvfm)name V
record(Pvfm)name X
X == Pvar(A>>6)
if X_P == Nil start
V == NEW(VvfmType)
V_Link == Var List; Var List == V
X_P == V
finish
result == X_P_V(A&63)
end
routine Flush Code
integer J
return if Cp = 0
Printsymbol(Dir Dump)
Dump Encoded(Cp)
Printsymbol(Code Buffer(J)) for J = 1, 1, Cp
Cp = 0
end
routine Assemble(record(Varfm)name Avar,
integer Amode, Vars, Local, Parameter List,
integername Global Attributes)
{Amode = -16 - Initial call }
{ -2 - Alternate format start}
{ -1 - Recordformat }
{ 0 - Procedure }
{ >0 - Procedure spec }
routinespec Not in Yet
routinespec Fail(string(63) Why)
routinespec Warn(integer Fault, string(63) What)
routinespec Display(record(Stackfm)name V, integer Bias)
routinespec Monitor(record(Stackfm)name V, string(127) Text)
predicatespec Iconst(record(Stackfm)name V)
predicatespec Iconst Item(record(Stackfm)name V)
predicatespec Const(record(Stackfm)name V)
predicatespec Same(record(Stackfm)name A, B)
predicatespec InReg(record(Stackfm)name V)
predicatespec Floating(record(Stackfm)name V)
integerfnspec Power(integer N)
integerfnspec Item Size(integer T)
record(Stackfm)mapspec Register(integer R)
routinespec Claim(integer Register)
routinespec Release(integer Register)
routinespec Release and Drop(record(Stackfm)name V)
routinespec Zap Index and Record(record(Stackfm)name V)
routinespec Release and Drop Pair(record(Stackfm)name A, B)
routinespec Hazard(integer Register)
routinespec Pessimise(record(Stackfm)name V)
routinespec Forget(integer Register)
routinespec Forget Destination(record(Stackfm)name V)
routinespec Forget Everything
routinespec Remember(integer Register, record(Stackfm)name V)
routinespec Remember Zero(integer Register)
routinespec Optimise(record(Stackfm)name V, integer Mode)
routinespec Simplify(record(Stackfm)name V)
routinespec Amap(record(Stackfm)name V)
routinespec Vmap(record(Stackfm)name V, integer Type)
routinespec Make AutoI(record(Stackfm)name V, integer Type)
routinespec Advance(record(Stackfm)name V, integer Type, By)
routinespec Load(record(Stackfm)name V, integer Register)
routinespec Loadup(record(Stackfm)name V)
routinespec Load Address(record(Stackfm)name V, integer R)
routinespec Loadup Address(record(Stackfm)name V)
routinespec Load Pair(record(Stackfm)name A, integer Ar,
record(Stackfm)name B, integer Br)
routinespec Load Trio(record(Stackfm)name A, integer Ar,
record(Stackfm)name B, integer Br,
record(Stackfm)name C, integer Cr)
routinespec Pop Stack(integer Bytes)
routinespec Load Protected(record(Stackfm)name V)
routinespec Move(record(Stackfm)name From, To)
routinespec Move Literal(integer Lit, record(Stackfm)name V)
routinespec Store(record(Stackfm)name From, To)
routinespec Store Address(record(Stackfm)name From, To,
integername Extra)
routinespec Operate(integer Op, record(Stackfm)name L, R)
routinespec Compare(record(Stackfm)name L, R)
integerfnspec New Label
routinespec Jump To(integer Internal Label, Cond Code)
routinespec Define Label(integer Internal Label)
routinespec Test Zero(record(Stackfm)name V)
routinespec Test Range(record(Stackfm)name V,
record(Varfm)name R)
routinespec Clear Vars(integer Limit)
routinespec DIR String(integer Op, string(*)name S)
routinespec Float(record(Stackfm)name V, integer R)
routinespec Dump External(integer C, record(Varfm)name V)
routinespec Do(string(31) Ident, integername Ep, integer Result)
integerfnspec GPR
integerfnspec FPR
integerfnspec Select Best(record(Stackfm)name From, To, integer D)
record(Stackfm)mapspec Descriptor
record(Stackfm)mapspec Temporary
routinespec Drop(record(Stackfm)name V)
record(Stackfm)mapspec Local Integer(integer Disp)
record(Stackfm)mapspec Literal(integer N)
record(Stackfm)mapspec Copy(record(Stackfm)name V)
integerfnspec Tag
integerfnspec Four Bytes
routinespec Prim(integer N)
routinespec Dump Text(integer Max)
routinespec Pass Parameters(record(Stackfm)name V,
integername X, integer BaseReg)
routinespec Assign(integer How)
routinespec String Assign(record(Stackfm)name From, To)
routinespec Set Assign(record(Stackfm)name From, To)
routinespec Evaluate String Expression(record(Stackfm)name V)
routinespec Record Assign(record(Stackfm)name From, To)
record(Stackfm)mapspec Claim Work Area(integer Size, Type)
routinespec Flush Diags
routinespec Convert Format(record(Stackfm)name V, integer Type)
routinespec To Short Real(record(Stackfm)name V)
routinespec Store Real Constant(record(Stackfm)name W)
routinespec Build Set(record(Stackfm)name S)
routinespec Drop Members(record(Stackfm)name S)
owninteger Frame = 0,
Round = 0
integer Aframe = 0, {array extension to frame}
Parameter Frame = 0,
Parameter Regs = 0,
String Result = 0
integer Block Type = 0,
Code Base = 0,
Uncond Jump = -1,
D,
N,
Parameter Mode,
VarBase = Vars,
First Alt = Parms-1,
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 Assign Lock = 1 {#0 to permit marking assigned permanently}
integer Attributes = 0,
At = 0,
Entry Mask = 0,
MyMark,
Open = Closed, {assume cannot return}
Event Label = 0,
Event Body = 0,
Event Bits = 0,
Wsp Save = 0, {frame address of where SP is saved}
Danger Marker = 0, {=1 if the block is dangerous}
Local Display = 0, {#0 if in a dangerous block}
Jlab,
Array Base = 0 {#0 if allocated}
integer Work Base = Last Work
integername Ca == Code Base {current Address}
string(127) Proc Id = Internal Id {003}
record(Withfm)name Withs == Nil
conststring(255) Monitor Id = "3L___monitor"
owninteger Monitor Ep = 0
routine Decode(integer Word, At)
externalroutinespec D alias "DECODE_ARM"(integer W, A)
Select Output(Report)
D(Word, At)
Select Output(Directives Out)
end
record(Stackfm)map Display Info(integer Base)
integer N
record(Stackfm)name T
if Base < Danger Level start {the safe case}
Frame Use(Base) = 0 {show the level used}
N = Display Vector(Base)
if N = 0 start
Min SB = Min SB-4; N = Min SB
Display Vector(Base) = N
finish
T == Literal(N)
T_Form = Direct
T_Base = Sb
else {the dangerous case - p-params}
T == Local Integer(Local Display+4*(Base-Danger Level))
finish
Attributes = Attributes!Attr Needs Display ! Attr Needs Gp
T_Flags = T_Flags!Known Ass
result == T
end
routine BD(integer Base, Disp)
Write(Disp, 1)
Printsymbol('(')
if None <= Base <= AnyF start
Printstring(Regid(Base))
else
if Base >= Base Local start
if Base = Local start
Printstring("Fp")
else
Printsymbol('L')
Base = Base-Base Local-1
Write(Base, 0)
finish
else
Write(Base, 0)
finish
finish
Printsymbol(')')
end
routine Show(integer N, string(15) Text)
if N # 0 start
Space; Printstring(Text)
Write(n, 1)
finish
end
routine Show Data(record(Stackfm)name V, integer Left)
Spaces(Left); Printstring(Typeid(V_Type))
Space; Printstring(Formid(V_Form))
BD(V_Base, V_Disp)
Show(V_Format, "Fm:")
Show(V_Area, "A:")
Show(V_Flags, "Fl:")
PrintSymbol('R') if V_Flags&By Ref # 0
PrintSymbol('A') if V_Flags&Array # 0
PrintSymbol('N') if V_Flags&Arrayname # 0
PrintSymbol('P') if V_Flags&Parameter # 0
PrintSymbol('D') if V_Flags&Defered # 0
PrintSymbol('W') if V_Flags&Awanted # 0
PrintSymbol('S') if V_Flags&Static # 0
PrintSymbol('=') if V_Flags&Known Ass # 0
Printsymbol('H') if V_Flags&Hazarded # 0
Printsymbol('X') if V_Flags&Xproc Spec # 0
Printsymbol('n') if V_Flags&Nasty Proc # 0
Printsymbol('C') if V_Flags&Checkable # 0
PrintSymbol('#') and Write(V_Varno, 0) if V_Varno # 0
if V_Record ## Nil start
Newline
Spaces(Left); Printstring(" _:")
Display(V_Record, Left+4)
finish
if V_Index ## Nil start
Newline
Write(V_Xsize, Left+2); Printstring("i:")
Display(V_Index, Left+4)
finish
end
routine Display(record(Stackfm)name V, integer Bias)
if V == Nil start
Printstring(" Nil"); Newline
return
finish
Show Data(V, Bias)
newline
if V_Oper # 0 start
Spaces(Bias-4); Printstring(Operid(V_Oper))
Display(V_Link, Bias+4)
finish
end
routine Show Reg(integer R)
integer A
A = Activity(R)
Printstring(Regid(R))
if A = 0 start
Printstring(" unused")
else if A < 0
if A = -1 start
Printstring(" locked")
else
Printstring(" ="); Printstring(Regid(-A)); Spaces(2)
finish
else
Printstring(" used*"); Write(A, -1)
finish
Printstring(" u:"); Print Hex(Used(R), 5)
Printstring(" k:"); Write(Ktimes(R), 0)
Newline
end
routine Monitor N(integer N, string(255) Text)
Select Output(Report)
Printstring(Text)
Write(N, 8)
Newline
Select Output(Directives Out)
end
routine Monitor Register(integer R, string(127) Text)
Select Output(Report)
Printstring(Text); Spaces(9-length(Text)); Space
Show Reg(R)
Select Output(Directives Out)
end
routine Monitor(record(Stackfm)name V, string(127) Text)
Select Output(Report)
Printstring(Text); Spaces(9-length(Text)); Space
Display(V, 6)
Select Output(Directives Out)
end
routine Mon Regid(integer R, string(127) Text)
Select Output(Report)
Printstring(Regid(R)); Space
Printstring(Text)
Newline
Select Output(Directives Out)
end
routine Display Knowledge
record(Knowfm)name K
Select Output(Report)
K == Knowing
while K ## Nil cycle
Printstring(Regid(K_Reg)); Printstring(" = ")
Printstring(Typeid(K_Ftype>>4)); Space
Printstring(Formid(K_Ftype&15)); Space
BD(K_Base, K_Disp)
if K_Extra # 0 start
Printstring(" X:"); Write(K_Extra, 1)
finish
if K_Area # 0 start
Printstring(" A:"); Write(K_Area, 1)
finish
if K_Oper # 0 start
Space; Printstring(OperId(K_Oper))
Write(K_Opnd, 1)
finish
Newline
K == K_Link
repeat
Select Output(Directives Out)
end
routine Show Where
Select Output(Report)
Printstring(" at line "); Write(Current Line, 0)
Printstring(" in file ".Include File) if Include File # ""
newline
end
routine Fail(string(63) Why)
routine Pcode(integer S)
if S >= 128 start
Printstring("128+")
S = S-128
finish
if ' ' <= S <= 126 start
Printsymbol(''''); Printsymbol(S); Printsymbol('''')
finish
write(S, 3)
end
routine Err(integer Stream)
integer R
record(Stackfm)name U, S
Select Output(Stream)
Newline
Printstring("====> Pass 2 fails -- "); Printstring(Why)
Show Where
Printstring("Code "); Pcode(Code)
Printstring(" Pending "); Pcode(Pending)
Newline
for R = R0, 1, R15 cycle
Show Reg(R) unless Activity(R) <= 0
repeat
S == Stack
while S ## Nil cycle
Printstring("S:"); Display(S, 5)
S == S_Stack
repeat
U == Using
while U ## Nil cycle
Printstring("U:"); Display(U, 5)
U == U_Using
repeat
Newline
monitor
end
Err(Report) {terminal}
Err(Listing) {listing}
stop
end
routine Warn(integer Fault, string(63) What)
Select Output(Report)
Interface_Faults = Interface_Faults+Fault
if Fault = 0 then Printstring("Warning: ") c
else Printstring("*Error: ")
Printstring(What)
Show Where
Select Output(Directives Out)
end
routine Not in Yet
Fail("***Not implemented yet***")
end
routine Dir1(integer Code)
Flush Code
Printsymbol(Code)
Pending Auto = 0
end
routine Dir2(integer Code, Arg1)
Flush Code
Printsymbol(Code)
Dump Encoded(Arg1)
Pending Auto = 0 unless Code = Dir Line
end
routine Dir3(integer Code, Arg1, Arg2)
Flush Code
Printsymbol(Code)
Dump Encoded(Arg1)
Dump Encoded(Arg2)
Pending Auto = 0
end
routine Dir4(integer Code, Arg1, Arg2, Arg3)
Flush Code
Printsymbol(Code)
Dump Encoded(Arg1)
Dump Encoded(Arg2)
Dump Encoded(Arg3)
Pending Auto = 0
end
record(Workfm)map Work Area(integer N)
record(WorkVfm)name W
integer E, S, X
on * start
E = Event_Event; S = Event_Sub; X = 0; ! Event_Extra not supported in bootstrapping compiler
Fail("too many work areas:".itos(E, 0))
finish
Monitor N(N, "work area") if Diag&MonOperand # 0
W == Work List
while N > 30 cycle
N = N-30
if W_Link == NIL start
W_Link == NEW(WorkVfmType)
W_Link = 0
finish
W == W_Link
repeat
result == W_W(N)
end
record(Labelfm)map Ilabel(integer N)
integer X, J
record(Ilabelfm)name I
record(Labelfm)name L
Fail("internal label/1") if N > Max Label
X = N>>8
!0.9! I == Ilabels(X)
{0.9} I == Ilabels(X)_Label
if I == NIL start
I == New(Ilabelfm Type)
!0.9! Ilabels(X) == I
{0.9} Ilabels(X)_Label == I
I_Link == Ilabel List; Ilabel List == I
for J = 0, 1, 255 cycle
L == I_Lab(J)
L_Lab = Defined
L_Env == NIL
repeat
finish
result == I_Lab(N&255)
end
routine Select Area(integer Area Id, integername Base)
Dir3(Dir Area, Area Id>>8, Base)
Current Area = Area Id
Ca == Base
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 Select Own Array Area
Select Area(Own Array Area, Own Array Base)
end
include "plant.inc"
include "load.inc"
include "repeat.inc"
integerfn Cheapest(integer Low, High)
integer R, A, U
integer Min Activity,
Min Known,
Min Reg, {default to R3 or F3}
Oldest
Min Activity = 1000
Min Known = 1000
Min Reg = 0
Used Time = Used Time+1
Oldest = Used Time
for R = Low, 1, High cycle
A = Activity(R); continue if A < 0 {locked}
U = Used(R)
if A = Min Activity start
if Min Known > Ktimes(R) start
Min Reg = R
Min Known = Ktimes(R)
Oldest = U
else if Min Known = Ktimes(R)
if Oldest > U start {choose the oldest}
Min Reg = R
Oldest = U
finish
finish
else if A < Min Activity
Min Activity = A
Min Reg = R
Min Known = Ktimes(R)
Oldest = U
finish
repeat
Fail("all registers lost") if Min Reg = 0
Used(Min Reg) = Used Time
Hazard(Min Reg) unless Min Activity = 0
result = Min Reg
end
integerfn GPR
result = Cheapest(R0, R8)
end
integerfn FPR
result = Cheapest(F0, F7)
end
record(Stackfm)map Register(integer Reg)
record(Stackfm)name R
R == Descriptor
if Reg = Any start
R_Type = Integers
Reg = Cheapest(R0, R8)
else if Reg = AnyF
R_Type = Lreals
Reg = Cheapest(F0, F7)
else
R_Type = Integers
R_Type = Lreals if Reg >= F0
finish
R_Base = Reg; Claim(Reg)
result == R
end
predicate Locked(integer R)
true if R >= 128 or R = 0 or Activity(R) < 0
false
end
predicate Properly Aligned(record(Stackfm)name V, integer Mask)
true if V_Type = Sets
if V_Type = Records start
false if V_Format >= 0
true if Var(-V_Format)_Disp = 3 {format needs word alignment}
finish
false unless Locked(V_Base)
true if V_Form = Direct c
and V_Record == Nil c
and V_Index == Nil c
and V_Disp&Mask = 0
false
end
include "simplify.inc"
routine Apply Index(record(Stackfm)name V, X, integer Xsize)
integer N, MulOp
if Iconst(X) and V_Form = Direct start {fold it in}
N = V_Disp+X_Disp*Xsize
V_Disp = N
Drop(X)
return
finish
if V_Index == Nil start {no index, just add the new one}
V_Index == X; V_Xsize = Xsize
else if V_Xsize = Xsize {equal scaling}
Operate(ADDx, V_Index, X) {add in the new bit}
else {different scaling}
MulOp = MULx
Operate(MulOp, V_Index, Literal(V_Xsize)) unless V_Xsize = 1
Operate(MulOp, X, Literal(Xsize)) unless Xsize = 1
Operate(ADDx, V_Index, X)
V_Xsize = 1
finish
end
routine Fix Unitary String(record(Stackfm)name V)
integer Len, Val, At
owninteger Null Address = -1
integerfn Locate(integer Len, Char)
integer Here
Constant Base = (Constant Base+3)&(¬3)
Here = Constant Base
Select Constant Area
Dump Byte(Len); Dump Byte(Char) if Len # 0
Select Code Area
result = Here
end
if V_Type = Strings and V_Bias = 1 start {""}
Null Address = Locate(0, 0) if Null Address < 0
At = Null Address
Len = 1
else if V_Type = Sets
Build Set(V); return
else if V_Type <= Addrs
Val = V_Disp&255
Warn(1, "string character out of range") if Val # V_Disp
At = Locate(1, Val)
Len = 2
else
Fail("bad tostring type")
finish
V_Disp = At; V_Type = Strings; V_Form = Direct
V_Area = Constant Area; V_Format = Len; V_Bias = Len
end
routine Amap(record(Stackfm)name V)
record(Stackfm)name W
if V_Form = Address start
Fix Unitary String(V)
else if V_Oper # 0
Fail("Amap:oper")
finish
V_Type = Integers {all addresses are integers}
return if V_Form = AutoD {special for the stack}
if V_Form = Proc start
if V_Flags&Xproc Spec # 0 start {case 1 - an external}
Hazard(R13); Forget(R13)
Dir2(Dir xThunk, V_Disp) { load @vector into R13}
Refs = Refs+1; Ca = Ca+4
V_Type = Integers; V_Form = Address
V_Base = R13; V_Disp = 0; V_Area = 0
Claim(R13)
else if V_Flags&Parameter # 0 {case 2 - already a parameter}
V_Type = Integers; V_Form = Direct; V_Area = 0
else if V_Flags&XprocDef # 0 {case 3 - simplified}
Hazard(R13); Forget(R13)
Dir2(Dir Thunk, V_Disp) { load @vector into R13}
Refs = Refs+1; Ca = Ca+4
V_Type = Integers; V_Form = Address
V_Base = R13; V_Disp = 0; V_Area = 0
Claim(R13)
else {cases 3 & 4}
Fail("cannot address local procedures")
finish
else
Fail("Amap:form") unless V_Form = Direct
V_Form = Address
if V_Index ## Nil and Iconst(V_Index) start
V_Disp = V_Disp+V_Index_Disp*V_Xsize
Drop(V_Index); V_Index == Nil
finish
if V_Disp = 0 and V_Index == Nil and V_Record ## Nil start
{convert addr 0(X) into X}
W == V_Record
V_Data = W_Data
W_Index == Nil; W_Record == Nil; Drop(W)
finish
finish
Monitor(V, "Amap<-") if Diag&MonOperate # 0
end
routine Make AutoI(record(Stackfm)name V, integer Type)
Amap(V) {get its address}
Load Protected(V) {to a safe register}
V_Type = Type; V_Form = AutoI
end
routine Vmap(record(Stackfm)name V, integer New Type)
record(Stackfm)name W, C
integer D = 0
Fail("Vmap:type") unless Integers <= V_Type <= Addrs
if V_Oper = ADDx start
C == V_Link
if Iconst(C) start
D = C_Disp
Drop(C); V_Link == NIL; V_Oper = 0
finish
finish
Loadup(V) if V_Oper # 0 {PSR}
if V_Form # Address start
W == Descriptor; W_Data = V_Data
V_Data = 0
V_Record == W
V_Disp = D
finish
V_Type = Internal Type(New Type); V_Form = Direct
V_Format = Type Fmt(New Type)
Monitor(V, "Vmap<-") if Diag&MonOperate # 0
end
routine Fmap(integer NewType)
Hazard(Stack_Base) if InReg(Stack)
Fail("Bad type for Fmap") unless Stack_Type = Integers c
and Stack_Form # Address
Stack_Form = Proc
Stack_Type = NewType
Stack_Flags = Stack_Flags ! Answer ! Parameter
end
routine Advance(record(Stackfm)name V, integer Type, By)
integer Check Flag
if V_Form # AutoD start
Check Flag = V_Flags&Checkable
Amap(V)
Operate(ADDx, V, Literal(By))
Vmap(V, Type)
V_Flags = V_Flags ! Check Flag
else
V_Type = Type
finish
end
!!%include "mtables.inc" {moved outside of mcode.inc because of "context" error}
!!%include "mcode.inc"
{ I need to move the above include in-line to avoid a "* 2755 dictionary full" error}
!##########################################################################
routine Machine Code
!%include "mtables.inc" { moved outside of Machine Code because of "context" error}
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
constinteger Max Opcode = 95
conststring(4)array Opcode(1:Max Opcode) =
"ABS", "ACS", "ADC", "ADD", "ADF",
"AND", "ASN", "ATN", "B", "BAL",
"BCC", "BCS", "BEQ", "BGE", "BGT",
"BHI", "BIC", "BL", "BLAL", "BLCC",
"BLCS", "BLE", "BLEQ", "BLGE", "BLGT",
"BLHI", "BLLE", "BLLS", "BLLT", "BLMI",
"BLNE", "BLNV", "BLPL", "BLS", "BLT",
"BLVC", "BLVS", "BMI", "BNE", "BNV",
"BPL", "BR", "BVC", "BVS", "CMF",
"CMFE", "CMN", "CMP", "CNF", "CNFE",
"COS", "DVF", "EOR", "EXP", "FDV",
"FIX", "FLT", "FML", "FRD", "LDF",
"LDM", "LDR", "LGN", "LOG", "MNF",
"MOV", "MUF", "MVF", "MVN", "ORR",
"POL", "POW", "RDF", "RFC", "RFS",
"RMF", "RND", "RPW", "RSB", "RSC",
"RSF", "SBC", "SIN", "SQT", "STF",
"STM", "STR", "SUB", "SUF", "SWI",
"TAN", "TEQ", "TST", "WFC", "WFS"
constbytearray Type(1:Max Opcode) =
10, 10, 1, 1, 10,
1, 10, 10, 5, 5,
5, 5, 5, 5, 5,
5, 1, 5, 5, 5,
5, 5, 5, 5, 5,
5, 5, 5, 5, 5,
5, 5, 5, 5, 5,
5, 5, 5, 5, 5,
5, 5, 5, 5, 9,
9, 1, 1, 9, 9,
10, 10, 1, 10, 10,
7, 7, 10, 10, 6,
4, 2, 10, 10, 10,
1, 10, 10, 1, 1,
10, 10, 10, 7, 7,
10, 10, 10, 1, 1,
10, 1, 10, 10, 6,
4, 2, 1, 10, 3,
10, 1, 1, 7, 7
constintegerarray Value(1:Max Opcode) =
16_0E208100,16_0EC08100,16_00A00000,16_00800000,16_0E000100,16_00000000,
16_0EB08100,16_0ED08100,16_EA000000,16_EA000000,16_3A000000,16_2A000000,
16_0A000000,16_AA000000,16_CA000000,16_8A000000,16_01C00000,16_EB000000,
16_EB000000,16_3B000000,16_2B000000,16_DA000000,16_0B000000,16_AB000000,
16_CB000000,16_8B000000,16_DB000000,16_9B000000,16_BB000000,16_4B000000,
16_1B000000,16_FB000000,16_5B000000,16_9A000000,16_BA000000,16_7B000000,
16_6B000000,16_4A000000,16_1A000000,16_FA000000,16_5A000000,16_EA000000,
16_7A000000,16_6A000000,16_0E90F110,16_0ED0F110,16_01600000,16_01400000,
16_0EB0F110,16_0EF0F110,16_0E908100,16_0E400100,16_00200000,16_0E708100,
16_0EA00100,16_0E100110,16_0E000110,16_0E900100,16_0EB00100,16_0C100100,
16_08100000,16_04100000,16_0E608100,16_0E508100,16_0E108100,16_01A00000,
16_0E100100,16_0E008100,16_01E00000,16_01800000,16_0EC00100,16_0E600100,
16_0E500100,16_0E500110,16_0E300110,16_0E800100,16_0E308100,16_0E700100,
16_00600000,16_00E00000,16_0E300100,16_00C00000,16_0E808100,16_0E408100,
16_0C000100,16_08000000,16_04000000,16_00400000,16_0E200100,16_0F000000,
16_0EA08100,16_01200000,16_01000000,16_0E400110,16_0E200110
!%endoffile
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
integer Op Num, Op Type, Op Value=0, Op Length
integer Operands, N, J, Key, P, X = 0, SymP, Disp
integer Rn, Rd, Rs, Rm, Sh, Rot, Ud, Reg1, Reg2
integer Fdst, Fs1, Fs2
string(7) Op String
record(Varfm)name W
switch Ot(-1:10)
routine Mc Error(string(127) Text)
routine Err(integer Stream)
Select Output(Stream)
Printstring("*"); Write(Current Line, 4)
Printstring(" ".Op String.": ".Text)
Newline
end
Err(Listing) {listing}
Err(Report) {terminal}
Fail("Bang") if Diag&Mon Bang # 0
Interface_Faults = Interface_Faults+1
Select Output(Directives Out)
signal 14
end
routine Find Opcode
integer Min, Max, P
string(4) Key
Key = "0" { this was a bare 0 - was that some new automatic type casting??? }
{ it gets immediately overwritten so WTF??? }
Op Length = Length(Op String)
if Op Length <= 3 start
SymP = Op Length
Key = Op String
else
SymP = 3
{ many 'tostring' calls added as that definitely was automatic type casting }
Key = tostring(Charno(Op String, 1)).tostring(Charno(Op String, 2)).tostring(Charno(Op String, 3))
if Charno(Op String, 1) = 'B' and Charno(Op String, 2) = 'L' c
and Op Length >= 4 start
Key = Key.tostring(Charno(Op String, 4))
SymP = 4
finish
finish
Min = 1; Max = Max Opcode
while Min <= Max cycle
P =(Min+Max)>>1
if Opcode(P) = Key start
Op Num = P; Op Type = Type(Op Num); Op Value = Value(Op Num)
return
finish
if Key > Opcode(P) then Min = P+1 else Max = P-1
repeat
if Op String = "BYTE" or Op String = "BYTE1" start
Op Num = -1; Op Type = -1; SymP = OpLength
else if Op String = "BYTE2"
Op Num = -2; Op Type = -1; SymP = OpLength
else if Op String = "BYTE4"
Op Num = -3; Op Type = -1; SymP = OpLength
finish else Mc Error("unknown opcode")
end
predicate Match(integer Wanted)
false unless Pending = Wanted
Readsymbol(Pending)
true
end
predicate PMatch(integer Wanted)
false unless Pending = Wanted ! 128
Readsymbol(Pending)
true
end
predicate Literal(integername N)
if Match('N') start
N = Four Bytes
true
finish
if Match(128+'b') start
N = Pending; Readsymbol(Pending)
true
finish
false unless Match('-')
Mc Error("constant expected") unless Literal(N)
N = -N
true
end
routine Want(integer Sym)
Mc Error(Tostring(Sym)." expected") unless Match(Sym)
end
routine Want Literal(integername N)
Mc Error("constant expected") unless Literal(N)
end
routine Register(integername R)
Mc Error("Register expected") unless Literal(R) and 0 <= R <= 15
end
routine F Register(integername R)
Mc Error("Floating register expected") unless Literal(R) c
and 16+0 <= R <= 16+7
end
routine Set CC
constintegerarray CC(0:15) =
'E'<<8 ! 'Q', 'N'<<8 ! 'E', 'C'<<8 ! 'S', 'C'<<8 ! 'C',
'M'<<8 ! 'I', 'P'<<8 ! 'L', 'V'<<8 ! 'S', 'V'<<8 ! 'C',
'H'<<8 ! 'I', 'L'<<8 ! 'S', 'G'<<8 ! 'E', 'L'<<8 ! 'T',
'G'<<8 ! 'T', 'L'<<8 ! 'E', 'A'<<8 ! 'L', 'N'<<8 ! 'V'
integer Sym, C
if SymP+1 < Op Length start
Sym = Charno(Op String, SymP+1)<<8 ! Charno(Op String, SymP+2)
for C = 0, 1, 15 cycle
if CC(C) = Sym start
Op Value = Op Value ! C<<28
SymP = SymP+2
return
finish
repeat
finish
Op Value = Op Value ! 16_E000 0000 {default to always}
end
routine Comma
Mc Error("comma missing") unless Match(',')
end
predicate Omatch(integer Sym)
false unless SymP < Op Length and Charno(Op String, SymP+1) = Sym
SymP = SymP+1
true
end
on 14 start
Readsymbol(Pending) while Pending # ';'
else
Op String = ""
while Pending # '_' cycle
Op String = Op String.Tostring(Pending) if Length(Op String) # 7
Readsymbol(Pending)
repeat
Readsymbol(Pending)
Find Opcode
Set CC if Op Type > 0 {funnies} and Op Type # 5 {branch}
->Ot(Op Type)
{data processing}
constbytearray Litsh(1:4) = 2_100 0000, 2_000 0000,
2_010 0000, 2_110 0000
constbytearray Regsh(1:4) = 2_101 0000, 2_001 0000,
2_011 0000, 2_111 0000
routine Bad Shift
Mc Error("unknown type of shift")
end
routine Get Shift
integer Sh
if PMatch('A') start
if PMatch('S') and PMatch('R') start
Sh = 1
else
Bad Shift
finish
else if PMatch('L')
if PMatch('S') start
if PMatch('L') start
Sh = 2
else if PMatch('R')
Sh = 3
else
Bad Shift
finish
else
Bad Shift
finish
else if PMatch('R')
if PMatch('R') start
Bad Shift unless PMatch('X')
Sh = 0
else if PMatch('O') and PMatch('R')
Sh = 4
else
Bad Shift
finish
else
Bad Shift
finish
if Sh = 0 start
Op Value = Op Value ! 2_00000 110 <<4 {RRX}
else if Match('#')
Want Literal(N)
Mc Error("shift out of range") unless 0 <= N <= 32
Op Value = Op Value ! (N&31)<<7 ! litsh(Sh)
else
Register(Rs)
Op Value = Op Value ! Rs<<8 ! regsh(Sh)
finish
end
Ot(1):Key = Op Value>>23&3
N = Op Value>>21&15
Rn = 0; Rd = 0; Rm = 0; Rs = 0
if Omatch('S') start
Op Value = Op Value ! 1<<20
finish
if Omatch('P') start
Warn(1, "spurious P qualifier") unless Key = 2_10
Rd = 15
finish
Register(Rn)
if Key # 2_10 start
Rd = Rn; Rn = 0
if N # 13 and N # 15 start
Comma
Register(Rn)
finish
finish
Op Value = Op Value ! Rd<<12 ! Rn<<16
Comma
if Match('#') start
Want Literal(N)
Rot = 16
if N # 0 start
Rot = Rot-1 and N = N>>2 while N&3 = 0
finish
Mc Error("cannot generate constant") if N>>8 # 0
Op Value = Op Value ! (Rot&15)<<8 ! N ! 16_0200 0000
else
Register(Rm)
Get Shift if Match(',')
Op Value = Op Value ! Rm
finish
->OK
routine Get Displacement(integer Mode)
integer Rm
Ud = 1
if Match('#') start
Want Literal(Disp)
Ud = 0 and Disp = -Disp if Disp < 0
else
Disp = 0
if Match('-') start
Ud = 0
else if Match('+')
finish
Register(Rm)
Op Value = Op Value ! Rm ! 16_0200 0000
Get Shift if Match(',')
finish
Op Value = Op Value ! Mode
end
routine Modify Disp
integer Sign, Mod
Sign = Pending
return unless Match('+') or Match('-')
Mc Error("constant expected") unless Literal(Mod)
Mod = -Mod if Sign = '-'
N = N+Mod
end
Ot(2):if Omatch('B') start
Op Value = Op Value ! 1<<22 {byte value}
finish
if Omatch('T') start
Op Value = Op Value ! 1<<21 {translate bit}
finish
Register(Rd)
Op Value = Op Value ! Rd<<12
Comma
Ud = 1
if Match(' ') start {a defined object}
W == Var(Tag)
Disp = W_Disp
Modify Disp
if W_Base = Local start
Rn = Actual(Fp)
else if W_Base = SB
Rn = Actual(Sb)
else if W_Base = 0 and W_Area < 0
Dir3(Dir Spec Load, Rd, -W_Area)
Refs = Refs+1; Ca = Ca+4
Rn = Rd
Disp = 0
finish else Mc Error("cannot address non-locals")
Disp = -Disp and Ud = 0 if Disp < 0
Op Value = Op Value ! 16_0500 0000 ! Rn<<16
else
Want('[')
Register(Rn)
Op Value = Op Value ! Rn<<16
if Match(',') start { [Rn, D] }
Warn(1, "spurious translate option") if Op Value&(1<<21) # 0
Get Displacement(16_0500 0000)
Want(']')
Op Value = Op Value ! 1<<21 if Match('!')
else
Want(']')
if Match(',') start { [Rn], D }
Get Displacement(16_0400 0000)
else { [Rn] }
Disp = 0
Op Value = Op Value ! 16_0400 0000
finish
finish
finish
Mc Error("displacement too large") if Disp > 4095
Op Value = Op Value ! Ud<<23 ! Disp
->OK
{Trap}
Ot(3):Want Literal(N); Op Value = Op Value ! N&16_00FF FFFF; ->OK
{Block data manipulation}
routine Rlist
Want('<')
unless Pending = '>' start
cycle
Register(N)
Op Value = Op Value ! 1<<N
repeat until not Match(',')
finish
Want('>')
end
Ot(4):if Omatch('I') start
if Omatch('A') start
Op Value = Op Value ! 2_01<<23
else if Omatch('B')
Op Value = Op Value ! 2_11<<23
else
Mc Error("IA or IB expected")
finish
else if Omatch('D')
if Omatch('A') start
Op Value = Op Value ! 2_00<<23
else if Omatch('B')
Op Value = Op Value ! 2_10<<23
else
Mc Error("DA or DB expected")
finish
else
if Omatch('F') start
Op Value = Op Value ! 2_10<<23
else if Omatch('E')
Op Value = Op Value ! 2_00<<23
finish
if Omatch('A') start
Op Value = Op Value ! 2_01<<23
else if Omatch('D')
Op Value = Op Value ! 2_00<<23
finish
finish
Register(Rn)
Op Value = Op Value ! Rn<<16
Op Value = Op Value ! 1<<21 if Match('!') {writeback}
Comma
Rlist
Op Value = Op Value ! 1<<22 if Match('^') {set PSR}
->OK
Ot(5):if Match(' ') start {a defined object}
W == Var(Tag)
if W_Type = Labels start
Dir3(Dir McLabel, W_Disp, Op Value)
Ca = Ca+4
->Done
finish
finish
Mc Error("Unimplemented form of branch")
routine Set DS(integer Let P)
if Omatch('D') start
Op Value = Op Value ! 16_0000 0080
else if Omatch('E')
Op Value = Op Value ! 16_0008 0000
else if Let P # 0 and Omatch('P')
Op Value = Op Value ! 16_0008 0080
else unless Omatch('S')
McError("D, S, E or P wanted")
finish
end
routine Lit Reg(integername R)
if Match('#') start
Want Literal(R)
if R = 1 and Match('/') start
Want Literal(R)
McError("only 1/2 permitted") if R # 2
R = 6
else
McError("bad range") unless 0 <= R <= 5 or R = 10
R = 7 if R = 10
finish
R = R ! 8
else
F Register(R); R = R&7
finish
end
Ot(6): if Omatch('S') start
else if Omatch('D')
Op Value = Op Value ! 2_000000000 0 000000 1 000000000000000
else if Omatch('E')
Op Value = Op Value ! 2_000000000 1 000000 0 000000000000000
else if Omatch('P')
Op Value = Op Value ! 2_000000000 1 000000 1 000000000000000
finish
F Register(Fdst); Comma
Ud = 1
if Match(' ') start {a defined object}
W == Var(Tag)
Disp = W_Disp
Modify Disp
if W_Base = Local start
Rn = Actual(Fp)
else if W_Base = SB
Rn = Actual(Sb)
else if W_Base = 0 and W_Area < 0
Dir3(Dir Spec Load, Rd, -W_Area)
Refs = Refs+1; Ca = Ca+4
Rn = Rd
Disp = 0
finish else Mc Error("cannot address non-locals")
else
Want('[')
Register(Rn)
if Match(',') start { [Rn, D] }
Warn(1, "spurious translate option") if Op Value&(1<<21) # 0
Get Displacement(16_0500 0000)
Want(']')
Op Value = Op Value ! 1<<21 if Match('!')
else
Want(']')
if Match(',') start { [Rn], D }
Get Displacement(16_0400 0000)
else { [Rn] }
Op Value = Op Value ! 16_0400 0000
finish
finish
finish
Disp = -Disp and Ud = 0 if Disp < 0
Mc Error("Alignment error") if Disp&3 # 0
Disp = Disp>>2
Mc Error("displacement too large") if Disp > 255
Op Value = Op Value ! Disp ! 16_0500 0000 ! Rn<<16 c
! (Fdst&7)<<12 ! Ud<<23
->OK
routine Set Round
if Omatch('P') start
Op Value = Op Value ! 16_0000 0020
else if Omatch('M')
Op Value = Op Value ! 16_0000 0040
else if Omatch('Z')
Op Value = Op Value ! 16_0000 0060
finish
end
Ot(7): Set DS(0)
Set Round
N = Op Value>>20&15
if N = 0 start {flt}
F Register(Reg1); Comma; Register(Reg2)
Op Value = Op Value ! (Reg1&7)<<16 ! Reg2<<12
else if N = 1 {fix}
Register(Reg1); Comma; F Register(Reg2)
Op Value = Op Value ! (Reg1)<<12 ! Reg2&7
else
Register(Reg1)
Op Value = Op Value ! Reg1<<12
finish
->OK
Ot(9): F Register(Fs1); Comma; Lit Reg(Fs2)
Op Value = Op Value ! (Fs1&7)<<16 ! Fs2
->OK
Ot(10): Set DS(1)
Set Round
F Register(Fdst); Comma
if Op Value&16_0000 8000 = 0 start {dyadic}
F Register(Fs1); Comma
else {monadic}
Fs1 = 0
finish
Lit Reg(Fs2)
Op Value = Op Value ! (Fdst&7)<<12 ! (Fs1&7)<<16 ! Fs2
->OK
Ot(-1): cycle
Mc Error("constant expected") unless Literal(N)
if Op Num = -1 start
Dump Byte(N&255)
else if Op Num = -2
Dump Byte(N&255)
Dump Byte(N>>8&255)
else
Dump Word(N)
finish
repeat until not Match(',')
if Ca&3 # 0 start
Dump Byte(0) until Ca&3 = 0
Warn(0, "zero padding bytes added to ensure word alignment")
finish
->Done
OK: Dump Word(Op Value)
Done: Mc Error("Too many operands") unless Match(';')
Mc Error("spurious operation qualifiers") if SymP # Op Length
finish
end
!%endoffile
!##########################################################################
integerfn Uses(integer R, record(Stackfm)name V)
integer N = 0
while V ## Nil cycle
N = N+1 if V_Base = R
N = N+Uses(R, V_Index) unless V_Index == Nil
N = N+Uses(R, V_Record) unless V_Record == Nil
V == V_Link
repeat
result = N
end
routine Store Real Constant(record(Stackfm)name W)
integer N
if W_Form = Address and W_Base = 0 c
and W_Record == Nil c
and W_Index == Nil start {real constant}
Constant Base = (Constant Base+3)&(¬3)
Select Constant Area
N = Ca
Dump Word(W_Rhigh)
Dump Word(W_Rlow)
Select Code Area
W_Disp = N; W_Area = Constant Area; W_Form = Direct
finish
end
predicate Potentially Unassigned(record(Stackfm)name V)
false if Unassigned = 0
false if V_Flags&Known Ass # 0
false unless V_Form = Direct and V_Flags&Checkable # 0
true
end
routine Simple(record(Stackfm)name From, To)
record(Stackfm)name W
W == Copy(From)
Move(W, To)
Release and Drop(W)
end
routine Load Address(record(Stackfm)name V, integer R)
Amap(V)
Load(V, R)
end
routine Push(record(Stackfm)name V)
record(Stackfm) S = 0
S_Type = Integers; S_Form = AutoD; S_Base = SP
Store(V, S)
end
routine Push Literal(integer Lit)
record(Stackfm)name L == Literal(Lit)
Push(L)
Release and Drop(L)
end
routine Push Address(record(Stackfm)name V)
Amap(V)
Push(V)
end
routine Pop Stack(integer Bytes)
return if Bytes = 0
Fail("stack alignment") if Bytes&3 # 0
Plant1(ADD, Sp, Sp, Rot(Bytes>>2, 16-1))
end
routine Loadup Address(record(Stackfm)name V)
Amap(V)
Load(V, Any)
end
routine Loadup(record(Stackfm)name From)
integer Oper
record(stackfm)name W, Lhs
if From_Type = Sets start
Fail("Bad set") if From_Oper = 0
Oper = From_Oper; W == From_Link; From_Oper = 0; From_Link == NIL
if From_Flags&Work Set = 0 start
Lhs == Claim Work Area(Set Size, Sets); Lhs_Flags = Lhs_Flags!Work Set
Set Assign(From, Lhs)
Release(From_Base)
Zap Index and Record(From)
From_Data = Lhs_Data
Drop(Lhs)
finish
Lhs == Copy(From)
From_Oper = Oper; From_Link == W
Set Assign(From, Lhs)
Release and Drop(Lhs)
else if Floating(From)
Load(From, AnyF)
else
Load(From, Any)
finish
end
routine Load Protected(record(Stackfm)name V)
{load V somewhere it can be altered safely}
Monitor(V, "->Load protected") if Diag&MonOperand # 0
Loadup(V)
if Activity(V_Base) # 1 start {covers in use (>1) and locked (<0)}
if V_Type >= Reals then Load(V, FPR) else Load(V, GPR)
finish
Monitor(V, "<-Load protected") if Diag&MonOperand # 0
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(MULHx):
Cop(MULX): L = L*N; ->Out
Cop(ANDx): 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>>N; ->Out
Cop(EXPX): Fail("Exp") if N < 0; L = L¬¬N; ->Out
Cop(MODx): Fail("Illegal MOD") if N <= 0
if L < 0 start
L = N-Rem(-L, N); L = 0 if L = N; ->Out
finish
Cop(REMx): Fail("Zero divide") if N = 0; L = Rem(L, N); ->Out
Cop(DIVX): Fail("Zero divide") if N = 0; L = L//N; ->Out
Cop(*): Fail("C-op")
Out:
end
routine Operate(integer NewOper, record(Stackfm)name Lhs, Rhs)
integer Op, Rconst, Key, Lflags, Rflags, N, Fn
record(Stackfm)name W
routine Swop
record(Stackfm) Temp
Temp_Data = Lhs_Data
Lhs_Data = Rhs_Data
Rhs_Data = Temp_Data
end
routine Zap
{Make LHS = integer constant 0}
Drop(W)
Drop(Rhs)
Lhs_Link == Nil; Lhs_Oper = 0
Rhs == Literal(0); Swop; Release and Drop(Rhs)
end
routine Reduce Constant
integer Op, N, F
routine Fix(integer Op)
Lhs_Oper = Op
Drop(Lhs_Link)
Lhs_Link == Nil
end
Op = Lhs_Oper; F = Oper Flags(Op)
N = Lhs_Link_Disp
if F&Nullop # 0 and Null Value(Op) = N start
Fix(0)
else if Op = MULx
if N = 0 start
Fix(0)
Release(Lhs_Base)
Lhs_Form = Address; Lhs_Base = None; Lhs_Disp = 0; Lhs_Area = 0
Release and Drop(Lhs_Index) if Lhs_Index ## Nil
Release and Drop(Lhs_Record) if Lhs_Record ## Nil
Lhs_Record == Nil; Lhs_Index == Nil
else if N = -1
Fix(NEGX)
finish
else if Op = ADDx
if Lhs_Form = Address start
Fix(0); Lhs_Disp = Lhs_Disp+N
finish
else if Op = ANDx and Lhs_Form = Direct and Lhs_Area = 0
N = N&255 if Lhs_Type = Bytes
if Unassigned = 0 or Lhs_Flags&Checkable = 0 c
or Lhs_Flags&Known Ass # 0 start
{only do this if Lhs is not to be checked for unassigned}
if N&16_FFFFFF00 = 0 start
Lhs_Type = Bytes
Fix(0) if N = 255
else if N&16_FFFF00FF = 0 and Lhs_Type = Shorts
Lhs_Type = Bytes; Lhs_Disp = Lhs_Disp+1
N = N>>8; Lhs_Link_Disp = N
Fix(0) if N = 255
Operate(LSHx, Lhs, Literal(8))
finish
finish
else if Op = XORX and N = -1
Fix(NOTX)
finish
end
integerfn Field(integer And, Shift, AndFirst)
integer R = 0
if AndFirst # 0 start {X&And >> Shift}
And = (And>>Shift)<<Shift
result = -1 if And = 0 {zero result}
And = And>>1 and R = R+1 while And&1 = 0
result = 0 if Shift < R {shift must equal R}
{it's now in the form X>>Shift & And}
else {X>>Shift & And}
And = (And<<Shift)>>Shift
result = -1 if And = 0 {zero result}
finish
N = Power(And+1); result = 0 if N < 0 or N > 8
result = N<<16 + Shift
end
if Diag&MonOperate # 0 start
Monitor(Lhs, "O-Lhs")
Monitor(Rhs, "O-Rhs")
finish
Rflags = Oper Flags(NewOper)
if Rflags&Unary # 0 start
if Iconst(Lhs) start {this excludes reals}
if NewOper = NEGX start
Lhs_Disp = -Lhs_Disp
else if NewOper = NOTX
Lhs_Disp = ¬Lhs_Disp
else if NewOper = ABSx
Lhs_Disp = |Lhs_Disp|
finish else Fail("Operator")
else
NewOper = NewOper+Real Shift if Floating(Lhs)
if Lhs_Oper # 0 start
if Lhs_Oper = NewOper start {e.g. -(-A) }
{SCR/87/401}
Lhs_Oper = 0 unless NewOper = ABSx c
or NewOper = RABSx {BEWARE: ABS(ABS(X))}
->Mon
finish
if NewOper = NEGx or NewOper = NOTx start {SCR/87/401}
if Lhs_Oper = NEGx or Lhs_Oper = NOTx start
{ -(¬A) -> A+1 Note: -NEG = ADD }
{ ¬(-A) -> A-1 -NOT = SUB }
Lhs_Oper = 0
if NewOper = NEGx then NewOper = ADDx else NewOper = SUBx
Operate(NewOper, Lhs, Literal(1))
->Mon
finish
finish
if NewOper = NEGx and Lhs_Oper = MULx and Iconst(Lhs_Link) start
if Lhs_Link_Disp # Minus Infinity start
Lhs_Link_Disp = -Lhs_Link_Disp
->Mon
finish
finish
Loadup(Lhs)
finish
Lhs_Oper = NewOper; Lhs_Link == Nil
finish
->Mon
finish
if NewOper = ConcX start
if Rhs_Bias = 1 start {s.""}
Drop(Rhs); return
finish
if Lhs_Bias = 1 start {"".S}
Fail("inconsistent concatenation") if Lhs_Link ## Nil
Lhs_Data = Rhs_Data; Drop(Rhs)
return
finish
Loadup(Lhs) if Lhs_Oper # 0 and Lhs_Oper # CONCx
Loadup(Rhs) if Rhs_Oper # 0
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 Iconst(Lhs) {1@? -> ?@1}
if Rhs_Oper # 0 start
Op = Rhs_Oper
if Op = NEGx and (NewOper = ADDx or NewOper = SUBx) start
{ Lhs + (-Rhs) }
NewOper = (ADDx+SUBx)-NewOper { Lhs - Rhs }
Rflags = Oper Flags(NewOper)
Rhs_Oper = 0
else if Op = NOTx and NewOper = ANDx {convert to BIC}
Rhs_Oper = 0; NewOper = BICx
else if (Op = LSHx or Op = RSHx) and Oper Flags(NewOper)&Easy # 0 c
and Lhs_Type < Reals c
and Lhs_Oper < Rnegx
{optimise A newoper B shift C}
W == Rhs_Link; Rhs_Link == NIL; Rhs_Oper = 0
Loadup(Lhs)
Loadup(Rhs)
if Iconst(W) start
if Op = LSHx then N = Ishift(Rhs_Base, W_Disp, Logical Left) c
else N = Ishift(Rhs_Base, W_Disp, Logical Right)
else
Loadup(W)
if Op = LSHx then N = Rshift(Rhs_Base, W_Base, Logical Left R) c
else N = Rshift(Rhs_Base, W_Base, Logical Right R)
finish
Plant1(Easy Op(NewOper), Lhs_Base, Lhs_Base, N)
Release and Drop Pair(Rhs, W)
return
else
Loadup(Rhs)
finish
finish
if Iconst(Rhs) start
Rconst = 1
if NewOper = SUBX start { Lhs-(+const) }
if Rhs_Disp # Minus Infinity start
Rhs_Disp = -Rhs_Disp
NewOper = ADDx { Lhs+(-const) }
Rflags = Oper Flags(ADDx)
finish
finish
if Oper Flags(NewOper)&Nullop # 0 and Null Value(NewOper) = Rhs_Disp start
Drop(Rhs)
return
finish
else
Rconst = 0
finish
if Lhs_Oper # 0 start
Op = Lhs_Oper; Lflags = Oper Flags(Op)
W == Lhs_Link
if Op = NEGx and NewOper = MULx start
Lhs_Oper = 0
Operate(MULx, Lhs, Rhs)
Operate(NEGx, Lhs, Nil)
return
finish
if Lflags&Unary = 0 and Iconst(W) start
if Rconst # 0 and NewOper < RNEGx start
Key = (Lflags!Rflags)&Assoc Mask
if Key = 0 {strongly associative} or c
(Key = Weak Assoc {weakly associative} and NewOper = Op) start
if Rhs_Base = None or NewOper = ADDX start
Constant Operation(NewOper, W_Disp, Rhs)
Reduce Constant if Rhs_Base = None
->Mon
finish
finish
if Op = LSHx and NewOper = ANDx and -31 <= W_Disp <= 0 start
N = Field(Rhs_Disp, -W_Disp, 0)
if N # 0 start
Zap and ->Mon if N = -1
W_Disp = N; Lhs_Oper = EXTx
Drop(Rhs)
->Mon
finish
finish
if Op = ANDx and NewOper = RSHx and 0 <= Rhs_Disp <= 31 start
N = Field(W_Disp, Rhs_Disp, 1)
if N # 0 start
Zap and ->Mon if N = -1
W_Disp = N
Lhs_Oper = EXTx
Drop(Rhs)
->Mon
finish
finish
!! %if Op = ADDx %and NewOper = MULx %start { (A+c)*m -> Am+cm }
!! W_Disp = W_Disp*Rhs_Disp
!! Lhs_Link == Nil; Lhs_Oper = 0
!! Operate(MULx, Lhs, Rhs)
!! Operate(ADDx, Lhs, W)
!! %return
!! %finish
finish
finish
if (Op = LSHx or Op = RSHx) and Oper Flags(NewOper)&Easy # 0 c
and NewOper # BICx c
and Rhs_Type < Reals start
Lhs_Link == NIL; Lhs_Oper = 0
Loadup(Lhs)
Loadup(Rhs)
if Iconst(W) start
if Op = LSHx then N = Ishift(Lhs_Base, W_Disp, Logical Left) c
else N = Ishift(Lhs_Base, W_Disp, Logical Right)
else
Loadup(W)
if Op = LSHx then N =Rshift(Lhs_Base, W_Base, Logical LeftR) c
else N =Rshift(Lhs_Base, W_Base, Logical RightR)
finish
Fn = Easy Op(NewOper)
Fn = RSB if NewOper = SUBx {not commutative}
Plant1(Fn, Rhs_Base, Lhs_Base, N)
Release and Drop Pair(Rhs, W)
return
finish
Loadup(Lhs) {no other choice}
finish
if Iconst(Lhs) and Rconst # 0 and NewOper < RNEGx start
Constant Operation(NewOper, Lhs_Disp, Rhs)
->Mon
finish
if Lhs_Type >= Reals or Rhs_Type >= Reals start
NewOper = NewOper+Real Shift unless NewOper >= RNEGx
if Lhs_Type = Sets start
if Lhs_Flags = Null Set start
Swop if NewOper = RADDx {keep the other set}
Rhs_Type = 0
else if Rhs_Flags = Null Set
Swop if NewOper = RMULx {keep the null set}
Rhs_Type = 0
finish
Lhs_Oper = NewOper; Lhs_Link == Rhs
if Rhs_Type = 0 start
Lhs_Oper = 0; Lhs_Link == Nil
Drop Members(Rhs); Release and Drop(Rhs)
finish
->Mon
finish
finish
if Rflags&Commutative # 0 and InReg(Rhs) start
Swop
Rconst = 0
Rconst = 1 if Iconst(Rhs)
finish
if NewOper = SUBx and Lhs_Form = Address = Rhs_Form start
{try to optimise addr(x) - addr(y)}
if Lhs_Base = Rhs_Base and Lhs_Area = Rhs_Area start
if Same(Lhs_Index, Rhs_Index) and Same(Lhs_Record, Rhs_Record) c
and Lhs_Xsize = Rhs_Xsize start
Lhs_Disp = Lhs_Disp - Rhs_Disp
Release and Drop(Rhs)
Release and Drop(Lhs_Index) if Lhs_Index ## Nil
Release and Drop(Lhs_Record) if Lhs_Record ## Nil
Lhs_Base = 0
Lhs_Xsize = 0
->Mon
finish
finish
finish
Lhs_Oper = NewOper; Lhs_Link == Rhs
Reduce Constant if Rconst # 0
Mon:
Monitor(Lhs, "<-Operate") if Diag&MonOperate # 0
end
routine Aop
integer Type, Format, Size
record(Stackfm)name X
X == Stack {index value}
Stack == X_Stack {the base item}
Size = Item Size(Stack_Format)
if Stack_Index == Nil start
Stack_Index == X; Stack_Xsize = Size
else if Stack_Xsize = Size
Operate(ADDx, Stack_Index, X)
else
Type = Stack_Type; Format = Stack_Format
Amap(Stack)
Operate(MULx, X, Literal(Size))
Operate(ADDx, Stack, X)
Vmap(Stack, Type); Stack_Format = Format
finish
end
routine Operation(integer Oper)
record(Stackfm)name V
V == Stack
Stack == Stack_Stack
Operate(Oper, Stack, V)
end
routine Replace(record(Stackfm)name Old, New)
Zap Index and Record(Old)
Release(Old_Base)
Old_Base = New_Base
Old_Disp = New_Disp
Old_Extra = New_Extra
Old_Type = New_Type
Old_Form = New_Form
Old_Format = New_Format
Old_Area = New_Area
Old_Oper = 0
Old_Link == Nil
Drop(New)
end
{***Register optimisation routines***}
predicate Memorable(record(Stackfm)name V, record(Knowfm)name K)
integer Op = 0, Scale = 0
if V_Oper # 0 start
false unless V_Link ## Nil and Iconst(V_Link)
Op = V_Oper
Scale = V_Link_Disp
finish
false if V_Index ## Nil or V_Record ## Nil or V_Form >= Memorable Limit
K_Ftype = V_Type<<4+V_Form
K_Base = V_Base
K_Disp = V_Disp
K_Extra = V_Extra
K_Area = V_Area
K_Opnd = Scale
K_Oper = Op
K_Ftype = Integers<<4 + Address if Iconst(V)
true
end
routine Optimise(record(Stackfm)name V, integer Swanted)
{Swanted = 0 if destination (address) wanted}
{ = 1 if source (value) wanted}
record(Knowfm)name P
record(Knowfm) M
record(Stackfm)name W
integer Op
P == Knowing; return if P == Nil {nothing known}
if V_Oper # 0 start
Op = V_Oper; V_Oper = 0
W == V_Link; V_Link == Nil
Optimise(V, 1)
Optimise(W, 1) unless W == Nil
V_Oper = Op; V_Link == W
finish
if V_Record ## Nil start
Optimise(V_Record, 1)
if V_Record_Form = Address start
Simplify(V)
P == Knowing; return if P == Nil {nothing known}
finish
finish
return unless Memorable(V, M) {worth looking for?}
Monitor(V, "Opt") if Diag&MonOpt # 0
routine Set(integer Form)
if V_Oper # 0 start
Release and Drop(V_Link)
V_Oper = 0; V_Link == Nil
finish
V_Type = Integers if Form = Address and V_Type <= Addrs {already expanded}
V_Form = Form
Release(V_Base)
V_Area = 0
V_Disp = 0; V_Base = P_Reg
Pending Auto = 0 if P_Reg = Pending Auto
Claim(V_Base)
Monitor(V, "Opt->") if Diag&MonOpt # 0
end
cycle
if P_Disp = M_Disp and P_Area = M_Area and
P_Extra = M_Extra and P_Oper = M_Oper and
P_Base = M_Base and P_Opnd = M_Opnd start {Basically ok}
if P_Ftype = M_Ftype and Swanted # 0 start {exact match}
Set(Address)
return
else if M_Oper = 0 and M_Ftype&15 # Address {beware real zero}
if P_Ftype = Integers<<4+Address start {we have the address}
Set(V_Form)
Optimise(V, 1) if Swanted # 0
return
finish
finish
finish
P == P_Link
repeat until P == Nil
end
record(Knowfm)map NewK
record(Knowfm)name P
P == Kasl
if P == Nil start
P == NEW(KnowfmType); P = 0
else
Kasl == P_Link
finish
result == P
end
routine Kinc(record(Knowfm)name K)
Ktimes(K_Reg) = Ktimes(K_Reg)+1
Ktimes(K_Base) = Ktimes(K_Base)+1 if K_Base&128 = 0 {beware base registers}
end
routine Kdec(record(Knowfm)name K)
Ktimes(K_Reg) = Ktimes(K_Reg)-1
Ktimes(K_Base) = Ktimes(K_Base)-1 if K_Base&128 = 0 {beware base registers}
end
routine Forget(integer Register)
integername N
record(Knowfm)name K, R
return unless R0 <= Register <= F7
Pending Auto = 0 if Pending Auto = Register
N == Ktimes(Register)
Used(Register) = 0
return if N = 0 {%or Activity(Register) < 0} {004}
K == Knowing; Knowing == Nil
while K ## Nil cycle
R == K; K == K_Link
if R_Reg = Register or R_Base = Register start
R_Link == Kasl; Kasl == R
Kdec(R)
Mon Regid(R_Reg, "Forgotten") if Diag&MonOpt # 0
else
R_Link == Knowing; Knowing == R {retain it}
finish
repeat
Fail("Register still known") if N # 0
end
routine Forget Everything
record(Knowfm)name K
Pending Auto = 0
K == Knowing
if K ## Nil start
cycle
Used(K_Reg) = 0
Used(K_Base) = 0 if K_Base&128 = 0 {beware of level bases}
Kdec(K)
exit if K_Link == Nil
K == K_Link
repeat
K_Link == Kasl; Kasl == Knowing
Knowing == NIL
finish
end
routine Inherit(integer New, Old)
record(Knowfm)name P, K, X
return if New = Old
Used(New) = Used Time
P == Knowing
while P ## Nil cycle
K == P; P == K_Link
if K_Reg = Old start
Mon Regid(Old, "inherited") if Diag&MonOpt # 0
X == NewK; return if X == Nil
X = K
X_Reg = New
X_Link == Knowing; Knowing == X
Kinc(X)
finish
repeat
end
routine Remember(integer Register, record(Stackfm)name V)
record(Knowfm)name K
record(Knowfm) M
return unless R0 <= Register <= F7 and Register # Any
Used(Register) = Used Time
if InReg(V) start {inherit other register's data}
Inherit(Register, V_Base)
return
finish
return if Register = V_Base
if Memorable(V, M) start
K == NewK; return if K == Nil
K = M
K_Reg = Register
K_Link == Knowing; Knowing == K
Kinc(K)
Monitor(V, "Remember ".Regid(Register)) if Diag&MonOpt # 0
finish
end
routine Remember Zero(integer Register)
record(Stackfm)name Zero == Literal(0)
Forget(Register)
Remember(Register, Zero)
Drop(Zero)
end
routine Forget Destination(record(Stackfm)name V)
integer Low, High, Base = V_Base, Unsafe = 0, Alter
record(Knowfm)name P, K
Monitor(V, "Forget Dest") if Diag&MonOpt # 0
Forget(V_Base) and return if InReg(V)
Low = V_Disp; High = Low+Item Size(V_Format)-1
High = Low+3 if High < Low
P == Knowing; Knowing == Nil
!
! If generated a instruction of form STR _ Rx, y(Rz) then
! should forget registers that hold non-address values.
! Do not do this if trusted => trusted gets some progs wrong
!
if Interface_Options & LL Trusted = 0 start
if V_Base < 128 and Activity(V_Base) >= 0 start
Unsafe = 1
else if V_Index ## Nil
Unsafe = 1
finish
Monitor N(Unsafe, "Unsafe") if Diag&MonOpt # 0
finish
while P ## Nil cycle
K == P; P == P_Link
Alter = 0
Alter = Unsafe if K_Base < 128 and Activity(K_Base) >= 0
if K_Ftype&15 # Address start {can remember addresses}
Alter = 1 if K_Base = Base and Low <= K_Disp <= High
finish
if Alter # 0 start
Kdec(K)
K_Link == Kasl; Kasl == K
Mon Regid(K_Reg, "Altered") if Diag&MonOpt # 0
else
K_Link == Knowing; Knowing == K {remember it}
finish
repeat
end
{Environment handling}
routine Forget Environment(integer Label)
record(Labelfm)name L
record(Knowfm)name P, E
L == Ilabel(Label)
P == L_Env; L_Env == NIL
if P ## NIL start
E == P
P == P_Link while P_Link ## NIL
P_Link == Kasl
Kasl == E
finish
end
routine Remember Environment(integer Label)
record(Knowfm)name K, Top == NIL, P
Forget Environment(Label)
K == Knowing
while K ## Nil cycle
P == NewK {cannot return Nil}
P = K
P_Link == Top
Top == P
Mon RegId(P_Reg, "in env") if Diag&MonOpt # 0
K == K_Link {onto the next item}
repeat
Ilabel(Label)_Env == 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(Labelfm)name L
record(Knowfm)name P, K, Next, Top
Monitor(Nil, "merge") if Diag&MonOpt # 0
if Knowing == Nil start
Forget Environment(Label)
else
L == Ilabel(Label)
Top == Nil
Next == L_Env
cycle
P == Next; exit if P == Nil
Next == P_Link
K == Knowing
cycle
if K_Reg = P_Reg and c
K_Disp = P_Disp and K_Base = P_Base and c
K_Ftype = P_Ftype and K_Area = P_Area and c
K_Opnd = P_Opnd and K_Oper = P_Oper start
P_Link == Top; Top == P
Mon RegId(P_Reg, "Merged") if Diag&MonOpt # 0
->Found
finish
K == K_Link
repeat until K == Nil
{Not Found}
P_Link == Kasl; Kasl == P {return the cell}
Found:repeat
L_Env == Top
finish
end
routine Restore Environment(integer Label)
record(Knowfm)name P, K, Next
Forget Everything {dispose of old knowledge}
Next == Ilabel(Label)_Env
cycle
P == Next; return if P == NIL
Next == P_Link
K == NewK
K = P
K_Link == Knowing; Knowing == K
Kinc(K)
Mon RegId(P_Reg, "back") if Diag&MonOpt # 0
repeat
end
{Register Control}
routine Claim(integer Register)
return unless R0 <= Register <= AnyF and Activity(Register) >= 0
Activity(Register) = Activity(Register)+1
Active Registers = Active Registers+1
Used Time = Used Time+1; Used(Register) = Used Time
Monitor Register(Register, "Claimed") if Diag&MonReg # 0
end
routine Release(integer Register)
return unless R0 <= Register <= AnyF and Activity(Register) >= 0
Activity(Register) = Activity(Register)-1
Fail("Register not claimed") if Activity(Register) < 0
Monitor Register(Register, "Released") if Diag&MonReg # 0
Active Registers = Active Registers-1
Fail("Register unclaimed") if Active Registers < 0
end
routine To Store(integer Code)
if Code # 0 start
if Code = 3 start {short}
Loadup(Stack) if Stack_Type = Bytes
else if Code = 1 {integer}
Loadup(Stack) if Stack_Type = Bytes or Stack_Type = Shorts
finish
finish
if Stack_Form = Address or Stack_Oper # 0 or Stack_Index ## Nil start
if Stack_Type = Strings or Stack_Type = Records start
Evaluate String Expression(Stack) {is this ok for records?}
else
Loadup(Stack)
Hazard(Stack_Base)
finish
finish
end
routine Pessimise(record(Stackfm)name V)
{this routine forces V into store - either by de-optimising it}
{or simply by storing it}
integer Reg, N, Disp
record(Knowfm)name K
record(Stackfm)name T
Monitor(V, "Pessimise->") if Diag&MonOperand # 0
Fail("Not loaded") unless Inreg(V)
Reg = V_Base
N = Ktimes(Reg)
K == Knowing; K == NIL if N = 0
cycle
if K == NIL start {not known in store}
Fail("corrupt knowing") if N # 0
Reg = V_Base {Must store it}
if R0 <= Reg <= R15 start {integer}
T == Claim Work Area(Word Length, Integers)
else {floating}
T == Claim Work Area(2*Word Length, Lreals)
finish
Disp = T_Disp {in case SIMPLE corrupts it}
Simple(V, T)
Release(Reg)
V_Base = Local; V_Disp = Disp; V_Form = Direct
Drop(T)
exit
finish
if K_Reg = Reg start
N = N-1
if K_Oper = 0 = K_Opnd start
if K_Ftype = V_Type<<4 + Direct and K_Area = V_Area c
and Locked(K_Base) start
Release(Reg)
V_Base = K_Base
V_Disp = K_Disp
V_Extra = K_Extra
V_Form = Direct
V_Flags = Known Ass
Claim(V_Base)
exit
else if K_Ftype = Integers<<4 + Address and K_Base = 0 c
and K_Area = 0 {constant}
Release(Reg)
V_Base = 0; V_Disp = K_Disp
V_Form = Address
V_Area = 0
V_Flags = Known Ass
exit
finish
finish
else if K_Base = Reg
N = N-1
finish
K == K_Link
repeat
Monitor(V, "Pessimise<-") if Diag&MonOperand # 0
end
routine Hazard(integer Reg)
integer Register = |Reg|
{This unpleasant routine has to deal with the horrors of needing}
{a register and so needing to ensure that it does not hold}
{useful data already.}
{***perhaps improve use of PESSIMISE***}
record(Stackfm)name U, R
integername N
integer Disp, Stored = 0
routine Store
record(Stackfm)name T
return if Stored # 0
Stored = 1
if R0 <= Register <= R15 start {integer}
T == Claim Work Area(Word Length, Integers)
else {floating}
T == Claim Work Area(2*Word Length, Lreals)
finish
Disp = T_Disp
Simple(RegV(Register), T); Release and Drop(T)
end
Monitor Register(Register, "Hazard") if Diag&MonReg # 0
N == Activity(Register); return if N <= 0 {locked/free}
U == Using
while U ## Nil cycle
if U_Base = Register start {the index looks after itself}
Monitor(U, "Hazarding") if Diag&MonReg # 0
if N = 1 and Stored = 0 and InReg(U) start
Pessimise(U)
return
finish
Store
if U_Form = Address and U_Disp = 0 and U_Index == Nil start {it's a regster}
U_Form = Direct; U_Base = Local; U_Disp = Disp
else {make it look like a record}
Fail("Corrupt record") if U_Record ## Nil
R == Local Integer(Disp)
R_Flags = Hazarded
U_Base = None; U_Record == R
finish
Release(Register)
finish
U == U_Using
repeat
if N # 0 start
Fail("Use lost") if N # 0
finish
end
routine Hazard All
Hazard(R0); Hazard(R1); Hazard(R2); Hazard(R3)
return if Active Registers = 0
Hazard(R4); Hazard(R5); Hazard(R6); Hazard(R7)
return if Active Registers = 0
Hazard(R8); Hazard(R11); Hazard(R14)
return if Active Registers = 0
Hazard(F0); Hazard(F1); Hazard(F2); Hazard(F3)
return if Active Registers = 0
Hazard(F4); Hazard(F5); Hazard(F6); Hazard(F7)
end
{Descriptor Control}
record(Stackfm)map Descriptor
record(Stackfm)name V
if Dasl == Nil start {empty, grab some from the heap}
Dasl == NEW(Stackfm Type)
Dasl_Using == Nil
finish
V == Dasl; Dasl == V_Using
V = 0
V_Using == Using; Using == V
result == V
end
routine Drop All(record(Stackfm)name V)
Drop All(V_Index) and V_Index == Nil if V_Index ## Nil
Drop All(V_Record) and V_Record == Nil if V_Record ## Nil
Drop(V)
end
routine Drop(record(Stackfm)name V)
record(Stackfm)name P, E
Monitor(V, "Drop") if Diag&MonStack # 0
Zap Index and Record(V)
if Using == V start {first is quick}
Using == V_Using
else {otherwise search for it}
P == Using
cycle
Fail("Not in use") if P == Nil
E == P
P == P_Using
repeat until P == V
E_Using == P_Using
finish
V_Using == Dasl; Dasl == V
end
routine Release and Drop(record(Stackfm)name V)
Release and Drop(V_Link) unless V_Link == Nil
Release(V_Base)
Drop(V)
end
routine Zap Index and Record(record(Stackfm)name V)
Release and Drop(V_Index ) and V_Index == Nil unless V_Index == Nil
Release and Drop(V_Record) and V_Record == Nil unless V_Record == Nil
end
routine Release and Drop Pair(record(Stackfm)name A, B)
Release and Drop(A)
Release and Drop(B)
end
routine Pop Release and Drop
record(Stackfm)name S
S == Stack
Stack == S_Stack
Release and Drop(S)
end
routine Drop Members(record(Stackfm)name S)
record(Memberfm)name M, X
M == S_Members ; S_Members == Nil
while M ## Nil cycle
X == M ; M == M_Link
if X_Const # 0 start
Drop(X_A)
Drop(X_B) if X_B ## Nil
else
Release and Drop(X_A)
Release and Drop(X_B) if X_B ## Nil
finish
Dispose(X)
repeat
end
routine Apply Indirection {to the stack}
record(Stackfm)name W
W == Stack; Stack == Descriptor
Stack_Stack == W_Stack
Stack_Type = W_Type; Stack_Form = Direct; Stack_Record == W
Stack_Format = W_Format
W_Type = Integers; W_Form = Direct; W_Format = 0
end
routine Stack True or False(integer CC)
{CC is the condition for TRUE}
integer Other, R, Lab
record(Stackfm)name V
V == Literal(0); Optimise(V, 1) {try for zero=false}
if InReg(V) start {Yes}
CC = Negated(CC)
Other = 1
else {No, try for one=true}
V_Disp = 1; Other = 0
finish
Load Protected(V); R = V_Base {in case the register is in use}
Release and Drop(V)
Fail("register active") unless Activity(R) = 0
Lab = New Label
Jump To(Lab, CC); V == Literal(Other); Load(V, R); Define Label(Lab)
Forget(R)
V_Stack == Stack; Stack == V
end
routine Stack Var(integer Varno)
integer Form, Flags
record(Stackfm)name V
V == Descriptor
V_V = Var(Varno)
V_Varno = Varno
V_Stack == Stack
Stack == V
Attributes = Attributes ! Attr Needs Gp if Stack_Base = SB
Form = V_Form
if V_Flags&XData Spec # 0 start
Flags = V_Flags; V_Flags = 0
Apply Indirection
Stack_Flags = Flags&(¬XData Spec)
finish
Apply Indirection if Form = Indirect {Be careful to use original}
Monitor(Stack, "Stack Var") if Diag&MonStack # 0
end
record(Stackfm)map Local Integer(integer Disp)
record(Stackfm)name V
V == Descriptor
V_Type = Integers; V_Form = Direct
V_Base = Local; V_Disp = Disp
V_Flags = Known Ass
result == V
end
record(Stackfm)map Literal(integer N)
record(Stackfm)name V
V == Descriptor
V_Disp = N
V_Type = Integers
V_Flags = Known Ass {ready for form being changed to direct}
result == V
end
routine Stack Integer(integer N)
record(Stackfm)name V
V == 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
record(Stackfm)map Temporary
{Cannot use CLAIM WORK AREA as they get released at the end of EACH statement}
record(Stackfm)name V
Frame = Frame&Alignment Mask - Word Length
V == Local Integer(Frame)
result == V
end
record(Stackfm)map Copy(record(Stackfm)name V)
record(Stackfm)name C
result == Nil if V == Nil
C == Descriptor
C_Data = V_Data; Claim(C_Base)
C_Oper = V_Oper
C_Index == Copy(V_Index) unless V_Index == Nil
C_Record == Copy(V_Record) unless V_Record == Nil
C_Link == Copy(V_Link) unless V_Link == Nil
result == C
end
{Stack control}
routine Select(integer Item)
record(Stackfm)name V, X
record(Varfm)name Field
V == Stack
Field == Var(Var(-V_Format)_Extra-Item)
Fail("Select") if V_Form = Address
Stack_Varno = 0
{temp frig for A(4)_Sn == S}
if V_Form = Direct and V_Index == Nil start
V_Disp = V_Disp+Field_Disp
V_Type = Field_Type
V_Form = Field_Form
V_Format = Field_Format
V_Flags = Field_Flags
V_Adata == Field_Adata
else {Indirect}
Amap(V) {ready for REDUCE}
X == Descriptor
X_V = Field; X_Base = 0
X_Record == V
Stack == X; X_Stack == V_Stack {re-link it}
finish
Apply Indirection if Stack_Form = Indirect
Monitor(Stack, "Select") if Diag&MonStack # 0
end
{Label & Jump Handling}
routine X Call(integer Ep, Stackit, Hazard)
record(Stackfm)name V
Hazard All if Hazard > 0 and Active Registers # 0
Dir2(Dir Xcall, Ep); Refs = Refs+1; Ca = Ca+4
Forget Everything unless Hazard < 0
Attributes = Attributes!Attr Needs Gp
if Stackit # 0 start
Attributes = Attributes!Attr Dynamic
V == Register(Stackit)
V_Stack == Stack; Stack == V
finish
end
routine Check Compiler Label(integer Label)
Fail("compiler labels/1") if Label > Max Label
end
integerfn New Label
Free Label = Free Label+1
Fail("too many internal labels") if Free Label&16_8000 # 0
result = Free Label
end
routine Jump to(integer Internal Label, Cond Code)
Jlab = Internal Label {remember for Events}
Cond Code = Reverse(Cond Code) and Invert = 0 if Invert # 0
Dir3(Dir Branch, Internal Label, Cond Code+Unsigned); Unsigned = 0
Refs = Refs+1
Ca = Ca+4 {assume 2 bytes worth}
Uncond Jump = Ca if Cond Code = Always {can't get past here}
Assign Lock = 0 {no longer safe}
end
routine Define Label(integer Internal Label)
Dir2(Dir Label, Internal Label)
Uncond Jump = -1 {can get here now}
Assign Lock = 0 {can no-longer remember ass}
end
routine Define Compiler Label(integer Label)
record(Labelfm)name L
Check Compiler Label(Label)
L == Ilabel(Label)
if L_Lab&Defined # 0 start {redefinition}
Forget Environment(Label)
L_Lab = New Label
finish
L_Lab = L_Lab!Defined {show it's defined}
Merge Environment(Label) if Uncond Jump # Ca
Define Label(L_Lab&Label Mask)
Restore Environment(Label)
end
integerfn Forward Label(integer Label)
record(Labelfm)name L
L == Ilabel(Label)
if L_Lab&Defined # 0 start {redefine it}
L_Lab = New Label
Remember Environment(Label)
else {another reference}
Merge Environment(Label)
finish
result = L_Lab
end
routine Jump Forward(integer Label, Cond Code)
Check Compiler Label(Label)
Jump To(Forward Label(Label), Cond Code)
if Cond Code = NE and Pending Known Register # 0 start
Remember(Pending Known Register, Pending Known)
finish
Pending Known Register = 0
end
routine Jump Backward(integer Label)
record(Stackfm) C, F
record(Stackfm)name U, CC
record(Forfm)name For == Nil
record(Varfm)name Vr
record(Labelfm)name L
integer How
Check Compiler Label(Label)
L == Ilabel(Label)
How = Always
Fail("Label missing") if L_Lab&Defined = 0
if Fors ## Nil and Label = Fors_Label start {repeat of a %for stat}
For == Fors; Fors == Fors_Link {unchain this item}
C_Data = For_Control
Vmap(C, For_Type)
Load(C, For_Reg)
Define Compiler Label(For_Entry) if For_Entry # 0
F_Data = For_Final
Compare(C, F); Release(C_Base); Release(F_Base)
How = For_CC
finish
Jump To(L_Lab&Label Mask, How)
if For ## Nil start
if How # Always and Language Flags&Undefined Control # 0 c
and Unassigned # 0 start
CC == Literal(0)
CC_Data = For_Control
Vmap(CC, For_Type)
U == Copy(UaPat); U_Type = For_Type
Simple(U, CC) {Zap the control variable}
Forget Destination(CC) {PSR 02NOV87}
Forget(U_Base) {beware of remembering bytes with zero}
Release and Drop(U)
Release and Drop(CC)
if For_Control_Varno # 0 start
Vr == Var(For_Control_Varno)
Vr_Flags = Vr_Flags&(¬Known Ass)
finish
finish
Dispose(For)
finish
end
routine Set User Label(integer Label)
record(Varfm)name V
V == Var(Label)
Clear Vars(Label)
V_Type = Labels
V_Base = Local
V_Disp = New Label
end
routine User Jump(integer Label)
owninteger Jout = 0
integer B
record(Stackfm)name Base
record(Varfm)name V
record(Varfm) C
V == Var(Label)
Set User Label(Label) if Label > Vars or V_Disp = 0 {Not in Yet allocated a var}
B = V_Base
if B # Local start {non-local}
Base == Display Info(B)
Release and Drop(Base)
Base == Literal(0); Base_Base = B; Base_Flags = Known Ass
Load(Base, Fp) {Restore old Fp}
Base_Disp = V_Extra; Base_Form = Direct; Base_Flags = Known Ass
Load(Base, R3); Release and Drop(Base) {new value for SP}
Do("3L_pascal___jump_out", Jout, 0)
finish
Jump To(V_Disp, Always)
end
routine Mark User Label
Dir1(Dir Mark User)
end
routine Define User Label(integer Label)
record(Varfm)name V
V == Var(Label)
Set User Label(Label) if Label > Vars or V_Disp = 0 {Not in Yet allocated a var}
Define Label(V_Disp)
Mark User Label
Forget Everything
end
routine Return(integer How)
integer Result Reg, Type
record(Stackfm)name V, W
if Uncond Jump = Ca start
Pop Release and Drop if How < 0 {remove stacked result}
return
finish
V == Nil
Result Reg = R0
Type = Avar_Type
if How = True start
V == Literal(1)
else if How = False
V == Literal(0)
else if How # 0
V == Stack; Stack == Stack_Stack
if How = Map start
Amap(V)
Type = Addrs {map result types are addresses}
else if Type = Strings or Type = Records
W == Literal(0)
W_Type = Type; W_Form = Direct
W_Record == Local Integer(String Result)
W_Record_Format = Avar_Format
if W_Type = Strings then String Assign(V, W) c
else Record Assign(V, W)
Release and Drop Pair(W, V)
V == Nil
finish
finish
if V ## Nil start
if Type = Reals or Type = Lreals start
Load(V, F0)
else
Load(V, Result Reg)
finish
Release and Drop(V)
finish
Dir2(Dir Return, Parameter Frame)
Refs = Refs+1
Ca = Ca+4 {assume two bytes}
Uncond Jump = Ca {Can't get past here}
Open = 0 {the procedure returns}
end
routine Stab(record(Stackfm)name V)
record(Stackfm)name T, TT
return if Iconst(V)
T == Temporary; TT == Copy(T) {in case of corruption by store}
Store(V, T)
Release and Drop(T)
Replace(V, TT)
V_Flags = V_Flags!Known Ass
end
routine Compile For(integer Repeat Label)
integer Type, N
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
record(Varfm)name V
integerfn Loop Type
integer I, N
result = 1 unless Iconst(Initial) and Iconst(Inc) c
and Iconst(Final)
I = Inc_Disp
N = Final_Disp-Initial_Disp+I
if I # 0 start
result = 1 if N = 0 {zero iterations?}
if N!!I >= 0 and Rem(N, I) = 0 start {constant}
if For Range ## Nil start
unless For Range_Disp <= Initial_Disp <= For Range_Extra and
For Range_Disp <= Final_Disp <= For Range_Extra start
result = 1 {check it dynamically}
finish
For Range == Nil {all OK}
finish
result = 0
finish
finish else I = 1
if Language Flags&Non Exact For = 0 start
Warn(1, "Non-integral %for loop")
Final_Disp = Initial_Disp+N//I*I
finish
result = 1
end
Final == Stack
Inc == Final_Stack
Initial == Inc_Stack
Control == Initial_Stack
Stack == Control_Stack
Stab(Inc)
Type = Control_Type
unless Control_Form = Direct c
and Control_Index == NIL c
and Control_Record == NIL c
and (Control_Base = None c
or Control_Base = Local c
or Control_Base = SB) start
{protect expensive (i.e. non-local) or moveable control variable}
Amap(Control); Stab(Control) {save its address}
else
Amap(Control)
finish
Simplify(Control)
For == NEW(ForfmType); For_Link == Fors; Fors == For
For_Label = Repeat Label
For_Control = Control_Data
Vmap(Control, Type); For_Type = Type
For_Entry = Loop Type {and check on the fly}
For_AS = 0 {no +1 or -1 yet}
N = Inc_Disp
For_CC = NE
if Language Flags&Non Exact FOR # 0 and For_Entry # 0 start
if N = 1 start
For_CC = LT
else if N = -1
For_CC = GT
finish else Fail("corrupt increment")
finish
Increment == Copy(Inc) {beware of corruption in operate}
Operate(SUBx, Initial, Inc)
Loadup(Initial); For_Reg = Initial_Base
Stab(Final); For_Final = Final_Data
Load(Initial, For_Reg) {beware of HAZARD in STAB}
if For_Entry # 0 start {may never execute the loop}
if Language Flags&Undefined Control = 0 start
{must save the initial value in case the loop isn't executed}
C == Copy(Control)
Store(Initial, C)
Release and Drop(C)
finish
For_Entry = Repeat Label+2
Jump Forward(For_Entry, Always)
finish
Define Compiler Label(Repeat Label)
if For_AS = 0 start
Operate(ADDX, Initial, Increment)
Load(Initial, For_Reg) {can be removed if desired!}
finish
if For Range ## Nil start
Test Range(Initial, For Range) {check initial value}
For Range == Nil
finish
Store(Initial, Control)
For_Control_V_Flags = For_Control_V_Flags!Known Ass
if Control_Varno # 0 start
V == Var(Control_Varno)
V_Flags = V_Flags!Known Ass
finish
Release and Drop Pair(Control, Initial)
Release and Drop(Final)
end
record(Stackfm)map Const String
record(Stackfm)name W
Constant Base = (Constant Base+3)&(¬3) {align it}
Select Constant Area
W == Literal(Ca)
W_Type = Strings; W_Form = Direct
W_Area = Constant Area
W_Format = Length(Value_String)+1
W_Bias = W_Format
Dump Text(0) unless Value_String = "" {I think this is safe?}
Select Code Area
result == W
end
routine Fix Tostring(record(Stackfm)name C)
record(Stackfm)name W
Value_String = Tostring(C_Disp)
W == Const String
C_Data = W_Data
Drop(W)
end
routine Set Size or Type(integer ST, record(Stackfm)name V)
integer N
if V_Type = Generals start
Amap(V)
V_Disp = V_Disp+ST*Word Length {<addr><size><type>}
else
if ST = 1 {sizeof} start
N = Item Size(V_Format)
if N = 1 and V_Type = Strings start {string(*)name}
Amap(V)
Advance(V, Integers, Wordlength)
return
finish
else
N = Type Code(V_Type)
finish
Release(V_Base)
Zap Index and Record(V)
V_Data = 0
V_Disp = N
V_Type = Integers
V_Form = Address
finish
end
include "call.inc"
routine Switch Label(integer Tag)
Dir2(Dir Slabel, Var(Tag)_Area+Popped Value)
Uncond Jump = -1
Assign Lock = 0
Mark User Label
Forget Everything
end
routine Switch Jump(integer Tag)
record(Stackfm)name X
X == Stack; Stack == Stack_Stack {the index}
Load(X, R1)
Release and Drop(X)
Prim(SwJump)
Dump Word(16_E792F105) {LDR_Pc,[R2,R5 %LSL #2]}
Dir2(Dir Sw Ref, Var(Tag)_Format); Ca = Ca+4
Uncond Jump = Ca
end
routine Save Wsp
record(Stackfm)name D
if Wsp Save = 0 start
Frame = (Frame&(¬3))-4
Wsp Save = Frame
finish
D == Local Integer(Wsp Save); Plant2(STR, Sp, D); Release and Drop(D)
end
routine Event Trap(integer Bits)
{###################################################}
{# Block(......) #}
{# ............ #}
{# %on EVENT BITS %start #}
{# Event Label -> ....... #}
{# ....... #}
{# %finish #}
{# Event Body -> ....... #}
{# ....... #}
{# %end #}
{###################################################}
integer Lab
record(Stackfm)name D
Lab = Tag
Save Wsp
Jump Forward(Lab, Always)
Event Bits = Bits
Event Body = Jlab
Event Label = New Label
Define Label(Event Label); Mark User Label
Forget Everything
D == Local Integer(Wsp Save); Plant2(LDR, Sp ,D); Release and Drop(D)
Attributes = Attributes!Attr Dynamic
end
routine Signal Event(integer Event)
record(Stackfm)name E, Sub Event, Extra
Extra == Stack
Sub Event == Extra_Stack
Stack == Sub Event_Stack
E == Literal(Event)
Load Trio(E, R1, Sub Event, R2, Extra, R3)
Release and Drop Pair(E, Sub Event)
Release and Drop(Extra)
Prim(Signal)
Uncond Jump = Ca
Attributes = Attributes!Attr Dynamic
end
include "compare.inc"
{Assignment}
routine General Move
record(Stackfm)name F, T, Flen, Tlen
Flen == Stack
Tlen == Flen_Stack
F == Tlen_Stack
T == F_Stack
Stack == T_Stack
Load Pair(Tlen, R3, Flen, R4)
Load Pair(T, R1, F, R2)
Load Pair(Tlen, R3, Flen, R4)
Load Pair(T, R1, F, R2)
Release and Drop Pair(Flen, Tlen)
Release and Drop Pair(F, T)
Prim(GenMove)
Forget Everything
end
routine Record Assign(record(Stackfm)name From, To)
integer LenL, LenR, Inc, Mod, Load, R, Aligned = 1, Zero
routine Record Op
R = GPR if R < 0
Plant2(LDR ! Mod, R, From) if Load # 0
Plant2(STR ! Mod, R, To)
end
LenL = Item Size(To_Format)
LenR = Item Size(From_Format) {note: Var(0)_Format=0 - constants}
LenL = LenR if LenL = 0 or (LenR # 0 and LenR < LenL)
return if LenL <= 0
Aligned = 0 unless LenL&3 = 0 and Properly Aligned(To, 3)
Zero = 0
if Iconst(From) start
Zero = 1
else
Aligned = 0 unless Properly Aligned(From, 3)
finish
Forget Destination(To)
Make AutoI(To, Integers)
Load = 1
Inc = 4; Mod = 0 {assume words}
if Aligned = 0 start {must use bytes}
Inc = 1; Mod = Byte Op
To_Type = Bytes
finish
if Zero # 0 start {record = 0}
Load = 0 {no load needed}
Loadup(From)
R = From_Base
else
Make AutoI(From, To_Type)
R = -1
finish
Repeat(Record Op, Literal(LenL), Inc, NE)
end
routine Set Assign(record(Stackfm)name From, Dest)
record(Memberfm)name M, X
integer Op = From_Oper, Fn
record(Stackfm)name W, Index
record(Stackfm)name To == Copy(Dest)
Build Set(From) if From_Members ## Nil
W == From_Link
if W ## Nil start
From_Link == Nil; From_Oper = 0
if From_Flags&Null Set # 0 start
From == W
else
Fail("Bad set operator") if Op # RADDx c
and Op # RSUBx c
and Op # RMULx
if W_Flags&Null Set = 0 start
unless Same(From, To) start
From_Oper = Op; From_Link == W; Loadup(From)
Set Assign(From, To)
Release and Drop(To)
return
finish
Build Set(W) if W_Members ## NIL and c
(W_Members_Items > 2 or Op = RMULx)
Load Address(To, R8)
if Op # RMULx and W_Members ## Nil start
M == W_Members; W_Members == Nil
while M ## Nil cycle
X == M; M == M_Link
Load Pair(To, R8, X_A, R1)
if X_B ## Nil start
Load(X_B, R0)
Load Pair(To, R8, X_A, R1)
Release and Drop(X_B)
if Op = RADDx then Fn = Set Bits else Fn = Clear Bits
else if Op = RADDx
Fn = Set Bit
else {%if Op = RSUBx}
Fn = ClearBit
finish
Release and Drop(X_A); Dispose(X)
Prim(Fn)
repeat
Release and Drop Pair(W, To)
else
Amap(W); Load Pair(To, R8, W, R11)
Release and Drop(W)
if Op = RADDx then Fn = Set Add else c
if Op = RSUBx then Fn = Set Sub c
else Fn = Set Inter
Prim(Fn)
Release and Drop(To)
finish
return
finish
finish
finish
Release and Drop(W) unless W == Nil
Forget Destination(To)
if From_Flags&Null Set # 0 start
routine Zero(integer R)
record(Stackfm)name W == Literal(0)
Load(W, R); Release and Drop(W)
end
Load Address(To, R8)
Zero(R0); Zero(R1); Zero(R2); Zero(R3)
Plant4(STM ! IA ! Write Back, To_Base, 16_000F)
Plant4(STM ! IA, To_Base, 16_000F)
else
{Note: if set expressions are about it is likely that the address}
{ of FROM is in R8, so load R11 first to catch it}
Load Address(From, R11)
Load Address(To, R8)
Hazard(R0); Hazard(R1); Hazard(R2); Hazard(R3)
Hazard(R4); Hazard(R5); Hazard(R6); Hazard(R7)
Plant4(LDM ! IA, From_Base, 16_00FF)
Plant4(STM ! IA, To_Base, 16_00FF)
Forget(R0); Forget(R1); Forget(R2); Forget(R3)
Forget(R4); Forget(R5); Forget(R6); Forget(R7)
finish
Release and Drop(To)
end
routine Resolve(integer Flag)
{S -> A.(B).C}
integer Lab, InLab = 0, Pend, N
record(Stackfm)name S, A, B, C
N = 0
if Flag&1 # 0 start
C == Stack; Stack == Stack_Stack
else
N = N!1
C == Nil
finish
B == Stack and Stack == Stack_Stack
if Flag&2 # 0 start
A == Stack; Stack == Stack_Stack
else
N = N!2
A == Nil
finish
S == Stack; Stack == Stack_Stack
Evaluate String Expression(B) if B_Oper # 0
Fix Tostring(B) if B_Type <= Addrs
Amap(S); Amap(B)
Load Pair(S, R1, B, R2)
Release and Drop Pair(S, B)
Prim(Sres)
if Flag&4 = 0 start {unconditional}
Prim(Resflop)
else {conditional}
Fail("corrupt resolution") if Pending # 't' and Pending # 'k'
Pend = Pending; Readsymbol(Pending)
InLab = Tag
if Pend = 't' start
Lab = New Label; Jump to(Lab, NE)
else
Jump Forward(InLab, NE); InLab = 0
finish
finish
Claim(R1); Claim(R7) {left fragment}
Claim(R3); Claim(R6) {right fragment}
if A ## Nil start
Load Address(A, R2); Prim(Frag1)
Release and Drop(A)
finish
if C ## Nil start
Load Address(C, R2); Prim(Frag2)
Release and Drop(C)
finish
Release(R1); Release(R7)
Release(R3); Release(R6)
if InLab # 0 start
Jump Forward(InLab, Always)
Define Label(Lab)
finish
end
include "strings.inc"
include "store.inc"
include "pparam.inc" {moved out of store.inc}
routine Array Index
record(Stackfm)name X, End
X == Stack {the index}
Stack == Stack_Stack {the array}
End == Stack
End == End_Params while End_Params ## Nil {find the end}
End_Params == X
X_Params == Nil
Stack_Oper = Stack_Oper+1
end
routine Array Access
integer N, Lim, Flag, Type, Format, Xsize, Scale Needed = 0, MulOp
record(Stackfm)name X, All, Next, Mult, Scale
routine Set up MULT
Mult == Copy(X_Stack) {header}
Advance(Mult, Integers, 4) {onto dope vector pointer}
Loadup(Mult) {pick up dope vector}
Mult_Disp = 20; Mult_Form = Direct {select multiplier 0}
end
Scale == NIL
X == Stack {index value}
Flag = X_Stack_Flags
MulOp = MULx
if Flag&Defered = 0 start
Scale Needed = 1 if (X_Stack_Type = Strings and X_Stack_Format = 1) c
or (X_Stack_Type = Records and X_Stack_Format = 0)
finish
Lim = 1
if X_Stack_Oper # 0 start {final of multi-dimensional}
Array Index
Next == Stack_Params
All == Literal(0)
Lim = Stack_Oper; Stack_Oper = 0
Set up MULT if Flag&Arrayname # 0 {it's dynamic}
for N = 1, 1, Lim cycle
X == Next
Next == X_Params; X_Params == Nil
if N # 1 start
if Flag&Arrayname # 0 start {no constant dope vector}
Operate(MulOp, All, Copy(Mult))
Mult_Disp = Mult_Disp+12
else
Operate(MulOp, All, Literal(Stack_Adata_Bound(N-1)_Mult))
finish
finish
Operate(ADDx, All, X)
repeat
Fail("Corrupt array index") if Next ## Nil
X == All
if Flag&Array = 0 start
if Scale Needed # 0 start
Scale == Mult {pointing at element size in the dope vector}
else
Release and Drop(Mult)
finish
finish
else {Single dimensional}
Set up MULT and Scale == Mult if Scale Needed # 0
Stack == X_Stack
finish
Type = Stack_Type; Stack_Type = Integers
Format = Stack_Format
Vmap(Stack, Integers) if Flag&Arrayname # 0 {indirect through the header}
if Flag&Defered # 0 start {namearray}
Xsize = Wordlength
Xsize = 2*Wordlength if Type = Strings and Format = 1
else if Scale ## NIL
Operate(MulOp, X, Scale)
Xsize = 1
else
Xsize = Item Size(Format)
finish
Stack_Flags = Stack_Flags ! Flag
Apply Index(Stack, X, Xsize)
if Flag&Defered # 0 start {namearray}
Vmap(Stack, Type)
else
Stack_Type = Type
finish
Stack_Format = Format
Stack_Flags = Stack_Flags&( ¬(Static!Array!Arrayname) )
Monitor(Stack, "Array") if Diag&MonOperand # 0
end
routine Update Line(integer This Line)
Fail("Stack") unless Stack == Nil
Fail("Registers") unless Active Registers = 0
Fail("Descriptors") unless Using == Nil
Fail("Corrupt") if RegV(Any )_Base # Any c
or RegV(AnyF)_Base # AnyF
if This Line # Current Line start
Current Line = This Line
Dir2(Dir Line, Current Line) if Compiling Prim = 0
finish
if Diag&MonLine # 0 start
Select Output(Report)
Printstring("Line:"); Write(This Line, 1); Newline
Select Output(Directives Out)
finish
Display Knowledge if Diag&MonOpt # 0
Work Validity = Work Validity+1 {release work areas}
Value = Default Value {restore default values}
end
{Parameter and Format processing}
routine Terminate Block
integer J, N, M
record(Varfm)name V
if Amode < 0 and Amode # -16 start {format - align alternatives}
Falign = Alt Align {pass back nested alignment}
N = 0
if Falign = ¬0 start {no alignment needed}
N = Frame Extra
else if Falign = ¬1 {halfword alignment}
N = Frame Extra&2
finish
M = N
if N # 0 start {can adjust}
for J = Parms, 1, First Alt cycle
V == Var(J)
V_Disp = V_Disp-N
repeat
Max Frame = Max Frame-N
Frame = Frame-N
finish
Frame = Max Frame if Max Frame > Frame
if Amode = -2 start {end of alternative}
Old Frame = Frame {pass it back}
else {end of complete format}
Avar_Disp = ¬Falign {***align***}
Frame = (Frame+(¬Falign))&Falign
Avar_Format = Frame
Dir1(Dir Record Off)
finish
finish
Frame = Old Frame
end
routine Copy Old Display
integer T, J
routine Copy(integer Flag, To)
record(Stackfm)name F, T
F == Literal(0)
if Flag < 0 start
F_Base = Local;
else
F_Base = R8; F_Form = AutoI; Claim(F_Base)
Loadup(F)
finish
T == Local Integer(To)
Plant2(STR, F_Base, T)
Release and Drop Pair(F, T)
end
T = Local Display
for J = Danger Level, 1, Local-1 cycle
Copy(0, T); T = T+4
repeat
Copy(-1, T) {special for FP}
end
predicate Finish Params
integer J,
Mod = 0, {002}
Type, A, N
record(Varfm)name Ap, Fp, V
record(Stackfm)name S
Parameter Regs = 0
Parameter List = 0 {no longer in params or format}
Flush Diags and true if Amode < 0 {end of format}
Parameter Frame = Frame
if Avar_Flags&Answer # 0 and Avar_Flags&Defered = 0 and
(Avar_Type = Strings or Avar_Type = Records) start
{allocate a result parameter}
Parameter Frame = Parameter Frame+4
String Result = 4; Mod = Mod+4
finish
if Amode = 0 start {remember parameter registers}
N = R0
A = 4
while A < Parameter Frame cycle
S == Local Integer(A)
Remember(N, S); Drop(S)
Parameter Regs = Parameter Regs+1
A = A+4
exit if N = R3
N = N+1
repeat
finish
Frame = -20 {ready for local variables}
if Varbase # Vars start {parameters given}
Avar_Extra = Parms {first-1}
Avar_Area = Parameter Frame {size of parameter part of frame}
for J = Varbase+1, 1, Vars cycle
Ap == Var(J) {actual}
Parms = Parms-1
Fp == Var(Parms) {formal}
Ap_Base = Local
Fp = Ap
Fp_Base = Sp {WSP}
Fp_Form = AutoD
Fp_Disp = 0; Ap_Disp = Ap_Disp+Mod
Fp_Flags = Fp_Flags!Known Ass
Fp_Flags = Fp_Flags!Awanted if Ap_Form # Direct
Fp_Type = Integers if Fp_Type = Bytes or Fp_Type = Shorts
if Ap_Flags&Awanted # 0 and Amode = 0 and Ap_Form # PROC start
{string/record value parameter}
Ap_Flags = Ap_Flags-Awanted
V == Var(Max Vars); V = Ap
Frame = Frame-Item Size(Ap_Format)
V_Base = Local; V_Disp = Frame
Stack Var(Max Vars); Stack Var(J)
Type = Stack_Type; Stack_Type = Integers; Vmap(Stack, Type)
Assign(Equals)
Ap = V
finish
Ap_Flags = Ap_Flags!Known Ass if Ap_Flags&Parameter = 0
repeat
Flush Diags
finish
true if Amode # 0 {not a definition}
if Danger Marker # 0 start
Danger Level = Local if Danger Level = No Danger
finish
if Danger Level # No Danger start
Frame = Frame&(¬3)-4*(Local-Danger Level+1)
Local Display = Frame
Attributes = Attributes ! Attr Local Display ! Attr Inherit
finish
Copy old Display if Local Display # 0 {copy the display}
false {the body follows}
end
integerfn Tag
integer N
Readsymbol(N); N = Pending<<8+N
Readsymbol(Pending)
result = N
end
routine Get String(string(*)name Text)
integer J, Sym, Limit
Limit = Size of(Text)-1
Text = ""
for J = Pending, -1,1 cycle
Readsymbol(Sym)
Text = Text.Tostring(Sym) if Length(Text) < Limit
repeat
Readsymbol(Pending)
end
predicate On IEEE
{differentiates between VAX & IEEE by means of the position}
{of the sign bit in floating-point numbers}
integer Mone = -1
longreal M = Mone
byteinteger B = Byteinteger(Addr(M))
true if B = 0 or B = 16_BF
false
end
routine Convert Format(record(Stackfm)name V, integer Type)
real Single
integer A = V_Rhigh,
B = V_Rlow,
Fh, Fl, S, X
unless A = 0 = B or On IEEE start
{first dismantle VAX form of FP numbers}
Fh = (A&2_1111111)<<16 ! (A>>16) {top 23 bits of FP number}
FL = (B&16_FFFF) <<16 ! (B>>16) {low 32 bits of FP number}
X = (A>>7) {true exponent}
X = X&255-128
S = A>>15&1 {sign bit}
if Type = Lreals start
X = (X+1023-1)&2_111 1111 1111 {NS exponent}
B = (Fh&7)<<29 ! (Fl>>3)
A = S<<31 + X<<20 + (Fh>>3)&16_000FFFFF
else {reals}
X = (X+127-1)&2_1111 1111
A = S<<31 + X<<23 + Fh
B = 0
finish
else if Type = Reals {convert to short real}
Single = V_Rval
A = Integer(Addr(Single))
B = 0
finish
V_Rhigh = A
V_Rlow = B
end
routine To Short Real(record(Stackfm)name V)
integer X, Y, Exp, S
return if V_Rhigh = 0 = V_Rlow
if On IEEE start
Real(Addr(V_Rval)) = V_Rval
else
X = V_RHigh; S = X
Y = V_Rlow
Exp = ((X>>20)&2_111 1111 1111) - 1023 + 1 {true exponent}
Exp = Exp + 127 -1 {short format}
X = (X&2_0000 0000 0000 1111 1111 1111 1111 1111)<<3
X = X ! (Y>>(32-3)) {extra bits from mantissa}
X = X+1 if Y&16_1000 0000 # 0 {round it}
if X&16_0080 0000 # 0 start {need to normalise}
X = X>>1
Exp = Exp+1
finish
X = X ! (Exp&255)<<23
X = X ! 16_8000 0000 if S < 0
V_Rhigh = X
V_Rlow = 0
finish
end
include "realcon.inc"
integerfn Four Bytes
integer A,B,C,D
A = Pending
Readsymbol(B)
Readsymbol(C)
Readsymbol(D)
Readsymbol(Pending)
result = ((A<<8+B)<<8+C)<<8+D
end
routine Input Integer Value(integer Byte)
Constant Type = Integers
if Byte = 0 start
Value_Integer = Four Bytes
else
Value_Integer = Pending; Readsymbol(Pending)
finish
if Pending = 'U' start
Value_Integer = -Value_Integer
Readsymbol(Pending)
else if Pending = '¬'
Value_Integer = ¬Value_Integer
Readsymbol(Pending)
finish
Stack Integer(Value_Integer) unless Pending = 'A' {%or Pending = '$'}
end
routine Input Real Value
Constant Type = Reals
Value_Real = Real Constant
if Pending # 'A' and Pending # '$' start
Stack Integer(0)
unless Value_Real = 0 and (Pending = 'S' or Pending = '?') start
{preserve true zero}
{beware - a C-oid parameter 0.0 MUST retain}
{its real-ness otherwise the wrong amount}
{gets stacked}
Stack_Type = Lreals; Stack_Rval = Value_Real
Convert Format(Stack, Lreals)
finish
finish
end
routine Input String Value
record(Stackfm)name W
Constant Type = Strings
Get String(Value_String)
return if Pending = '$' or Pending = 'A'
if Length(Value_String) = 1 start
Stack Integer(Charno(Value_String, 1))
Stack_Bias = -1
else
W == Const String
W_Stack == Stack
Stack == W
finish
end
{Testing Predicates}
predicate InReg(record(Stackfm)name V)
false if V == Nil c
or V_Form # Address c
or V_Disp # 0 c
or V_Base = 0 c
or V_Area # 0 c
or V_Oper # 0 c
or V_Index ## Nil c
or V_Record ## Nil
true
end
predicate Floating(record(Stackfm)name V)
true if Reals <= V_Type <= Lreals or V_Oper >= RNEGx
false
end
predicate Same(record(Stackfm)name A, B)
true if A == B
false if A == Nil or B == Nil
false if A_Disp # B_Disp or
A_Base # B_Base or
A_Type # B_Type or
A_Form # B_Form or
A_Extra # B_Extra or
A_Area # B_Area
if A_Index ## Nil start
false unless B_Index ## Nil c
and A_Xsize = B_Xsize c
and Same(A_Index, B_Index) c
and A_Index_Oper = B_Index_Oper c
and Same(A_Index_Link, B_Index_Link)
else
false if B_Index ## Nil
finish
if A_Record ## Nil start
false unless B_Record ## Nil c
and Same(A_Record, B_Record) c
and A_Record_Oper = B_Record_Oper c
and Same(A_Record_Link, B_Record_Link)
else
false if B_Record ## Nil
finish
true
end
predicate Const(record(Stackfm)name V)
false if V_Form # Address or
V_Base # 0 or
V_Oper # 0 or
V_Index ## Nil or
V_Record ## Nil or
V_Area # 0
true
end
predicate Iconst(record(Stackfm)name V)
false if V == Nil c
or V_Form # Address c
or V_Base # 0 c
or V_Oper # 0 c
or V_Index ## Nil c
or V_Record ## Nil c
or V_Type > Addrs c
or V_Area # 0
true
end
predicate Iconst Item(record(Stackfm)name V)
{Same as ICONST but ignores the OPER field}
false if V == Nil c
or V_Form # Address c
or V_Base # 0 c
or V_Index ## Nil c
or V_Record ## Nil c
or V_Type > Addrs c
or V_Area # 0
true
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
record(Stackfm)map Claim Work Area(integer Bytes, Type)
record(Stackfm)name T
record(Workfm)name W, Best == NIL
integer P
Fail("claim work area/1") if Bytes <= 0
P = Work Base
cycle
if P = Last Work start {no suitable one available}
if Best == NIL start
Last Work = Last Work+1; Best == Work Area(Last Work)
Frame = (Frame-Bytes)&(¬3)
Best_Size = Bytes; Best_Displacement = Frame
finish
W == Best
exit
finish
P = P+1; W == Work Area(P)
Monitor N(P, "try work") if Diag&MonStack # 0
if W_Validity < Work Validity and W_Size >= Bytes start
exit if W_Size = Bytes
Best == W if Best == NIL or Best_Size > W_Size
finish
repeat
W_Validity = Work Validity {prevent its re-use}
Monitor N(W_Displacement, "temporary") if Diag&MonStack # 0
T == Literal(W_Displacement)
T_Base = Local; T_Type = Type; T_Form = Direct; T_Format = Bytes
result == T
end
routine Constant Bounds
Vub = Popped Value
Vlb = Popped Value
end
routine Set CD(integer Value, integername CD)
CD = Value&x'3FFF' if Value&x'C000' = 2<<14
end
Predicate Alternate format(integer Code)
integer Attr = 0
record(Varfm) Dummy
if Code = 'A' start {Start of alternatives}
Assemble(Dummy, -2, Vars, Local, -1, Attr)
Alt Align = Alt Align&Falign
else if Code = 'C' {Next alternative}
Max Frame = Frame if Frame > Max Frame
Frame = Frame Base
else if Code = 'B' {End of alternatives}
Frame = Max Frame if Max Frame > Frame
Falign = Alt Align
true
else
Fail("Format ".ItoS(Code, 0))
finish
false
end
routine Compile Begin
integer Main Ep = 0
record(Varfm) B
B = 0 {Dummy heading}
B_Type = Generals
B_Disp = New Label
B_Base = None {show an internal routine}
if Local # Base Local start {internal}
Stack Integer(B_Disp)
Stack_Flags = Stack_Flags!Nasty Proc if Local >= Danger Level
Call(0)
Ostate = 0
else
Ostate = External
External Id = "3L___main_program"
Entry Point = External No+1
Main Ep = 1
finish
Internal Id = "block"
Internal Id = Alias and Alias = "" if Alias # ""
Assemble(B, 0, Vars, Local+1, 0, Attributes)
end
routine Clear Vars(integer Limit)
Fail("Too many objects") if Limit >= Parms
while Vars < Limit cycle
Vars = Vars+1
Var(Vars) = 0
repeat
end
{Var control}
routine DIR String(integer Op, string(*)name S)
integer L = Length(S), J
Dir1(Op) if Op >= 0
Dir1(L)
Dir1(Charno(S, J)) for J = 1, 1, L
end
routine Dump External(integer Code, record(Varfm)name V)
External No = External No+1
if Code&1 = 0 start {spec}
if V_Form = Proc then V_Area = Dir Xcall and V_Disp = External No c
else V_Area = -External No and V_Disp = 0
finish
Code = Code!4 if Code&2 # 0 and V_Flags&Prim Proc # 0 {not Prim proc}
DIR String(Dir Ext, External Id)
Dir2(Code, V_Disp)
end
routine Plant Diag(record(Diagfm)name D)
integer Disp, Type, Ind, Base, BType, PType
record(Afm)name Dv
return if D_X&64 # 0 and D_Format&16_FFFF = 0
Disp = D_Var_Disp
Disp = D_Ext if D_Ext # 0 {external data}
Type = (D_X>>2)&15
if Interface_Options&LL Vars # 0 and Type # 14 start
Dir String(Dir Diag, D_Id)
Dump Encoded(D_X)
Dump Encoded(D_Xtype)
Dump Encoded(D_Var_Disp)
Dump Encoded(D_Format&16_FFFF) if D_X&64 # 0 {records}
finish
if DEBUG # 0 start
Base = D_X&3
Ind = D_X>>7
Btype = D_XType&15
PType = (D_XType>>4)&15
if Type = 14 start {Array}
Dir String(Dir DEBUG Array, D_Id)
Dv == D_Var_Adata
Dump Encoded(Dv_Bound(1)_Lower)
Dump Encoded(Dv_Bound(1)_Upper)
Dump Encoded(Dv_Total Size)
Dump Encoded(Btype) {base (element) type}
Dump Encoded(D_Format&16_FFFF) {Pointer to format}
else
return if Base # 1 and Base # 2
Dir String(Dir DEBUG Var, D_Id) {Variable identifier}
Dump Encoded(Type) {Primary type}
Dump Encoded(Ind) {Indirect bit - VAR}
Dump Encoded(Base) {Addressing base}
Dump Encoded(Btype) {Base type of pointer}
Dump Encoded(PType) {Type pointed at}
Dump Encoded(D_Var_Disp) {Displacement from base}
Dump Encoded(D_Format&16_FFFF) {Pointer to format}
Dump Encoded(Item Size(D_Var_Format)) {object size}
finish
finish
end
routine Dump Diag(integer Base, record(Qfm)name Q)
record(Diagfm) D
record(Diagfm)name ND
return if Compiling Prim # 0
D_Link == Diag List {here to prevent UNASS from VAX}
D_Id = Internal Id
D_Xtype = 0
D_Ext = 0
if Base = Any start
return if Parameter List = 0
Base = 0
D_Xtype = (Q_Dtype>>2)&15
Q_Dtype = 14<<2
else if Base = Local
Base = 1
else if Base = SB
Base = 2
else if Base < 0
D_Ext = -Base; Base = 3
else
Base = 0
finish
if Q == Nil start
D_X = 0
D_Format = 0
else
D_Format = Q_Dform
if Q_Pointed ## Nil start
D_Xtype = Q_Dtype>>2 ! (Q_Pointed_Dtype>>2&15)<<4
Q_Dtype = Q_Dtype ! 15<<2 ! Q_Pointed_Dtype&64 {escape}
D_Format = Q_Pointed_Dform
finish
D_X = Q_Ind<<7 ! Q_Dtype ! Base
finish
D_Var == DefV
return if D_Format = 0 and D_X&64 # 0 {record(*)name}
if Parameter List = 0 start {not in record or parameters}
Plant Diag(D)
else
ND == NEW(Diagfm Type)
SYY: ND = D
Diag List == ND {_Link set up above}
finish
end
routine Flush Diags
routine Flush(record(Diagfm)name D)
return if D == NIL
Flush(D_Link)
Plant Diag(D)
Dispose(D)
end
{The list is currently backwards - reverse it to preserve order}
Flush(Diag List)
Diag List == NIL
end
routine Define Var
integer Decl, Tf, NewV, Area, External Mode
integername At
integer Spec, Oflags, N,
Type, {external item type}
Form, {external item form}
Format {external item size or format}
record(Varfm)name Fv
record(Qfm) Q, Pq
record(Stackfm)name Vv
constbytearray Form Map(0:15) = 0, {Unknown}
Direct, {integer}
Indirect, {integername}
0(4), {label/format/?/switch}
Proc(4), {rt/fn/map/pred}
Direct, {array}
Direct, {arrayname}
Direct, {namearray}
Direct, {namearrayname}
0
routine Encode Type(integer Type, Format, record(Qfm)name Q)
switch T(-3:10)
constshortarray DiagMap(-3:10) =
5<<2 {-3}, 3<<2 {-2}, 2<<2 {-1},
0 {0},
1<<2 {1}, 4<<2 {2}, 6<<2 {3}, 7<<2!64 {4},
8<<2 {5}, 13<<2 {6}, 10<<2!64 {7}, 11<<2!64 {8},
12<<2 {9}, 9<<2 {10}
constbytearray TypeMap(-3:10) =
Lreals {-3}, Bytes {-2}, Shorts {-1},
Generals {0},
Integers {1}, Reals {2}, Strings {3}, Records {4},
Bytes {5}, Sets {6}, Bytes {7}, Shorts {8},
Integers {9}, Bytes {10}
constbytearray SizeMap(-3:10) =
WordLength*2 {-3}, 1 {-2}, 2 {-1},
WordLength*3 {0},
WordLength {1}, WordLength*1 {2}, 0 {3}, 0 {4},
1 {5}, Set Size {6}, 1 {7}, 2 {8},
WordLength {9}, 1 {10}
constbytearray AlgnMap(-3:10) =
3 {-3}, 0 {-2}, 1 {-1},
3 {0},
3 {1}, 3 {2}, 0 {3}, 0 {4},
0 {5}, 3 {6}, 0 {7}, 1 {8},
3 {9}, 0 {10}
if Type = 1 start {split integers}
if Format = 2 then Type = -2 {bytes} else c
if Format = 3 then Type = -1 {short}
else if Type = 2 {split reals}
if Format = 4 then Type = -3 {longreal}
finish
Fail("Unknown type") unless -3 <= Type <= 10
Q_Type = TypeMap(Type)
Q_Size = SizeMap(Type); DefV_Format = Q_Size
Q_Round = AlgnMap(Type)
Q_Bias = 0
Q_Dtype = DiagMap(Type)
Q_Dform = 0
Q_Format = Format
Q_Diags = 1 {assume diags are sensible}
Q_Ind = 0 {assume not indirect}
Q_Pointed == Nil
->T(Type)
T(0): {general} Q_Diags = 0; return
T(-3):{long}
T(1): {integer}
T(2): {real}
T(5): {boolean} DefV_Flags = DefV_Flags ! Checkable
T(-1):{short}
T(-2):{byte}
T(10):{char} return
T(3): {string} Q_Size = Format+1
DefV_Format = Q_Size
return
T(4): {record} Fv == Var(Format)
if Format > Vars start
Clear Vars(Format)
Interface_Formats = Interface_Formats+1
Fv_Area = Interface_Formats
else
Q_Size = Fv_Format
finish
DefV_Format = -Format
Q_Round = Fv_Disp {alignment required}
Q_Dform = Fv_Area {diagnostic index}
T(7): {byte enumerated} Q_Dform = Var(Format)_Area; return
T(8): {short enumerated} Q_Dform = Var(Format)_Area; return
T(9): {pointer} DefV_Flags = DefV_Flags ! Checkable
T(6): {set} if Q ## Pq start
Encode Type(Q_Dim, Format, Pq)
DefV_Format = SizeMap(Type) {restore it}
Q_Pointed == Pq
else
Q_Diags = 0
finish
if Type = 6 {sets} start
{beware of a checkable base type}
DefV_Flags = DefV_Flags & (¬Checkable)
finish
return
end {of encode type}
NewV = 1
Decl = Tag
if Decl # 0 start {normal item}
NewV = 0 if Decl <= Vars
DefV == Var(Decl); Clear Vars(Decl)
else {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) # 127 start
Internal Id = Internal Id.Tostring(Pending)
finish
Readsymbol(Pending)
repeat
Readsymbol(Pending)
Tf = Tag
Format = Tag
Ostate = Tag
Q_Dim = Ostate>>8
Spec = Ostate&8
Oflags = Ostate&16_F0
Ostate = Ostate&7; Ostate = External if Ostate = Dynamic
Type = Tf>>4&15
Form = Tf&15
if Alias # "" start
Ostate = External if Ostate = System
External Id = Alias; Alias = ""
else if Ostate = System
Ostate = External
External Id = "$".Internal Id
else
External Id = Internal Id
finish
External Mode = Ostate
if Form = 0 and Decl = 0 start {special for enumerated types}
Parms = Parms+1
Dump Diag(0, Nil)
return
finish
Encode Type(Type, Format, Q); Q_Diags = 0 if Internal Id = ""
DefV_Type = Q_Type
if Oflags&16 # 0 start {indirect}
DefV_Type = Integers; DefV_Format = 4
Q_Ind = 1; Q_Size = 4; Q_Round = Alignment; Q_Bias = 0
Form = 1
finish
Q_Bias = 0 if Form # 1
DefV_Flags = DefV_Flags!Checkable if Oflags&32 # 0
Decl Size = Q_Size
DefV_Form = Form Map(Form)
if Form = 4 start {recordformat}
DefV_Extra = Parms
Parameter Mode = -1; Block Type = -1
if DefV_Area = 0 start
Interface_Formats = Interface_Formats+1
DefV_Area = Interface_Formats {diagnostic index}
finish
return
else if Form = 3 {label}
Set User Label(Decl)
if Language Flags&Pascal Flag # 0 start
Save Wsp if Wsp Save = 0
DefV_Extra = Wsp Save
finish
else if Form = 6 {switch}
DefV_Area = Free Label-Vlb+1 {zero'th tag}
DefV_Disp = Vlb {lower bound}
DefV_Extra = Vub {upper bound}
N = Free Label+1
Free Label = N+Vub-Vlb
Constant Base = (Constant Base+3)&(¬3) {align it}
Select Constant Area
DefV_Format = Ca {address of vector}
Dump Word(Vub) {upper}
Dump Word(Vlb) {lower}
Dir3(Dir Swdef, N, Free Label)
Constant Base = Constant Base+4*(Vub-Vlb+1)
Select Code Area
else if 7 <= Form <= 10 {rt, fn, map, pred}
Parameter Mode = 1
Block Type = Spec {0=def, 8=spec}
if 8 <= Form <= 9 start {fn/map}
DefV_Flags = DefV_Flags!Answer
if Form = 9 start {map}
DefV_Flags = DefV_Flags!Defered
else if DefV_Type <= Addrs {integral function}
DefV_Type = Integers {all results integers}
finish
else if Form = 10 {predicate}
DefV_Flags = DefV_Flags!Pred Call
finish
if External Mode = OWN start
External Mode = External
Ostate = External
DefV_Flags = DefV_Flags ! Keep Local
else if External Mode >= Primrt
if External Mode = PrimRt start
Defv_Flags = Defv_Flags!Primitive
Defv_Prim = Q_Dim
else
Defv_Flags = DefV_Flags!Prim Proc
finish
External Mode = External
Ostate = External
finish
if Parameter List > 0 start {proc variable}
{beware - a spec will follow}
{which must not corrupt flags}
Danger Marker = 1
Frame = (Frame+3)&(¬3) {keep word aligned}
DefV_Disp = Frame
DefV_Base = Local
DefV_Flags = DefV_Flags!Parameter
Frame = Frame + Word Length*2
else if Local >= Danger Level
DefV_Flags = DefV_Flags!Nasty Proc
finish
else
if Form = 11 or Form = 13 start {array or namearray}
Q_Diags = 0
if Form = 13 start {namearray}
Decl Size = Word Length
Decl Size = Word Length*2 if Q_Type = Strings c
and Q_Size = 1 {string(*)%namearray}
DefV_Flags = Defered
Q_Round = Alignment
finish
Q_Size = 0 {no space allocated here}
else if Form = 2 {%name}
Q_Ind = 1
Q_Round = Alignment
if Q_Type # Generals start
Decl Size = Word Length
Decl Size = Word Length*2 if Q_Type = Strings c
and Q_Size = 1 {string(*)name}
Q_Size = Decl Size
finish
else if Form = 1 {simple variable}
if Parameter List > 0 and (Q_Type = Strings c
or Q_Type = Records c
or Q_Type = Sets) start
Q_Size = Word Length
DefV_Flags = DefV_Flags!Awanted if Oflags&16 = 0
finish
else {arrayname or namearrayname}
Q_Diags = 0
Q_Round = Alignment
Q_Size = Word Length*2
DefV_Flags = Defered if Form = 14 {namearrayname}
DefV_Flags = DefV_Flags!Arrayname
finish
if External Mode = 0 start {automatic}
DefV_Base = Local
if Decl = 0 start {record}
Frame = (Frame+Q_Round)&(¬Q_Round)
Defv_Disp = Frame; Frame = Frame+Q_Size
else if Parameter List > 0 {parameters}
Q_Round = 3 if Q_Round < 3
Q_Size = 4 if Q_Size < 4
Frame = (Frame+3)&(¬3) {keep parameters word aligned}
DefV_Disp = Frame
Frame = Frame+Q_Size
else
if Q_Size > 256 start {allocate dynamically}
Q_Ind = 1
Frame = Frame&(¬3)-4 {1 word slot}
DefV_Disp = Frame; DefV_Form = Indirect
DefV_Flags = DefV_Flags&(¬Checkable)
N = (Q_Size+3)&(¬3) {round up size}
Attributes = Attributes!Attr Sp Unknown
if Unassigned # 0 start {set it unassigned}
Attributes = Attributes!Attr Needs Gp
Vv == Literal(N)
Load(Vv, R4)
Release and Drop(Vv)
Prim(Dalloc) {alters SP}
else
Vv == Local Integer(-N)
Vv_Base = Sp; Vv_Form = Address
Load(Vv, Sp) {adjust Sp}
Drop(Vv)
finish
Vv == Local Integer(Frame)
Plant2(STR, Sp, Vv) {initialise pointer}
Release and Drop(Vv)
if wsp save # 0 start {done it, => wrong}
save wsp {do it again}
finish {quick hack}
else
Frame = Frame&(¬Q_Round)-Q_Size
DefV_Disp = Frame
finish
finish
DefV_Flags = DefV_Flags!Known Ass if Tf&256 # 0
Dump Diag(Local, Q) if Q_Diags#0 and Amode <= 0
else {own/external}
Ownextra = 0
if Spec = 0 start {definition}
Init Flag = 0
OwnType = Q_Type; OwnForm = Form
if External Mode = Con start {const something}
if Form = 2 {constname} c
or Form = 12 {constarrayname} c
or Form = 14 {constnamearrayname} start
DefV_Form = Direct
Init Flag = -1
return
finish
Constant Base = (Constant Base+3)&(¬3) {align it}
Area = Constant Area; At == Constant Base
DefV_Area = Constant Area
Q_Diags = 0
else {ownish}
Area = Own Area; At == Own Base; DefV_Base = Sb
if Form = 11 or Form = 13 start {array or namearray}
Own Array Base = (Own Array Base+3)&(¬3)
Area = Own Array Area; At == Own Array Base
Ostate = 255 {flag for INIT}
finish
finish
Ownextra = 1 if Ownform = 12 or Ownform = 14 {..arrayname}
Ownextra = 1 if Owntype = Strings c
and DefV_Format = 1 c
and (Ownform = 2 or Ownform = 13)
{string(*) name & namearray}
OwnType = Integers and Q_Round = 3 if OwnForm # 1 c
and OwnForm # 11
At = (At+Q_Round)&(¬Q_Round)
DefV_Disp = At
if Form = 11 or Form = 13 start {array or namearray}
DefV_Flags = DefV_Flags!Arrayname
N = DefV_Disp-Vlb*Decl Size {back to A(0)}
Own Base = (Own Base+3)&(¬3)
DefV_Base = SB; DefV_Disp = Own Base; DefV_Area = 0
Select Own Area
Dir4(Dir Header, Area>>8, N, 0); Ca = Ca+8
Select Code Area
Value = Default Value
Init Flag = 1
{dummy dope-vector}
DefV_Adata == New(A Type)
SYY: DefV_Adata = 0
finish
if External Mode = External start
Dump External(2_01, DefV)
DefV_Area = 0 {beware prior %spec}
DefV_Flags = DefV_Flags&(¬XData Spec) { " " " }
finish
Dump Diag(DefV_Base, Q) if Q_Diags # 0
else {external data spec}
DefV_Flags = DefV_Flags ! XData Spec
DefV_Flags = DefV_Flags!Arrayname if Form = 11 or Form = 13
Dump External(2_00, DefV)
finish
finish
finish
Alt Align = Alt Align&(¬Q_Round) {remember worst alignment}
Round = Q_Round
Dtype = Q_Dtype {remember for arrays (dimension)}
end
routine Dump Text(integer Max)
integer J, Len
Len = Length(Value_String)
if Max = 0 start {no upper limit}
Max = Len {use the actual length}
else {check the length}
Len = Max and Warn(0, "String truncated") if Len > Max
finish
Dump Byte(Len)
for J = 1, 1, Max cycle
if J > Len then Dump Byte(0) c
else Dump Byte(Charno(Value_String, J))
repeat
end
routine Adump
record(Stackfm) Rv
integer J, Disp, Key
if OwnType = Integers or OwnType = Addrs start
if Stack == Nil start {the easy case}
Dump Word(Value_Integer)
else
if Stack_Record ## NIL start
Fail("Adump/0")
else
Simplify(Stack)
Disp = Stack_Disp
Fail("Adump/1") unless Stack_Record== Nil and Stack_Index == Nil
if Stack_Form = Address start
if Stack_Base = SB start
Key = 0
else if Stack_Base = None
if Stack_Area = Constant Area start
Key = -1
else
Key = -Stack_Area
Fail("Adump/4") if Key <= 0
finish
finish else Fail("Adump/2")
Dir3(Dir Init, Key, Disp)
finish else Fail("Adump/3")
finish
Ca = Ca+4
Pop Release and Drop
finish
else if Owntype = Bytes or Owntype = Booleans
Warn(0, "value truncated to 8 bits unsigned") unless 0 <= Value_Integer <= 255
Dump Byte(Value_Integer)
else if OwnType = Shorts
Warn(0, "value truncated to 16 bits signed") unless 16_FFFF 8000 <= Value_Integer <= 16_0000 7FFF
Dump Half(Value_Integer)
else if OwnType = Reals or OwnType = Lreals
Rv_Rval = Value_Real; Convert Format(Rv, Owntype) {BEWARE: = 1.3(12) etc}
Dump Word(Rv_Rhigh)
Dump Word(Rv_Rlow ) if Owntype = Lreals
else if OwnType = Strings
Dump Text(Decl Size-1)
else if OwnType = Records or Owntype = Sets
Dump Byte(0) for J = 1, 1, Decl Size
finish else Fail("Init")
while Ownextra > 0 cycle
Dump Word(0)
Ownextra = Ownextra-1
repeat
end
routine Init(integer N)
if Stack ## Nil and Iconst(Stack) start
Value_Integer = Stack_Disp
Constant Type = Integers
Pop Release and Drop
finish
if Reals <= OwnType <= Lreals start
Value_Real = Value_Integer if Constant Type = Integers
finish
if Init Flag < 0 start {const?name}
DefV_Disp = Value_Integer
else
if Ostate = Con then Select Constant Area else c
if Ostate = 255 then Select Own Array Area c
else Select Own Area
while N > 0 cycle
N = N-1; Adump
repeat
Select Code Area
finish
Value = Default Value {Restore the default values}
DefV_Flags = DefV_Flags!Known Ass
end
routine Dimension(integer Dim, N)
{ %integerarray A(1:5) Base+Disp = Header (Direct) !Array!Static X=DV}
{ %integerarray B(1:N) Base+Disp = Header (Direct) !Arrayname }
{ %integerarray _C(1:5) Base+Disp = A(0) (Direct) !Array X=DV}
{ %integerarrayname D Base+Disp = Header (Direct) !Arrayname }
integer X, Static Array = 0, J
record(Varfm)name V
record(Afm) Dope
record(Stackfm)name B, Total, DopeVector, Zero, Header
record(Stackfm)name L1, L2, U1, U2, M1, M2
record(Qfm) Q
predicate All Const
record(Stackfm)name P
record(Boundfm)name B
integer J, N
P == Stack
N = Decl Size
for J = Dim, -1, 1 cycle
B == Dope_Bound(J)
false unless Iconst(P); B_Upper = P_Disp; P == P_Stack
false unless Iconst(P); B_Lower = P_Disp; P == P_Stack
B_Mult = N
N = B_Upper-B_Lower+1
Fail("Array inside-out") if N < 0
repeat
Dope_Total Size = N {remember final bound}
{A constant dope-vector}
Dope_Base = Local
Dope_Dimension = Dim
Dope_Zero Displacement = 0
N = 0
for J = 1, 1, Dim cycle
B == Dope_Bound(J)
Dope_Zero Displacement = Dope_Zero Displacement*N-B_Lower
N = B_Mult
Dope_Total Size = Dope_Total Size*N
repeat
Dope_Zero Displacement = Dope_Zero Displacement*N
Pop Release and Drop for J = 1, 1, Dim*2
Static Array = 1
Constant Base = (Constant Base+Alignment)&Alignment Mask
Dope_Dv = Constant Base
if Parameter List = 0 start
Dope_Total Size = (Dope_Total Size+3)&(¬3) {word align it}
finish
Select Constant Area
Dump Word(Dim)
Dump Word(Dope_Total Size)
Dump Word(Dope_Zero Displacement)
for J = 1, 1, Dim cycle
B == Dope_Bound(J)
Dump Word(B_Lower)
Dump Word(B_Upper)
Dump Word(B_Mult)
repeat
Select Code Area
true
end
Attributes = Attributes ! Attr Sp Unknown
{Create dope-vector}
if All Const start {constant dope-vector}
return if N = 0 {own dope vector}
if Parameter List # 0 start {in format}
X = Parms+N
Frame = (Frame+Round)&(¬Round)
while N > 0 cycle
N = N-1
X = X-1; V == Var(X)
V_Disp = Frame+Dope_Zero Displacement
Frame = Frame+Dope_Total Size
V_Form = Direct
V_Flags = V_Flags!Array
V_Adata == New(A Type)
SYY: V_Adata = Dope
if Debug # 0 start
Q_Dform = 0
Q_Dform = Var(-V_Format)_Area if V_Format < 0
Q_Pointed == NIL
Q_Ind = 0
Q_Dtype = Dtype
DefV == V
Dump Diag(Any, Q)
finish
repeat
return
finish
Zero == Nil
Zero == Literal(Dope_Zero Displacement) c
if Dope_Zero Displacement # 0
Total == Literal(Dope_Total Size)
DopeVector == Literal(Dope_Dv)
DopeVector_Form = Address; DopeVector_Area = Constant Area
Load(DopeVector, R3)
Load(Zero, R2) unless Zero == Nil
Load(Total, R1)
else {dynamic dope-vector}
if Dim = 1 start {special case fir 1 dimension}
U1 == Stack; Stack == U1_Stack {upper bound}
L1 == Stack; Stack == L1_Stack {lower bound}
M1 == Literal(Decl Size)
Load Trio(U1, R4, L1, R3, M1, R5)
Release and Drop Pair(L1, U1); Release and Drop(M1)
Prim(Dynamic 1)
else if Dim = 2 {special case for 2 dimensions}
U2 == Stack; Stack == U2_Stack {upper bound}
L2 == Stack; Stack == L2_Stack {lower bound}
M2 == Literal(Decl Size)
U1 == Stack; Stack == U1_Stack {upper bound}
L1 == Stack; Stack == L1_Stack {lower bound}
Load Pair(U1, R4, L1, R3)
Load Trio(U2, R7, L2, R6, M2, R8)
Load Pair(U1, R4, L1, R3)
Load Trio(U2, R7, L2, R6, M2, R8)
Release and Drop Pair(L1, U1)
Release and Drop Pair(L2, U2); Release and Drop(M2)
Prim(Dynamic 2)
else
X = Decl Size
for J = 1,1,Dim cycle
Push Literal(X); X = 0
B == Stack; Stack == B_Stack; Push(B); Release and Drop(B)
B == Stack; Stack == B_Stack; Push(B); Release and Drop(B)
repeat
Push Literal(0)
Push Literal(0)
Push Literal(Dim)
Prim(Dynamic N)
{returns with: R1 = Total size (rounded)}
{ R2 = Zero Displacement}
{ R3 = Dope Vector address}
finish
Total == Register(R1)
Zero == Register(R2)
DopeVector == Register(R3)
finish
{create the arrays}
{a head looks like: <address of A0> <address of dope-vector> }
{ ^ ^ }
{ V_Disp V_Disp+4 }
Frame = Frame & (¬3)
Header == Local Integer(Frame-Wordlength)
Load Address(Header, R4) {end of headers}
X = Vars-N
while N > 0 cycle
N = N-1
X = X+1; V == Var(X)
Frame = Frame-2*Wordlength
V_Disp = Frame {address of header}
V_Flags = V_Flags!Known Ass!ArrayName
V_Form = Direct
Plant1(SUB, Sp, Sp, Just(R1)) {claim space}
{This can be improved by using R4 or Sp for the zero'th address}
{but it needs dope-vectors to be the other way round?}
if Zero == NIL start
Plant1(MOV, 0, R0, Just(Sp))
else
Plant1(ADD, Sp, R0, Just(R2))
finish
Plant4(STM ! Write Back, R4, 16_0009) {STM_<R0,R3>, R0 = zero'th}
repeat
Release and Drop(Total)
Release and Drop(Zero) if Zero ## Nil
Release and Drop(DopeVector)
Release and Drop(Header)
end
routine Swop
record(Stackfm)name T
T == Stack
Stack == T_Stack
T_Stack == Stack_Stack
Stack_Stack == T
end
routine Define Range
integer T
record(Varfm)name V
T = Tag; V == Var(T); Clear Vars(T)
Constant Bounds; V_Disp = Vlb; V_Extra = Vub; V_Format = -1
end
routine Test Range(record(Stackfm)name S, record(Varfm)name V)
record(Stackfm)name R, L, U, Low, High
return if Interface_Options&LL Range = 0
if S_Type = Sets start
Low == Literal(V_Disp)
High == Literal(V_Extra)
Loadup(S) if S_Oper # 0
Build Set(S) if S_Members ## Nil
R == Copy(S); Amap(R)
Load Trio(Low, R1, High, R2, R, R0)
Prim(Set Range)
Release and Drop Pair(Low, High); Release and Drop(R)
return
finish
if Iconst(S) start
return if V_Disp <= S_Disp <= V_Extra
Warn(1, "Range violation")
finish
Loadup(S)
R == Copy(S) {so as not to destroy the register}
U == Literal(V_Extra)
if V_Disp # 0 start {use dynamic range}
L == Literal(V_Disp)
Load Trio(R, R1, L, R2, U, R3)
Prim(Dynamic Range)
Release and Drop(L)
else
Load Pair(R, R1, U, R3)
Prim(Check Range)
finish
Release and Drop Pair(R, U)
end
routine Duplicate
record(Stackfm)name V
V == Copy(Stack)
V_Stack == Stack
Stack == V
end
routine Stack Work Variable
integer T
record(Varfm)name V
T = Tag; V == Var(T); Clear Vars(T)
if V_Base = None start {a new one}
Frame = Frame&Alignment Mask-Wordlength
V_Type = Integers; V_Form = Direct
V_Base = Local; V_Disp = Frame
V_Flags = Known Ass
finish
Stack Var(T)
end
routine Claim With(integer N)
integer Format
record(Withfm)name W
W == NEW(Withfm Type)
W_Link == Withs; Withs == W
W_Key = N
if Stack_Index ## Nil or Stack_Record ## Nil c
or Stack_Form # Direct c
or not Locked(Stack_Base) start
Format = Stack_Format
Amap(Stack); Stab(Stack)
Stack_Format = Format
Stack_Flags = Stack_Flags ! Stored With
finish
W_Data = Stack_Data
Pop Release and Drop
end
routine Release With(integer N)
record(Withfm) Base
record(Withfm)name W == Base, X
Base_Link == Withs
while W_Link ## Nil cycle
if W_Link_Key = N start
X == W_Link
W_Link == X_Link
Withs == Base_Link
Dispose(X)
return
finish
W == W_Link
repeat
Fail("No use")
end
routine Use With(integer N)
integer Format
record(Withfm)name W == Withs
while W ## Nil cycle
if W_Key = N start
Stack Integer(0)
Stack_Data = W_Data
if Stack_Flags&Stored With # 0 start
Format = Stack_Format
Vmap(Stack, Integers)
Stack_Format = Format
finish
return
finish
W == W_Link
repeat
Fail("No use")
end
routine Build Set(record(Stackfm)name S)
record(Stackfm)name W, Z, OldLink
record(Memberfm)name M, X
recordformat Csetfm(bytearray Set(0:31)) {32*8 = 256}
record(Csetfm) C
integer Dumped = 0, Marked = 0, In Work = 0, Low, High, Op, OldOper
routine Dump Set
integer J
Dumped = 1
Constant Base = (Constant Base+3)&(¬3) {align it}
S_Type = Sets
S_Disp = Constant Base; S_Form = Direct; S_Area = Constant Area
Select Constant Area
Dump Byte(C_Set(J)) for J = 0, 1, 31
Select Code Area
end
routine Mark(integer N)
integer W
unless 0 <= N <= 255 start
Warn(1, "Set element out of range ".itos(N, 0))
return
finish
W = N>>3
C_Set(W) = C_Set(W) ! (1<<(N&7))
Marked = 1
end
Monitor(S, "Bset->") if Diag&Monoperand # 0
OldLink == S_Link; S_Link == NIL
OldOper = S_Oper; S_Oper = 0
C = 0
M == S_Members; S_Members == Nil
S_Flags = S_Flags&(¬Null Set)
while M ## Nil cycle
X == M; M == M_Link
if X_Const # 0 start
High = X_A_Disp; Drop(X_A)
if X_B == Nil start
Mark(High)
else
Low = X_B_Disp; Drop(X_B)
while Low <= High cycle
Mark(Low); Low = Low+1
repeat
finish
else
if In Work = 0 start
W == Claim Work Area(Set Size, Sets)
if Marked # 0 start
Dump Set if Dumped = 0
Set Assign(S, W)
Release(S_Base) {it's going to be copied over soon}
Marked = 0
else
Z == Literal(0); Z_Flags = Null Set
Set Assign(Z, W)
Release and Drop(Z)
finish
S_Data = W_Data
Drop(W)
Dumped = 1
In Work = 1
finish
Amap(S); Load Pair(S, R8, X_A, R1)
if X_B == Nil start
Op = Set Bit
else
Load Trio(X_B, R0, S, R8, X_A, R1)
Release and Drop(X_B)
Op = Set Bits
finish
Prim(Op)
Vmap(S, Sets); S_Flags = S_Flags ! Work Set
Release and Drop(X_A)
finish
Dispose(X)
repeat
Dump Set if Dumped = 0
S_Link == OldLink
S_Oper = OldOper
Monitor(S, "Bset<-") if Diag&MonOperand # 0
end
routine Compile In(integer Stack it)
integer N
record(Stackfm)name V, Set, C
Set == Stack; V == Set_Stack; Stack == V_Stack
Build Set(Set) if Set_Members ## Nil
Loadup(Set) if Set_Oper # 0
if Set_Flags&Null Set # 0 start
if Stackit # 0 start
C == Literal(0) {false}
C_Stack == Stack; Stack == C
else
Dump Word(16_E150 0000) {CMPS _ R0, R0 = cc equal = false}
finish
Release and Drop(Set); Release and Drop(V)
return
finish
if (Iconst(V) and 0 <= V_Disp <= 255) start
Advance(Set, Integers, (V_Disp>>5)<<2)
Operate(ANDx, Set, Literal(1<<(V_Disp&31)))
Test Zero(Set)
else
Amap(Set)
Load Pair(V, R1, Set, R2)
Prim(SetIn)
finish
Release and Drop Pair(Set, V)
Stack True or False(NE) if Stackit # 0
end
routine Add Member(integer N)
record(Memberfm) Base
record(Memberfm)name M, P
record(Stackfm)name A, B == Nil
integer Items = 0
A == Stack; Stack == A_Stack
if N # 0 start
B == Stack; Stack == B_Stack
if Iconst(A) and Iconst(B) and A_Disp < B_Disp start {empty}
Drop(A); Drop(B); return
finish
finish
M == NEW(Memberfm Type)
M_A == A
M_B == B
Items = Stack_Members_Items if Stack_Members ## NIL
if Iconst(A) and (B == Nil or Iconst(B)) start
M_Const = 1
M_Link == Stack_Members
Stack_Members == M
else
M_Const = 0
Base_Link == Stack_Members
P == Base
P == P_Link while P_Link ## Nil and P_Link_Const # 0
M_Link == P_Link
P_Link == M
Stack_Members == Base_Link
finish
Stack_Members_Items = Items+1
Stack_Flags = Stack_Flags&(¬Null Set)
end
routine Stack Data Size
integer T, N
T = Pending; Readsymbol(Pending)
if T = 0 start
T = Tag
N = Var(T)_Format
N = Var(-N)_Format if N < 0
else
if Undefined <= T <= Sets then N = Type Size(T) c
else N = 0
Fail("Unknown type") if N = 0
finish
Stack Integer(N)
end
routine Test for NIL
if Unassigned # 0 start
Stack_Flags = Stack_Flags!Known Ass
Load(Stack, R1)
Prim(TestNil) {tests NIL, Unassigned & Disposed}
finish
end
routine Set Variant Count(integer N)
record(stackfm)name V == Copy(Stack), Count
Vmap(V, Shorts)
Count == Literal(N)
Simple(Count, V)
Release and Drop Pair(Count, V)
end
routine Test Variant Count(integer N)
record(Stackfm)name V == Copy(Stack), Count
Count == Literal(N)
Vmap(V, Shorts)
Load Pair(V, R3, Count, R0)
Prim(Test Variant)
Release and Drop Pair(V, Count)
end
routine Check not long NEW
record(Stackfm)name V == Copy(Stack)
Amap(V); Vmap(V, Shorts)
Test Zero(V); Invert = 0
Prim(Test NEW)
Release and Drop(V)
end
routine Check Dynamic Bounds
record(Stackfm)name Lower, Upper
Upper == Stack; Lower == Upper_Stack; Stack == Lower_Stack
Load Trio(Stack, R1, Lower, R2, Upper, R3)
Prim(Dynamic Range)
Release and Drop Pair(Lower, Upper)
end
routine Localise
{STACK Loc; STACK size; Stack Zero; LOCALISE}
{Loc is a pointer to an area containing SIZE bytes}
{the area is copied into an anonymous local area and}
{Zero is the displacement of AREA(first) from Area(0)}
{i.e. Area(first) = Loc+Zero}
{Loc is updated to point to this local area}
record(Stackfm)name Loc, Size, Zero
Zero == Stack
Size == Zero_Stack
Loc == Size_Stack
Stack == Loc_Stack
Forget Destination(Loc)
Amap(Loc)
Load Trio(Size, R0, Zero, R1, Loc, R2)
Prim(MakeLocal)
Attributes = Attributes ! Attr Sp Unknown
Release and Drop Pair(Size, Zero)
Release and Drop(Loc)
end
routine End of Block
if Local # Base Local start {not first (dummy) call}
if Uncond Jump # Ca and Avar_Type = Generals and
Avar_Flags&Prim Proc = 0 start
Return(Routine)
finish
finish
end
routine Process Include File
Get String(Include File)
Dir String(Dir Include, Include File)
end
switch C(0:255)
At = 0
Pending Auto = 0
Old Frame = Frame
if Amode >= -1 start {procedure definition, format start}
Frame = 0 {ready for first field}
if Amode >= 0 start {procedure def}
Frame = 4 {ready for first parameter}
if Avar_Flags&Xproc Spec # 0 start {previous external spec}
Avar_Flags = Avar_Flags-Xproc Spec
Avar_Disp = 0
finish
Avar_Disp = New Label if Avar_Disp = 0 and
(Permrt # Ostate # External or Amode = 0)
if Amode = 0 start {entry to block}
if Local > Base Local + Max Nesting start
Fail("Subroutines nested too deeply")
finish
Uncond Jump = -1; Forget Everything
Dir2(Dir Start Block, Avar_Disp); Blocks = Blocks+1
DIR String(-1, Internal Id)
Fmark = Fmark+1; Frame Use(Local) = Fmark
if DEBUG # 0 start {001}
Dir3(Dir DEBUG Start Proc, {001}
0, {type} {001}
Current Line {source}) {001}
finish {001}
finish
if Ostate = External start
if Amode # 0 start {external spec}
Avar_Flags = Avar_Flags!Xproc Spec
Dump External(2_10, Avar)
else {external definition}
Avar_Flags = Avar_Flags!Xproc Def
N = 2_11
N = 2_11 ! 1<<4 if Avar_Flags&Keep Local # 0
Dump External(N, Avar)
Attributes = Attributes!Attr Xdef
if Avar_Flags&Prim Proc # 0 start
Attributes = Attributes!Attr Prim
finish
finish
finish
else
Dir2(Dir Record On, Avar_Area)
finish
finish
Frame Extra = Frame
Frame = (Frame+Alignment)&Alignment Mask
Frame Extra = Frame-Frame Extra
Frame Base = Frame
MyMark = Fmark
Max Frame = 0
Alt Align = ¬0
Pending Known Register = 0
Pending Auto = 0
->C('}') if Code = 'H' {special for BEGIN}
cycle
Code = Pending; Readsymbol(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(0); continue
c('F'): Jump Forward(Tag, Always); continue
c('G'): Get String(Alias); continue
c('H'): Compile Begin; continue
c('I'): Select Input(Icode In2); Readsymbol(Pending); 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(0); continue
c('O'): Update Line(Tag); continue
c('P'): Dump Byte(Popped Value&255); 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, Nil); 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, Nil); continue
c(']'): Operation(RSHx); continue
c('^'): Stack_Format = -Tag; 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('g'): Test for NIL; continue
c('h'): Special Call(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'): Do(Monitor Id, Monitor Ep, 0); continue
c('n'): Select(Tag); continue
c('o'): Event Trap(Tag); continue
c('p'): AssignParameter; continue
c('q'): Process Include File; continue
c('r'): Resolve(Tag); continue
c('s'): To Store(Tag); continue
c('t'): Jump Forward(Tag, TT); continue
c('u'): Aop; continue
c('v'): Operate(ABSx, Stack, Nil); 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, Attributes)
continue
c('}'): exit if Finish Params
Do("3L___stack_check", Stack Check, 0) if Interface_Options&LL Stack # 0
continue
c('~'): N = Pending; Readsymbol(Pending)
exit if Alternate Format(N); continue
{************ Extra Items **************}
c(128+'"'): Unsigned = 10; Stack Condition; continue
c(128+'?'): Unsigned = 10; Compare Values; continue
c(128+','): Max Frame = Frame if Frame > Max Frame
Frame = Frame Base; continue
c(128+'0'): N = Tag; {but no operation} continue
c(128+'1'): Add Member(0); continue
c(128+'2'): Add Member(1); continue
c(128+'3'): Set Variant Count(Tag); continue
c(128+'4'): Test Variant Count(Tag); continue
c(128+'5'): Check not long NEW; continue
c(128+'6'): Check Dynamic Bounds; continue
c(128+'/'): Operation(UDIVx); continue
c(128+'|'): Operation(UREMx); continue
c(128+'@'): Decode(0, -1) if Diag&Mon Code # 0
Current Line = Tag; continue
c(128+'A'): Amap(Stack); continue
c(128+'B'): if Pending = 't' then Pending = '#' c
else Pending = '='
Test Zero(Stack); Pop Release and Drop; continue
c(128+'C'): Unsigned = 0; Stack Condition; continue
c(128+'D'): Duplicate; continue
c(128+'E'): Loadup(Stack) unless Stack_Form = Address c
and Locked(Stack_Base) c
and Stack_Record == Nil c
and Stack_Index == Nil; continue
c(128+'F'): Stack_Format = -Tag; continue
c(128+'I'): Compile In(1); continue
c(128+'L'): Localise; continue
c(128+'M'): Operation(MODx); continue
c(128+'N'): Operation(REMx); continue
C(128+'O'): Apply Round(Stack); continue
c(128+'P'): Pop Release and Drop; continue
c(128+'R'): Define Range; continue
c(128+'S'): Swop; continue
c(128+'T'): Apply Trunc(Stack); continue
c(128+'U'): Use With(Tag); continue
c(128+'V'): Vmap(Stack, Tag); continue
c(128+'W'): Stack Work Variable; continue
C(128+'X'): Loadup(Stack) unless Stack_Type = Lreals; continue
c(128+'Z'): Stack Integer(0); Stack_Type = Sets
Stack_Flags = Null Set; continue
c(128+'['): Claim With(Tag); continue
c(128+']'): Release With(Tag); continue
c(128+'b'): Input Integer Value(1); continue
c(128+'c'): General Compare; continue
c(128+'e'): N = Stack_Type ; Amap(Stack)
Loadup(Stack) unless Stack_Form = Address c
and Locked(Stack_Base) c
and Stack_Index == Nil c
and Stack_Record == Nil
Vmap(Stack, N); continue
c(128+'f'): For Range == Var(Tag); continue
c(128+'g'): Call(1); continue
c(128+'i'): Compile In(0); continue
C(128+'n'): Apply Int(Stack); continue
c(128+'m'): General Move; continue
c(128+'o'): Owntype = Tag; continue
c(128+'p'): Fmap(Tag); continue
c(128+'r'): Test Range(Stack, Var(Tag)); continue
c(128+'s'): Set Size or Type(1, Stack); continue
c(128+'t'): Set Size or Type(2, Stack); continue
c(128+'v'): Compare Values; Prim(Test Variant); continue
c(128+'w'): Apply Intpt(Stack); continue
c(128+'z'): Stack Data Size; continue
c(128+'{'): Nn = 0
Assemble(AltV, -2, Vars, Local, -1, Nn)
Alt Align = Alt Align&Falign; continue
c(128+'}'): Frame = Max Frame if Max Frame > Frame
Falign = Alt Align; exit
repeat
Global Attributes = Global Attributes! (Attributes&Attr GLOBALS)
if Amode&8 = 0 start
Attributes = Attributes!Attr Inner Uses if Frame Use(Local) # MyMark
if DEBUG # 0 start {001}
Dir2(Dir DEBUG End Proc, Current Line {source}) {001}
finish {001}
Dir1(Dir End Block)
Dump Encoded(Frame&Alignment Mask-Aframe)
Dump Encoded(Code Base)
Dump Encoded(Parameter Frame)
Dump Encoded(Parameter Regs)
Dump Encoded(Display Vector(Local))
Dump Encoded(Local Display)
Dump Encoded(Array Base)
Dump Encoded(Attributes)
Dump Encoded(Entry Mask)
Dump Encoded(Event Bits&16_FFFF)
Dump Encoded(Event Label)
Dump Encoded(Event Body)
Forget Everything
Avar_Flags = Avar_Flags!Open
finish
Terminate Block
Display Vector(Local+1) = 0 unless Local = Display Limit
Danger Level = No Danger if Danger Level = Local
Pending Known Register = 0
Pending Auto = 0
Last Work = Work Base
return
C(*): Fail("Code ".Itos(Code, 0))
end
{Initialisation}
Activity(Sp) = -1 {lock the stack pointer}
Activity(Fp) = -1 {lock the frame pointer}
Activity(Sb) = -1 {lock the static base}
Compiling Prim = Interface_Prim
Unassigned = Interface_Options&LL Assigned
Debug = Interface_Options&LL Debug {001}
Own Base = 16 if Unassigned # 0
Pvar(J)_P == Nil for J = 0, 1, Var Top
!0.9! Ilabels(J) == NIL %for J = 0, 1, Max Label>>8
{0.9} Ilabels(J)_Label == NIL for J = 0, 1, Max Label>>8
Select Input(Icode In); Readsymbol(Pending)
Var(0) = 0
Default Value = 0 {*****make this unassigned later*****}
Value = Default Value
routine Initialise(record(Stackfm)name V, integer Base, Form)
V = 0
V_Base = Base
V_Type = Integers
V_Form = Form
V_Flags = Known Ass
end
Initialise(Ua Pat, Sb, Direct)
Initialise(Zero, 0, Address)
Initialise(One, 0, Address); One_Disp = 1
Initialise(SpV, Sp, Address)
begin
integer J
record(Stackfm)name R
for J = R0, 1, AnyF cycle
R == RegV(J)
R = 0
R_Base = J
R_Type = Integers
R_Form = Address
R_Format = Wordlength
if J >= F0 start
R_Type = Lreals
R_Format = Wordlength*2
finish
repeat
end
Knowing == Nil
Kasl == Nil
Select Output(Directives Out)
Parms = Max Vars {leaving Var(Max Vars) free}
Constant Base = 0
Free Label = 0
Section = 0
Assemble(Var(0), -16, 0, Base Local, 0, J) {Var(0) is a dummy}
Dump Encoded(Entry Point)
Dump Encoded(Control)
Dump Encoded(Min SB)
Interface_Ref Count = Refs
Interface_Def Count = Free Label
Interface_Block Count = Blocks
Interface_External Count = External No
Interface_Global Size = Own Base
Interface_Global Array Size = Own Array Base
Interface_Constant Size = Constant Base
begin {get rid of heap objects}
routine Monitor(string(255) Text)
Select Output(Report)
Printstring(Text); Newline
end
record(Vvfm)name V
Monitor("Dispose Vars") if Diag&MonLine # 0
while Var List ## NIL cycle
V == Var List; Var List == Var List_Link
DISPOSE(V)
repeat
record(Knowfm)name K
Monitor("Dispose Kasl") if Diag&MonLine # 0
while Kasl ## Nil cycle
K == Kasl; Kasl == Kasl_Link
DISPOSE(K)
repeat
record(Ilabelfm)name I
Monitor("Dispose Labels") if Diag&MonLine # 0
while Ilabel List ## NIL cycle
I == Ilabel List; Ilabel List == I_Link
DISPOSE(I)
repeat
record(WorkVfm)name W1, W2 == Work List_Link
Monitor("Dispose Work") if Diag&MonLine # 0
while W2 ## NIL cycle
W1 == W2; W2 == W2_Link
DISPOSE(W1)
repeat
Monitor("Disposed") if Diag&MonLine # 0
end
end
endoffile