Expression:
PROGRAM
IMPORTS CPtr: Code, MPtr: ComData, CodeDefs, ConvertUnsafe, IntCodeUtils, LiteralOps, P5, P5S, P5U, Real, SymbolOps, TreeOps
EXPORTS CodeDefs, P5
SHARES Rope =
BEGIN OPEN FOpCodes, CodeDefs, IntCodeDefs;
imported definitions
FieldBitCount: TYPE = Symbols.FieldBitCount;
WordCount: TYPE = Symbols.WordCount;
BitCount: TYPE = Symbols.BitCount;
firstMappedAddress: CARDINAL = PrincOps.wordsPerPage;
LocalHB: TYPE = OpCodeParams.LocalHB;
GlobalHB: TYPE = OpCodeParams.GlobalHB;
ExprOptions: CodeDefs.StoreOptions = [expr: TRUE, init: TRUE];
BitAddress: TYPE = Symbols.BitAddress;
CBTIndex: TYPE = Symbols.CBTIndex;
CBTNull: CBTIndex = Symbols.CBTNull;
ContextLevel: TYPE = Symbols.ContextLevel;
CSEIndex: TYPE = Symbols.CSEIndex;
CTXIndex: TYPE = Symbols.CTXIndex;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
lZ: ContextLevel = Symbols.lZ;
lG: ContextLevel = Symbols.lG;
LTIndex: TYPE = Literals.LTIndex;
CodeOper: TYPE = P5.CodeOper;
tb: Tree.Base; -- tree base (local copy)
seb: Symbols.Base; -- semantic entry base (local copy)
bb: Symbols.Base; -- body entry base (local copy)
cb: CodeDefs.Base; -- code base (local copy)
ltb: Literals.Base; -- literal base (local copy)
stb: Literals.Base; -- string base (local copy)
ExpressionNotify:
PUBLIC Alloc.Notifier =
BEGIN -- called by allocator whenever table area is repacked
seb ← base[Symbols.seType];
bb ← base[Symbols.bodyType];
tb ← base[Tree.treeType];
cb ← base[codeType];
ltb ← base[Literals.ltType];
stb ← base[Literals.stType];
END;
recentExp: PUBLIC Tree.Link; -- for debugging
ExpList:
PUBLIC
PROC [t: Tree.Link]
RETURNS [head, tail: NodeList ←
NIL] = {
OneExp: Tree.Scan = {
n: Node ← P5.Exp[t];
nl: NodeList ← P5U.MakeNodeList[n];
IF tail = NIL THEN head ← nl ELSE tail.rest ← nl;
tail ← nl};
TreeOps.ScanList[t, OneExp]};
LitKindForType:
PROC [type: Symbols.Type]
RETURNS [RefLitKind] = {
SELECT type
FROM
MPtr.typeATOM, MPtr.idATOM => RETURN[atom];
MPtr.idTEXT => RETURN[refText];
ENDCASE => RETURN[rope];
};
BitsForStringRep:
PROC [string:
LONG
STRING]
RETURNS [BitCount] = {
chars: LONG CARDINAL ← string.length;
RETURN[(chars+4)*CharSize]};
RopeHoldingStringRep:
PROC [string:
LONG
STRING]
RETURNS [ByteSequence] = {
nchars: CARDINAL ← string.length;
chars: Rope.Text ← z.NEW[Rope.TextRep[nchars + 4]];
lengthrep:
RECORD[
SELECT
OVERLAID *
FROM
-- very host machine dependent
bytes => [b: PACKED ARRAY [0..1] OF CHAR],
card => [w: CARDINAL],
ENDCASE] ← [card[nchars]];
chars[0] ← chars[2] ← lengthrep.b[0];
chars[1] ← chars[3] ← lengthrep.b[1];
FOR i:
CARDINAL
IN [0..nchars)
DO
chars[4+i] ← string[i];
ENDLOOP;
RETURN[chars]};
Exp:
PUBLIC
PROC [t: Tree.Link]
RETURNS [l: IntCodeDefs.Node] =
BEGIN -- generates code for an expression
node: Tree.Index;
WITH e: t
SELECT
FROM
literal =>
WITH e.index
SELECT
FROM
word => RETURN [P5U.MakeNodeLiteral[LiteralOps.Value[lti]]];
string => {
BEGIN
msti: Literals.MSTIndex = LiteralOps.MasterString[sti];
string: LONG STRING ← @stb[msti].string;
WITH s: stb[sti]
SELECT
FROM
heap =>
RETURN[z.
NEW[NodeRep.const.refLiteral ←
[bits: PtrSize, details: const[data: refLiteral[
litKind: LitKindForType[s.type],
contents: ConvertUnsafe.ToRope[string]]]]]];
ENDCASE => {
body: Node ← z.
NEW[NodeRep.const.bytes ← [
bits: BitsForStringRep[string], details: const[bytes[RopeHoldingStringRep[string]]]]];
RETURN[P5U.ApplyOp[oper: P5U.MesaOpNode[addr], args: P5U.MakeNodeList[body], bits: PtrSize]];
};
END;
};
string => RETURN [Lexeme[literal[string[sti]]]];
ENDCASE;
symbol => {
sei: ISEIndex = e.index;
IF ~seb[sei].constant THEN RETURN[VarForSei[e.index]];
SELECT SymbolOps.XferMode[seb[sei].idType]
FROM
proc => {
-- get the label for the proc
bti: CBTIndex = seb[sei].idInfo;
op: CodeOper ← z.NEW[OperRep.code ← [code[label: NIL, offset: 0]]];
P5.FillProcLabel[op: op, bti: bti];
l ← z.NEW[NodeRep.oper ← [bits: ProcSize, details: oper[op]]];
RETURN[l];
};
signal, error => RETURN[NIL]; -- what to do here?
program => RETURN[NIL]; -- what to do here?
ENDCASE => ERROR;
};
subtree =>
BEGIN
recentExp ← t;
IF e = Tree.Null
THEN
RETURN[IF CPtr.xtracting THEN CPtr.xtractNode ELSE CPtr.caseCV];
node ← e.index;
SELECT tb[node].name
FROM
casex => l ← P5.CaseStmtExp[node, TRUE];
bindx => l ← P5.BindStmtExp[node, TRUE];
assignx => l ← P5S.AssignExp[node];
extractx => l ← P5S.ExtractExp[node];
plus => l ← Plus[node];
minus => l ← Minus[node];
div => l ← Div[node];
mod => l ← Mod[node];
times => l ← Times[node];
dot, uparrow => l ← DotOrUparrow[node];
reloc => l ← Reloc[node];
dollar => l ← Dollar[node];
uminus => l ← UMinus[node];
addr => l ← Addr[node];
index => l ← P5S.Index[node];
dindex => l ← P5S.DIndex[node];
construct => l ← P5.Construct[Tree.Null, node, ExprOptions];
arraydesc => l ← ArrayDesc[node];
length => l ← Length[node];
base => l ← Base[node];
body => l ← P5S.BodyInit[node];
rowcons => l ← P5.RowCons[Tree.Null, node, ExprOptions];
stringinit => l ← P5S.StringInit[node];
pad =>
BEGIN
psei: CSEIndex = SymbolOps.UnderType[tb[node].info];
bits: BitCount ← P5U.FullWordBits[P5U.BitsForType[psei]];
cl: CodeList ← P5U.NewCodeList[];
tv: Var ← P5U.MakeTemp[cl: cl, bits: bits, init: P5.Exp[t]].var;
P5U.MoreCode[cl, tv];
l ← P5U.MakeBlock[cl, bits];
END;
ord, val, cast, loophole => l ← Exp[tb[node].son[1]];
safen => l ← Safen[node];
seqindex => l ← P5S.SeqIndex[node];
item => l ← Exp[tb[node].son[2]];
callx, portcallx => l ← P5S.CallExp[node];
substx => l ← P5S.SubstExp[node];
signalx => l ← P5S.SigExp[node];
errorx => l ← P5S.ErrExp[node];
syserrorx => l ← P5S.SysErrExp[node];
startx => l ← P5S.StartExp[node];
new => l ← P5.New[node];
listcons => l ← P5.ListCons[node];
create => l ← P5S.Create[node];
mwconst => l ← MwConst[node];
fork => l ← P5S.ForkExp[node];
joinx => l ← P5S.JoinExp[node];
float => l ← Float[node];
narrow => l ← P5.NarrowExp[node];
check => l ← P5U.BoundsCheck[Exp[tb[node].son[1]], Exp[tb[node].son[2]]];
proccheck => l ← P5S.ProcCheck[node];
chop =>
BEGIN
bits: BitCount = P5U.BitsForType[tb[node].info];
l ← P5U.TakeField[n: Exp[tb[node].son[1]], vl: [disp: 0, size: bits]];
END;
all => l ← P5.All[Tree.Null, node, ExprOptions];
gcrt => l ← P5.GetCanonicalType[node];
ENDCASE => l ← P5.FlowExp[node];
END;
ENDCASE;
RETURN
END;
VarForSei:
PUBLIC
PROC [sei: ISEIndex]
RETURNS [l: Var] = {
loc: Location;
ctx: CTXIndex ← seb[sei].idCtx;
level: ContextLevel ← SymbolOps.CtxLevel[ctx];
id: INT ← LONG[LOOPHOLE[sei, CARDINAL]];
SELECT level
FROM
lZ => ERROR;
lG => loc ← z.NEW[globalVar LocationRep ← [globalVar[id: 0]]];
ENDCASE => loc ← z.NEW[localVar LocationRep ← [localVar[id: 0, parent: P5.visibleContext[level]]]];
l ← P5U.MakeVar[bits: LONG[LOOPHOLE[seb[sei].idInfo, CARDINAL]], id: id, loc: loc];
};
BinaryOp:
PROC [node: Tree.Index, op: ArithSelector]
RETURNS [l: Node] =
BEGIN -- generate code for +, -, *, /, etc.
op1, op2: Node;
op1 ← Exp[tb[node].son[1]];
op2 ← Exp[tb[node].son[2]];
l ← P5U.ApplyOp[oper: P5U.ArithOpForTree[node, op], args: P5U.MakeNodeList2[op1, op2], bits: op1.bits];
END;
Plus:
PROC [node: Tree.Index]
RETURNS [l: Node] = {
RETURN[BinaryOp[node, add]]};
Minus:
PROC [node: Tree.Index]
RETURNS [l: Node] = {
RETURN[BinaryOp[node, sub]]};
UMinus:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generate code for (unary) -
op1: Node;
op1 ← Exp[tb[node].son[1]];
l ← P5U.ApplyOp[oper: P5U.ArithOpForTree[node, neg], args: P5U.MakeNodeList[op1], bits: op1.bits];
END;
Times:
PROC [node: Tree.Index]
RETURNS [Node] = {
RETURN[BinaryOp[node, mul]]};
Div:
PROC [node: Tree.Index]
RETURNS [Node] = {
RETURN[BinaryOp[node, div]]};
Mod:
PROC [node: Tree.Index]
RETURNS [Node] = {
RETURN[BinaryOp[node, mod]]};
Float:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN
op1: Node;
op1 ← Exp[tb[node].son[1]];
l ← P5U.ApplyOp[oper: P5U.ConvertOpNode[from: longSigned, to: shortReal], args: P5U.MakeNodeList[op1], bits: op1.bits];
END;
Safen:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN
cl: CodeList ← P5U.NewCodeList[];
nt: Tree.Link;
nt ← P5U.ProcessSafens[cl, [subtree[node]]];
l ← Exp[nt];
RETURN[P5U.MaybeBlock[cl, l]];
END;
Addr:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generates code for "@"
op1: Node = Exp[tb[node].son[1]];
l ← P5U.ApplyOp[oper: P5U.MesaOpNode[addr], args: P5U.MakeNodeList[op1], bits: PtrSize];
END;
ArrayDesc:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- pushes two components of an array descriptor onto stack
subNode: Tree.Index = TreeOps.GetNode[tb[node].son[1]];
long: BOOL ← tb[node].attr2;
base: Node ← Exp[tb[subNode].son[1]];
length: Node ← Exp[tb[subNode].son[2]];
loc: Location ← z.NEW[composite LocationRep ← [composite[P5U.MakeNodeList2[base, length]]]];
l ← z.NEW[var NodeRep ← [bits: 2*WordSize, details: var[location: loc]]];
END;
Length:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generates code to extract length from array descriptor
relocs need not apply
ad: Node = Exp[tb[node].son[1]];
loc: Location ← z.NEW[field LocationRep ← [field[base: ad, start: WordSize]]];
l ← P5U.MakeVar[bits: WordSize, loc: loc];
END;
Base:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generates code to extract base from array descriptor
relocs get converted to addr
ad: Node = Exp[tb[node].son[1]];
loc: Location ← z.NEW[field LocationRep ← [field[base: ad, start: 0]]];
l ← P5U.MakeVar[bits: PtrSize, loc: loc];
END;
DerefLocation:
TYPE =
REF deref LocationRep;
FieldLocation:
TYPE =
REF field LocationRep;
DotOrUparrow:
PROC [mainnode: Tree.Index]
RETURNS [l: Node] =
BEGIN
generate code for "exp.field"
t1: Tree.Link = tb[mainnode].son[1];
ptr: Node ← Exp[t1];
nilCheck: BOOL;
derefLoc: DerefLocation ← z.NEW[deref LocationRep ← [deref[addr: ptr]]];
derefVar: Var ← P5U.MakeVar[bits: size, loc: derefLoc];
field: VLoc;
size: FieldBitCount;
end: WordCount;
IF tb[mainnode].name = uparrow
THEN
BEGIN
end ← P5U.WordsForSei[tb[mainnode].info];
size ← end*WordSize;
l ← derefVar; l.bits ← size;
END
ELSE
BEGIN
sei: ISEIndex = TreeOps.GetSe[tb[mainnode].son[2]];
psei: CSEIndex = SymbolOps.NormalType[P5U.OperandType[t1]];
offset: BitAddress;
size: FieldBitCount;
[offset: offset, size: size] ← SymbolOps.RecField[sei];
end ← P5U.WordsForBits[P5U.Bits[offset]+size];
field ← [disp: P5U.Bits[offset], size: size];
WITH seb[psei]
SELECT
FROM
ref =>
BEGIN OPEN SymbolOps;
rcsei: CSEIndex = UnderType[refType];
if we point to a type, it fills a number of full words
WITH seb[rcsei]
SELECT
FROM
record =>
field ← P5U.AdjustLoc[vl: field, rSei:
LOOPHOLE[rcsei],
fSei: sei, tBits: P5U.FullWordBits[P5U.BitsForType[rcsei]]];
ENDCASE;
END;
ENDCASE => P5.P5Error[642];
l ← P5U.TakeField[n: derefVar, vl: field];
END;
IF tb[mainnode].attr1
THEN
BEGIN -- nil checking, see if hardware will do it
tsei: CSEIndex = SymbolOps.UnderType[tb[mainnode].info];
nilCheck ← ~MPtr.switches['a]
OR
end > firstMappedAddress
OR (
WITH t: seb[tsei]
SELECT
FROM
sequence => TRUE,
array => SymbolOps.WordsForType[tsei] NOT IN (0..OpWordCount.LAST],
record, union => tb[mainnode].name = uparrow,
ENDCASE => FALSE);
END
ELSE nilCheck ← FALSE;
IF nilCheck
THEN {
nc: Node = P5U.ApplyOp[oper: P5U.MesaOpNode[nilck], args: P5U.MakeNodeList[ptr], bits: PtrSize];
derefLoc.addr ← nc};
END;
AdjustNilCheck:
PUBLIC
PROC [t: Tree.Link, wordOffset:
CARDINAL] =
BEGIN -- used by SeqIndex to suppress nil check if bound (at offset) is checked
SELECT TreeOps.OpName[t]
FROM
dollar => AdjustNilCheck[TreeOps.NthSon[t, 1], wordOffset];
dot, uparrow =>
IF MPtr.switches['a]
AND wordOffset < firstMappedAddress
THEN
BEGIN
subNode: Tree.Index = TreeOps.GetNode[t];
tb[subNode].attr1 ← FALSE;
END;
ENDCASE;
END;
Reloc:
PUBLIC
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generates code for "baseptr[relptr]"
base: Node ← Exp[tb[node].son[1]];
relptr: Node ← Exp[tb[node].son[2]];
sum: Node;
IF tb[node].attr1
THEN
BEGIN -- reloc of an array descriptor
field: FieldLocation ← z.NEW[field LocationRep ← [field[base: relptr, start: 0]]];
relptr ← P5U.MakeVar[bits: PtrSize, loc: field];
END;
sum ← P5U.ApplyOp[oper: P5U.ArithOpForTree[node, add], args: P5U.MakeNodeList2[base, relptr], bits: PtrSize];
l ← P5U.Deref[n: sum, bits: SymbolOps.WordsForType[tb[node].info]*WordSize];
END;
Dollar:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- generates code for "exp$field"
sei: ISEIndex = TreeOps.GetSe[tb[node].son[2]];
rec: Node;
field: FieldLocation← NIL;
rcsei: RecordSEIndex = LOOPHOLE[P5U.OperandType[tb[node].son[1]]];
functionCall: BOOL = seb[rcsei].argument;
offset: BitAddress;
size: FieldBitCount;
vl: VLoc;
rec ← Exp[tb[node].son[1]];
IF functionCall THEN [offset, size] ← SymbolOps.FnField[sei]
ELSE [offset, size] ← SymbolOps.RecField[sei];
vl ← [disp: P5U.Bits[offset], size: size];
IF rec.bits < WordSize
THEN
vl ← P5U.AdjustLoc[vl: vl, rSei: rcsei, fSei: sei, tBits: rec.bits];
l ← P5U.TakeField[n: rec, vl: vl];
END;
MwConst:
PROC [node: Tree.Index]
RETURNS [l: Node] =
BEGIN -- puts multi-word constant out to code stream
lti: LTIndex = LiteralOps.WordIndex[NARROW[tb[node].son[1], Tree.Link.literal].index];
WITH ll: ltb[lti]
SELECT
FROM
short => l ← P5U.MakeNodeLiteral[LiteralOps.Value[lti]];
long =>
BEGIN
SELECT ll.length
FROM
0 => P5.P5Error[649];
1 => l ← P5U.MakeNodeLiteral[ll.value[0]];
2 => {
idw:
RECORD [
SELECT
OVERLAID *
FROM
twoWords => [v1, v2: WORD],
int => [i: INT],
ENDCASE];
idw.v1 ← ll.value[0];
idw.v2 ← ll.value[1];
l ← P5U.MakeNodeLiteral[idw.i]};
ENDCASE =>
l ← NIL; -- REMOVE
BEGIN
nwords: CARDINAL = ll.length;
IF ll.codeIndex = 0 THEN
BEGIN
ll.codeIndex ← P5.MoveToCodeWord[];
FOR i: CARDINAL IN [0..nwords) DO P5.WriteCodeWord[ll.value[i]] ENDLOOP;
P5U.RecordConstant[ll.codeIndex, nwords];
END;
var ← [wSize: nwords, space: code[wd: ll.codeIndex, lti: lti]];
END;
END;
ENDCASE => ERROR; -- to keep the compiler happy
END;
MultiZero:
PUBLIC
PROC [t: Tree.Link, minWords:
CARDINAL]
RETURNS [
BOOL] =
BEGIN
IF TreeOps.OpName[t] = mwconst
THEN
BEGIN
s: Tree.Link = TreeOps.NthSon[t, 1];
WITH s
SELECT
FROM
literal =>
WITH l: index
SELECT
FROM
word =>
BEGIN
lti: LTIndex = l.lti;
WITH ll: ltb[lti]
SELECT
FROM
long =>
FOR i:
CARDINAL
IN [0 .. ll.length)
DO
IF ll.value[i] # 0 THEN EXIT;
REPEAT
FINISHED => RETURN [ll.length >= minWords]
ENDLOOP;
ENDCASE;
END;
ENDCASE;
ENDCASE;
END
ELSE
IF minWords <= 1
AND P5U.TreeLiteral[t]
THEN
RETURN [P5U.TreeLiteralValue[t] = 0];
RETURN [FALSE]
END;
RealConst:
PUBLIC
PROC [t: Tree.Link]
RETURNS [
BOOL, Real.Extended] =
BEGIN
IF TreeOps.OpName[t] = mwconst
THEN
BEGIN
s: Tree.Link = TreeOps.NthSon[t, 1];
v: ARRAY [0..2) OF WORD;
lti: LTIndex = LiteralOps.WordIndex[NARROW[s, Tree.Link.literal].index];
WITH ll:ltb[lti]
SELECT
FROM
long =>
SELECT ll.length
FROM
2 => {v[0] ← ll.value[0]; v[1] ← ll.value[1]};
ENDCASE => ERROR;
ENDCASE => ERROR;
RETURN [TRUE, Real.RealToExtended[LOOPHOLE[v]]]
END;
RETURN [FALSE, [nan, FALSE, 0, 0]]
END;
END.