DIRECTORY
Basics USING [LongNumber, ShortNumber, BITAND],
IO,
Rope,
VM USING [AddressForPageNumber, SimpleAllocate],
MicroDefs,
MicroGlobalVars,
MicroOps, -- lots and lots
MicroUtils
USING [
AtomAtPointer, GetCharAtPointer, GetSymbolMemSink, GetSymbolMemSource,
MoveBlock, PutCharAtPointer];
MicroProcessImpl:
CEDAR
PROGRAM
IMPORTS
Basics, IO, Rope, VM,
MicroDefs, MicroGlobalVars, MicroOps, MicroUtils
= BEGIN OPEN MicroDefs, MicroGlobalVars;
expansionPtr: LONG POINTER TO WORD ← NIL;
stmtTooLong: ROPE = "Statement too long\n";
Expand packed values
ExpandLength:
PUBLIC
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER]
RETURNS[len: INTEGER] = TRUSTED {
Returns the length of an expanded block, or -1 if no encoded data
ptr: LONG POINTER TO WORD ← aPtr + lx;
any: BOOL ← FALSE;
len ← lx;
UNTIL ptr = aPtr
DO
ptr ← ptr - 1;
IF ptr^ >= 40B THEN LOOP;
any ← TRUE;
len ← ExpandSize[(ptr-1)^, ptr^] + len - 2;
ptr ← ptr - 1;
ENDLOOP;
RETURN[IF any THEN len ELSE - 1];
};
Expand:
PUBLIC
PROC[argRef: ArgRef]
RETURNS[didExpansion:
BOOL] =
TRUSTED {
Expand a block possibly containing encoded data;
Returns TRUE iff expansion actually occurred
Since Expand is only called for immediate use, we can re-use the same storage if expansion is necessary (claim as of 15 Oct)
len: INTEGER;
rPtr, ptr: LONG POINTER TO WORD;
aPtr: LONG POINTER TO WORD ← argRef.aPtr;
lx: INTEGER ← argRef.lx;
IF lx < 2 THEN RETURN[FALSE];
len ← ExpandLength[aPtr, lx];
IF len = -1 THEN RETURN[FALSE];
rPtr ← expansionPtr+len; -- temp storage for expansion
ptr ← aPtr + lx;
UNTIL ptr = aPtr
DO
ptr ← ptr - 1;
IF ptr^ >= 40B
THEN { rPtr ← rPtr - 1; rPtr^ ← ptr^}
ELSE {
n: INTEGER = ExpandSize[(ptr-1)^, ptr^];
rPtr ← rPtr - n;
ExpandValue[(ptr-1)^, ptr^, rPtr];
ptr ← ptr - 1;
};
ENDLOOP;
argRef.aPtr ← expansionPtr;
argRef.lx ← len;
RETURN[TRUE];
};
ProcessOneClause:
PUBLIC
PROC[evalMode: EvalMode] =
TRUSTED {
val: INTEGER;
typ: SymbolType;
oldTailTop: NAT = stmtTailTop;
oldTailBottom: NAT = stmtTailBottom;
gotoOuter: BOOL ← FALSE;
stmtTailTop ← stmtTailBottom;
DO
-- lp label in micproc.pr1
{
terminator: CHAR;
tailOld: NAT ← stmtTailBottom;
[] ← LexicalScan[FALSE, stmtTailTop];
terminator ← MicroOps.GetStmtChar[stmtBufferTop-1];
IF stmtTailBottom # tailOld
THEN {
IF ( MicroOps.GetStmtValue[stmtTailTop-1] < 40B)
AND (tailOld # stmtTailTop)
THEN {
expand old value
thisBot: NAT= stmtTailBottom;
ExpandTail[stmtTailTop];
tailOld ← tailOld + stmtTailBottom - thisBot; -- adjust for expanded value
};
DO
-- sym label in micproc.pr1
Process symbol just found by scanner, set val and typ
Val, Typ may be:
int value (valmode, fldmode only)
adr ep (valmode, fldmode only)
und ep (fldmode only)
tailNew: NAT ← stmtTailBottom;
addr: NAT ← stmtTailBottom;
nChars: NAT ← tailOld - stmtTailBottom;
symIndex: INTEGER;
sAtom: ATOM;
stmtTailBottom ← tailOld;
IF MicroOps.GetStmtValue[tailOld-1] < 40B
THEN {
SELECT MicroOps.GetStmtChar[tailOld-1]
FROM
symc => symIndex ← MicroOps.GetStmtInteger[tailOld-2];
< 40C => symIndex ← 1;
ENDCASE =>
[symIndex, sAtom] ← MicroOps.LookupSymbol[stmtBuffer+addr, nChars];
}
ELSE [symIndex, sAtom] ← MicroOps.LookupSymbol[stmtBuffer+addr, nChars];
SELECT symIndex
FROM
0 => {
Look inside symbol name
numOK: BOOL ← FALSE;
IF MicroOps.GetStmtChar[tailOld-1] = '←
THEN {
might be a store
symIndex ← MicroOps.LookupSymbol[stmtBuffer+addr, nChars-1].symIndex;
IF (symIndex # 0)
AND (MicroOps.GetSymbol[symIndex].sType = addressType)
THEN {
aPtr: LONG POINTER TO WORD ← MicroOps.ArgString[2];
aPtr^ ← symIndex;
MicroUtils.PutCharAtPointer[aPtr+1, symc];
MicroOps.MacroCall[MicroUtils.GetSymbolMemSink[symIndex], 1];
GOTO loop;
};
}
ELSE {
-- Try for a number
sgn: NAT ← 0;
ovf: BOOL ← FALSE;
addr1, end: NAT;
char: CHAR;
val ← 0;
IF (char ← MicroOps.GetStmtChar[addr]) = '- THEN sgn ← 1;
addr1 ← addr + sgn;
end ← addr + nChars;
WHILE (addr1#end)
AND ((char ← MicroOps.GetStmtChar[addr1])
IN ['0..'7])
DO
IF Basics.BITAND[LOOPHOLE[val], 160000B]#0 THEN ovf ← TRUE;
val ← val*8 + (char - '0);
addr1 ← addr1 + 1;
ENDLOOP;
IF addr1#(addr+sgn)
THEN {
-- some digits
IF addr1 = end
THEN {
-- all digits
IF ovf
THEN {
IF sAtom =
NIL
THEN
sAtom ← MicroUtils.AtomAtPointer[stmtBuffer+addr, nChars];
MicroOps.ReportError[
IO.PutFR["\n *** Integer %g too large\n", IO.atom[sAtom] ],
FALSE];
};
IF sgn # 0 THEN val ← -val;
typ ← integerType;
numOK ← TRUE;
}
ELSE {
-- literal
LiteralSplit[addr, nChars, addr1-addr];
GOTO loop;
};
};
IF ~numOK
THEN {
-- Undefined symbol
IF sAtom =
NIL
THEN
sAtom ← MicroUtils.AtomAtPointer[stmtBuffer+addr, nChars];
IF evalMode # fieldStoreVal
THEN {
MicroOps.ReportError[
IO.PutFR["\n *** %g undefined\n", IO.atom[sAtom] ],
FALSE];
GOTO loop;
};
val ← MicroOps.PutInSymbol[sAtom, typ ← undefnType].symIndex;
};
};
}; -- ends ePtr = 0
1 => {
-- encoded number
val ← MicroOps.GetStmtInteger[tailOld-2];
typ ← integerType;
};
ENDCASE => {
-- dispatch on symbol type
typ ← MicroOps.GetSymbol[symIndex].sType;
SELECT
TRUE
FROM
typ = macroType => {
MicroOps.MacroCall[symIndex, 0];
GOTO loop;
};
typ = addressType => {
IF evalMode = accumulateVal
THEN
TRUSTED {
aPtr: LONG POINTER TO WORD ← MicroOps.ArgString[2];
aPtr^ ← symIndex;
MicroUtils.PutCharAtPointer[aPtr+1, symc];
MicroOps.MacroCall[MicroUtils.GetSymbolMemSource[symIndex], 1];
GOTO loop;
};
val ← symIndex;
typ ← addressType;
};
(typ = integerType)
AND (evalMode # accumulateVal) =>
val ← LOOPHOLE[MicroOps.GetSymbol[symIndex].sVal, INTEGER];
(typ = undefnType) AND (evalMode = fieldStoreVal) => val ← symIndex;
typ = neutralType => {
stmtTailBottom ← tailNew;
IF tailOld # stmtTailTop
THEN {
tailOld ← stmtTailTop;
LOOP;
};
};
ENDCASE => {
MicroOps.ReportError[
IO.PutFR["\n *** Symbol %g not legal as token\n",
IO.rope[MicroOps.GetSymbol[symIndex].name] ],
FALSE];
GOTO loop;
};
};
EXIT;
ENDLOOP; -- second DO, corresponds to sym in micproc
IF tailOld # stmtTailTop
THEN
MicroOps.ReportError["\n ***Bad syntax where value required\n", FALSE]
ELSE
IF (typ # neutralType)
AND (terminator # sepc)
THEN {
stmtTailBottom ← tailOld - 2;
MicroOps.PutStmtValue[stmtTailBottom, LOOPHOLE[typ, WORD]];
MicroOps.PutStmtInteger[stmtTailBottom+1, val];
};
}; -- end of if stmtTailBottom # tailOld
stmtBufferTop ← stmtBufferTop - 1;
IF (terminator # '()
AND (terminator # endc)
THEN {
IF terminator = ',
THEN
{ stmtTailBottom ← oldTailBottom; stmtTailTop ← oldTailBottom};
LOOP;
};
stmtTailTop ← oldTailTop;
RETURN;
EXITS loop => {};
};
ENDLOOP;
};
ProcessStmt:
PUBLIC
PROC[sPtr:
LONG POINTER TO WORD, lx:
INTEGER, mode: EvalMode]
RETURNS[typ: SymbolType, val: WORD] = TRUSTED {
Internal entry to processing loop
quick check for a number
old: NAT;
IF (lx = 2)
AND ((MicroUtils.GetCharAtPointer[sPtr+1] = numc)
OR
(MicroUtils.GetCharAtPointer[sPtr+1] = num6c)) THEN RETURN[integerType, sPtr^];
IF stmtBufferTop+lx+1 > stmtTailBottom
THEN {
MicroOps.ReportError[stmtTooLong, FALSE];
RETURN[undefnType, 0];
};
MicroOps.PutStmtChar[stmtBufferTop, '( ];
MicroUtils.MoveBlock[to: stmtBuffer+stmtBufferTop+1, from: sPtr, num: lx];
stmtBufferTop ← stmtBufferTop+lx+1;
old ← stmtTailBottom;
ProcessOneClause[mode];
IF stmtTailBottom = old
THEN
{ typ ← integerType; val ← 0 }
ELSE {
typ ← GetStmtTypeAtPos[old-2];
val ← MicroOps.GetStmtValue[old-1];
};
stmtTailBottom ← old;
};
EvalArg:
PUBLIC
PROC[argP:
LONG POINTER TO WORD, lx:
INTEGER]
RETURNS[val: WORD] = TRUSTED {
Evaluate argument
old: NAT;
useArgP: LONG POINTER TO WORD ← argP;
IF (lx=2)
AND ((argP+1)^ < 40B)
THEN {
-- quick check for number
valc: CHAR = MicroUtils.GetCharAtPointer[argP+1];
SELECT valc
FROM
numc, num6c => RETURN[argP^];
symc => {
symb: SymbolObj = MicroOps.GetSymbol[argP^];
IF symb.sType = integerType THEN RETURN[symb.sVal]
};
ENDCASE => ERROR;
};
IF stmtBufferTop + lx + 1 > stmtTailBottom
THEN {
MicroOps.ReportError[stmtTooLong, FALSE];
RETURN[0]
};
[] ← MicroOps.PushStmtChar['( ];
FOR j:
NAT
IN [0.. lx)
DO
[] ← MicroOps.PushStmtValue[useArgP^];
useArgP ← useArgP + 1;
ENDLOOP;
stmtBufferTop ← stmtBufferTop+lx+1;
old ← stmtTailBottom;
ProcessOneClause[returnVal];
IF stmtTailBottom = old
THEN val ← 0
ELSE {
IF GetStmtTypeAtPos[old-2] # integerType
THEN
MicroOps.ReportError[
IO.PutFR["\n *** Arg %g does not yield integer value\n",
IO.atom[MicroUtils.AtomAtPointer[argP, lx]] ],
FALSE];
val ← MicroOps.GetStmtValue[old-1];
};
stmtTailBottom ← old;
RETURN[val];
};
Internal procedures
ExpandSize:
PROC[val:
WORD, valC:
INTEGER]
RETURNS[len:
INTEGER] = {
Compute the size of the expanded value
vc: Basics.ShortNumber = LOOPHOLE[valC];
vcx: CHAR = LOOPHOLE[vc.lo, CHAR];
SELECT vcx
FROM
symc =>
RETURN[Rope.Length[MicroOps.GetSymbol[LOOPHOLE[val, INTEGER]].name]];
num6c => RETURN[6];
numc => {
len ← 0;
DO
val ← val/8;
len ← len +1;
IF val = 0 THEN RETURN[len];
ENDLOOP;
};
ENDCASE => RETURN[0];
};
ExpandToRope:
PROC[val:
WORD, valC:
INTEGER]
RETURNS[rep:
ROPE] = {
vc: Basics.ShortNumber = LOOPHOLE[valC];
vcx: CHAR = LOOPHOLE[vc.lo, CHAR];
SELECT vcx
FROM
symc => rep ← MicroOps.GetSymbol[LOOPHOLE[val, INTEGER]].name;
num6c, numc => {
ln: Basics.LongNumber;
ln.hi ← 0; ln.lo ← LOOPHOLE[val];
rep ← IO.PutFR["%b", IO.int[LOOPHOLE[ln]]];
};
ENDCASE =>
ERROR MicroDefs.Error["ExpandValue error"];
};
ExpandValue:
PROC[val:
WORD, valC:
INTEGER, ptr:
LONG
POINTER
TO
WORD ←
NIL] =
TRUSTED {
Expand encoded value into stmtBuffer
name: ROPE ← ExpandToRope[val, valC];
len: NAT ← name.Length[];
IF ptr =
NIL
THEN {
offset: NAT ← stmtTailBottom - len;
IF offset <= stmtBufferTop
THEN {
MicroOps.ReportError[stmtTooLong, FALSE];
RETURN
};
stmtTailBottom ← offset;
ptr ← stmtBuffer + offset;
};
FOR i:
NAT
IN [0 .. len)
DO
MicroUtils.PutCharAtPointer[ptr, name.Fetch[i]];
ptr ← ptr + 1;
ENDLOOP;
};
ExpandTail:
PROC[thisTop:
NAT] = {
Expand an excoded datum just below thisTop
nowBottom: NAT;
len: NAT = thisTop - stmtTailBottom - 2;
temp: IntegerSeq ← NEW[IntegerSeqRec[len]];
FOR i:
NAT
IN [0..len)
DO
TRUSTED { temp[i] ← MicroOps.GetStmtInteger[stmtTailBottom+i] };
ENDLOOP;
stmtTailBottom ← thisTop;
ExpandValue[MicroOps.GetStmtValue[thisTop-2], MicroOps.GetStmtInteger[thisTop-1]];
IF (nowBottom ← stmtTailBottom - len) < stmtBufferTop
THEN
MicroOps.ReportError[stmtTooLong, FALSE]
ELSE {
FOR i:
NAT
IN [0..len)
DO
MicroOps.PutStmtInteger[nowBottom+i, temp[i]];
ENDLOOP;
stmtTailBottom ← nowBottom;
};
};
LexicalScan:
PROC[symFlag:
BOOL, thisTop:
NAT]
RETURNS[ePtr:
INTEGER, symb:
ATOM] = {
If symFlag then return the symbol index of a symbol and delete it from tail
If not symFlag, leave value on tail
Expand encoded values whenever stmtTailBottom # thisTop
stmtBuffer[0] contains endc, so don't need to check stmtBufferTop = 0 here
tailOrigin: NAT ← stmtTailBottom;
lexicalLen: NAT;
thisChar: CHAR;
DO
thisChar ← MicroOps.GetStmtChar[stmtBufferTop ← stmtBufferTop - 1];
SELECT thisChar
FROM
') => {
parenTop: NAT ← stmtTailBottom;
ProcessOneClause[accumulateVal];
IF ( MicroOps.GetStmtValue[parenTop-1] < 40B)
AND
(stmtTailBottom#parenTop) AND (parenTop#thisTop) THEN ExpandTail[parenTop];
};
': => {
nextEp: INTEGER;
symb: ATOM;
sObj: SymbolObj;
type: SymbolType;
[nextEp, symb] ← LexicalScan[TRUE, stmtTailBottom];
sObj ← MicroOps.GetSymbol[nextEp];
type ← sObj.sType;
IF (nextEp=0)
OR (type=nullType)
OR (type=undefnType)
THEN
MicroOps.LabelDefn[nextEp, symb]
ELSE {
tag: ROPE = "\n *** Tag %g already defined\n";
IF nextEp = 0
THEN
MicroOps.ReportError[IO.PutFR[tag, IO.atom[symb] ], FALSE]
ELSE MicroOps.ReportError[IO.PutFR[tag, IO.rope[sObj.name] ], FALSE];
};
};
'(, ',, endc => {
-- rightParen, comma, cr
stmtBufferTop ← stmtBufferTop + 1;
EXIT
};
'] => {
numArgs: INTEGER ← MicroOps.CollectArgs[];
symb: ATOM;
nextEp: INTEGER;
[nextEp, symb] ← LexicalScan[TRUE, stmtTailBottom];
IF nextEp = 0
THEN
MicroOps.ReportError[
IO.PutFR["\n *** Macro Name %g not defined\n", IO.atom[symb] ], FALSE]
ELSE MicroOps.MacroCall[nextEp, numArgs];
};
'← => {
IF stmtTailBottom = tailOrigin
THEN {
stmtTailBottom ← stmtTailBottom - 1;
MicroOps.MoveValueInStmtBuffer[from: stmtBufferTop, to: stmtTailBottom];
LOOP;
};
MicroOps.PutStmtChar[stmtBufferTop+1, sepc];
stmtBufferTop ← stmtBufferTop + 2;
EXIT;
};
sepc => LOOP;
symc, numc, num6c =>
TRUSTED {
-- encoded value
IF stmtTailBottom = thisTop
THEN {
stmtTailBottom ← stmtTailBottom - 1;
MicroOps.MoveValueInStmtBuffer[to: stmtTailBottom, from: stmtBufferTop];
stmtBufferTop ← stmtBufferTop - 1;
stmtTailBottom ← stmtTailBottom - 1;
MicroOps.MoveValueInStmtBuffer[to: stmtTailBottom, from: stmtBufferTop];
LOOP;
};
stmtBufferTop ← stmtBufferTop - 1;
ExpandValue[MicroOps.GetStmtValue[stmtBufferTop],
MicroOps.GetStmtInteger[stmtBufferTop+1]];
};
ENDCASE =>
TRUSTED {
stmtTailBottom ← stmtTailBottom - 1;
MicroOps.MoveValueInStmtBuffer[to: stmtTailBottom, from: stmtBufferTop];
};
lexicalLen ← tailOrigin - stmtTailBottom;
IF lexicalLen = 0
THEN {
IF symFlag
THEN
MicroOps.ReportError["\n ***Missing Macro name or Tag symbol\n", FALSE];
RETURN[0, NIL];
};
IF MicroOps.GetStmtValue[tailOrigin-1] < 40B
THEN {
val: INTEGER ← MicroOps.GetStmtInteger[tailOrigin-2];
valc: CHAR ← MicroOps.GetStmtChar[tailOrigin-1];
IF lexicalLen = 2
THEN {
IF symFlag THEN stmtTailBottom ← tailOrigin;
IF valc = symc
THEN {
IF val < 256 THEN MicroDefs.Error[" Bad symIndex - LexicalScan"];
RETURN[val, NIL];
};
IF symFlag
THEN
MicroOps.ReportError["\n ***Found number instead of symbol\n", FALSE];
RETURN[0, NIL];
};
Expand the datum after-the-fact
ExpandTail[tailOrigin];
lexicalLen ← tailOrigin - stmtTailBottom;
};
IF ~symFlag THEN RETURN[0, NIL];
stmtTailBottom ← tailOrigin;
[ePtr, symb] ← MicroOps.LookupBufferSymbol[stmtTailBottom-lexicalLen, lexicalLen];
IF ePtr # 0 AND ePtr < 256 THEN MicroDefs.Error[" Bad symIndex - LexicalScan"];
RETURN[ePtr, symb]; -- so can set breakpoint here
};
LiteralSplit:
PROC[addr:
NAT, nChars, kx:
INTEGER] =
TRUSTED {
Split a literal and set up a macro call
the first kx chars are the numeric part
temp: LONG POINTER TO WORD;
ePtr: INTEGER;
eName: ATOM;
n: INTEGER;
i: INTEGER ← 0;
IF MicroOps.GetStmtChar[addr] = '-
THEN {
-- move - from numeric part to symbol
kx ← kx - 1;
MicroUtils.MoveBlock[to: stmtBuffer+addr, from: stmtBuffer+addr+1, num: kx];
MicroOps.PutStmtChar[addr+kx, '-];
};
n ← LOOPHOLE[Basics.BITAND[LOOPHOLE[kx-1, WORD], 3], INTEGER] + 1;
WHILE i < kx
DO
temp ← MicroOps.ArgString[n];
TRUSTED {
FOR j: INTEGER IN [0..n) DO
(temp+j)^ ← MicroOps.GetStmtInteger[addr+i+j];
ENDLOOP;
};
i ← i + n;
n ← 4;
ENDLOOP;
[ePtr, eName] ← MicroOps.LookupBufferSymbol[addr+kx, nChars-kx];
IF ePtr = 0
THEN
MicroOps.ReportError[
IO.PutFR["\n *** Undefined literal symbol in %g %g\n",
IO.atom[MicroUtils.AtomAtPointer[stmtBuffer+addr, kx]], IO.atom[eName] ],
FALSE]
ELSE MicroOps.MacroCall[ePtr, (kx+3)/4];
};
GetStmtTypeAtPos:
PROC[offset:
NAT]
RETURNS[SymbolType] =
{ RETURN[LOOPHOLE[MicroOps.GetStmtValue[offset], SymbolType]] };