MicroBuiltInsImpl:
CEDAR
PROGRAM
IMPORTS
Basics, IO,
MicroDefs, MicroGlobalVars, MicroOps, MicroUtils
EXPORTS
MicroOps, MicroUtils
= BEGIN OPEN MicroDefs, MicroGlobalVars;
minBI: CARDINAL = 1;
maxBI: CARDINAL = 44;
SetupIndex: TYPE = [0..377B];
BINumArgs: TYPE = [0..17B];
BuiltInAccessTableEntry:
TYPE =
MACHINE
DEPENDENT
RECORD[
setup (0: 0..7): SetupIndex ← 0,
minNA (0: 8..11): BINumArgs ← 0,
maxNA (0: 12..15): BINumArgs ← 0
];
emptyEntry: BuiltInAccessTableEntry =
[setup: 0, minNA: min0, maxNA: noMax];
BuiltInAccessTable: TYPE = ARRAY[0..maxBI] OF BuiltInAccessTableEntry;
builtInAccessTable: BuiltInAccessTable ← ALL[emptyEntry];
minNumArgs values
min0: BINumArgs = 0;
min1: BINumArgs = 1;
min2: BINumArgs = 2;
min3: BINumArgs = 3;
min4: BINumArgs = 4;
min5: BINumArgs = 5;
min6: BINumArgs = 6;
min7: BINumArgs = 7;
maxNumArgs values
max0: BINumArgs = 0;
max1: BINumArgs = 1;
max2: BINumArgs = 2;
max3: BINumArgs = 3;
max4: BINumArgs = 4;
max5: BINumArgs = 5;
max6: BINumArgs = 6;
max7: BINumArgs = 7;
noMax: BINumArgs = 15;
Setup values
noSetup: SetupIndex = 0; -- dummy value
ev1: SetupIndex = 1; -- eval 1st arg
ev2: SetupIndex = 2; -- eval 2nd arg
ev12: SetupIndex = 3; -- eval 1st and 2nd args
ev23: SetupIndex = 4; -- eval 2nd and 3rd args
look1: SetupIndex = 5; -- lookup 1st arg
mem1: SetupIndex = 6; -- lookup 1st arg as memory
btLev2: SetupIndex = 7; -- lookup 1st arg as bittable, eval 2nd arg
ev3: SetupIndex = 8; -- eval 3rd arg
field1: SetupIndex = 9; -- lookup 1st arg as field name
exp1: SetupIndex = 10; -- expand 1st arg
maxMemoryNum: INTEGER = 15; -- max memory #
maxMemWidth: INTEGER = 256; -- max memory width
maxMemSize: INTEGER = 77777B; -- max memory size
MemoryArray: TYPE = ARRAY [0..maxMemoryNum] OF Memory;
memoryArray: MemoryArray ← ALL[NIL];
RestartBuiltins: PUBLIC PROC = { lastMemNum ← 0 };
DoBuiltIn:
PUBLIC
PROC[
symIndex: INTEGER, nArgs: INTEGER, argPtr: LONG POINTER TO WORD] = TRUSTED {
let dobi(bep,na,ac)
symb: SymbolObj = MicroOps.GetSymbol[symIndex];
biIndex: INTEGER = symb.sMisc; -- magic here
entry: BuiltInAccessTableEntry = builtInAccessTable[biIndex];
aPtr: LONG POINTER TO WORD ← argPtr;
maxArgs: INTEGER;
argsArray: ARRAY [1..7] OF ArgRef ← ALL[NIL]; -- must be LOCAL
val1, val2, val3, val4, val5: INTEGER;
stmtTooLong: ROPE = "\n\t*** Statement too long";
DoBx:
PROC[bVal:
BOOL] =
TRUSTED {
IF bVal THEN maxArgs ← maxArgs - 1;
IF nArgs < maxArgs THEN RETURN;
DoBa[argsArray[maxArgs].aPtr, argsArray[maxArgs].lx];
};
DoBa:
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER] =
TRUSTED {
Append lx chars, starting a aPtr, onto stmt buffer
IF stmtBufferTop + lx >= stmtTailBottom
THEN
MicroOps.ReportError[stmtTooLong, FALSE]
ELSE {
MicroUtils.MoveBlock[to: stmtBuffer+stmtBufferTop, from: aPtr, num: lx];
stmtBufferTop ← stmtBufferTop + lx;
};
lx ← lx + 1; -- for setting breakpoints
};
DoAv:
PROC[val:
INTEGER] =
TRUSTED {
Append val as number
IF stmtBufferTop + 2 >= stmtTailBottom
THEN
MicroOps.ReportError[stmtTooLong, FALSE]
ELSE {
[] ← MicroOps.PushStmtInteger[val];
[] ← MicroOps.PushStmtChar[numc];
};
};
IF nArgs > (maxArgs ← entry.maxNA)
OR nArgs < entry.minNA
THEN {
MicroOps.ReportError[
IO.PutFR["\n\t*** Wrong number (%g) of arguments for %g (%g, %g)\n",
IO.int[nArgs], IO.rope[symb.name], IO.int[maxArgs], IO.int[entry.minNA] ],
FALSE];
RETURN
};
IF maxArgs # noMax
THEN
FOR i:
INTEGER
IN [1..nArgs]
DO
argsArray[i] ← NEW[ArgRec ← [aPtr+1, aPtr^ - 1]];
aPtr ← aPtr + aPtr^;
ENDLOOP;
SELECT entry.setup
FROM
ev1 => val1 ← DoEvalArg[argsArray[1]];
ev2 => val2 ← DoEvalArg[argsArray[2]];
ev3 => val3 ← DoEvalArg[argsArray[3]];
ev12 => {
val1 ← DoEvalArg[argsArray[1]];
val2 ← DoEvalArg[argsArray[2]];
};
ev23 => {
val2 ← DoEvalArg[argsArray[2]];
val3 ← DoEvalArg[argsArray[3]];
};
look1 =>
val1 ← ExpandArgForIndex[argsArray[1]].symIndex;
mem1 =>
val1 ← LookTypeExpand[argsArray[1], memoryType];
field1 =>
val1 ← LookTypeExpand[argsArray[1], fieldType];
btLev2 => {
val1 ← LookTypeExpand[argsArray[1], bitTableType];
val2 ← DoEvalArg[argsArray[2]];
};
exp1 => [] ← MicroOps.Expand[argsArray[1]];
ENDCASE => NULL;
SELECT biIndex
FROM
1 => {
-- BUILTIN
[] ← MicroOps.Expand[argsArray[1]];
XBuiltin[argsArray[1].aPtr, argsArray[1].lx, val2];
};
2 => {
-- M (MACRO)
macroDefIndex:
INT =
MicroOps.MacroDefn[argsArray[2].aPtr, argsArray[2].lx];
macDef: LONG POINTER TO WORD = MicroOps.MacroDefnFromIndex[macroDefIndex];
symAtom: ATOM;
symIndex: INTEGER;
sObj: SymbolObj;
[symIndex, symAtom] ← MicroOps.LookupSymbol[argsArray[1].aPtr, argsArray[1].lx];
IF symIndex = 0
THEN [symIndex, sObj] ← MicroOps.PutInSymbol[symAtom, macroType]
ELSE {
sObj ← MicroOps.GetSymbol[symIndex];
IF sObj.sType # macroType
THEN
IF sObj.sType # nullType
THEN RedefnError[sObj, macroType]
ELSE MicroOps.ReportError[
IO.PutFR["\n\t*** Macro %g redefined\n",
IO.rope[sObj.name]],
FALSE];
};
IF symIndex # 0 THEN sObj.sData ← NEW[INT ← macroDefIndex];
};
3 =>
-- N (NEUTRAL)
[] ← EnterArgInSymTab[argsArray[1].aPtr, argsArray[1].lx, neutralType];
4 => {
-- MEMORY
symIndex: INTEGER;
symb: ATOM;
[symIndex, symb] ← ExpandArgForIndex[argsArray[1]];
XMemory[symIndex, symb, val2, val3,
MemoryEnter[argsArray[4]], MemoryEnter[argsArray[5]] ];
};
5 => MicroOps.TargetSet[val1]; -- TARGET
6 => MicroOps.DefaultBuiltin[val1, argsArray[2].aPtr, argsArray[2].lx]; -- DEFAULT
7 => {
-- F (FIELD)
[] ← MicroOps.Expand[argsArray[1]];
XField[argsArray[1].aPtr, argsArray[1].lx, val2, val3];
};
8 =>
-- PF (PREASSIGN)
MicroOps.DoField[val1, argsArray[2].aPtr, argsArray[2].lx, FALSE];
9 => {
-- SET
symIndex: INTEGER;
sType: SymbolType;
sObj: SymbolObj;
symAtom: ATOM;
[symIndex, symAtom] ← ExpandArgForIndex[argsArray[1]];
IF symIndex = 0
THEN
[symIndex, sObj] ← MicroOps.PutInSymbol[symAtom, integerType]
ELSE sObj ← MicroOps.GetSymbol[symIndex];
sType ← sObj.sType;
IF sType = integerType
THEN sObj.sVal ←
LOOPHOLE[val2,
WORD]
ELSE
IF (sType = nullType)
OR (sType = undefnType)
THEN
{ sObj.sType ← integerType; sObj.sVal ← LOOPHOLE[val2, WORD] }
ELSE RedefnError[sObj, integerType];
};
10 => {
-- ADD
val1 ← 0;
FOR k:
INTEGER
IN [1..nArgs]
DO
val1 ← val1 + LOOPHOLE[MicroOps.EvalArg[aPtr+1, aPtr^-1], INTEGER];
aPtr ← aPtr + aPtr^;
ENDLOOP;
DoAv[val1];
};
11 => {
-- IP
symb: SymbolObj ← IF val1 = 0 THEN NIL ELSE MicroOps.GetSymbol[val1];
IF symb =
NIL
OR symb.sType # addressType
THEN {
typ: SymbolType;
[typ, val1] ← MicroOps.ProcessStmt[argsArray[1].aPtr, argsArray[1].lx, returnVal];
IF typ # addressType
THEN {
MicroOps.ReportError[
IO.PutFR["\n\t*** 'IP[%g]' - Arg not address\n",
IO.atom[MicroUtils.AtomAtPointer[argsArray[1].aPtr, argsArray[1].lx]] ],
FALSE];
RETURN;
};
};
DoAv[MicroOps.GetSymbol[val1].sVal];
};
12 => {
-- IFSE
ap1: LONG POINTER TO WORD;
ap2: LONG POINTER TO WORD;
lx: INTEGER = argsArray[1].lx;
[] ← MicroOps.Expand[argsArray[2]];
IF lx # argsArray[2].lx THEN { DoBx[FALSE]; RETURN };
IF lx = 0 THEN { DoBx[TRUE]; RETURN };
ap1 ← argsArray[1].aPtr;
ap2 ← argsArray[2].aPtr;
FOR k:
INTEGER
IN [0.. lx)
DO
IF (ap1+k)^ # (ap2+k)^ THEN { DoBx[FALSE]; RETURN };
ENDLOOP;
DoBx[TRUE];
};
13 => DoBx[MicroOps.IsFieldSet[val1]];
-- IFSET
14 => DoBx[val1 = val2]; -- IFE
15 => DoBx[val1 > val2]; -- IFG
16 => {
-- IFDEF
bVal: BOOL ← FALSE;
IF (val1 # 0)
THEN {
type: SymbolType = MicroOps.GetSymbol[val1].sType;
bVal ← (type # nullType) AND (type # undefnType);
};
DoBx[bVal];
};
17 => {
-- IFME
bVal: BOOL ← FALSE;
val2 ← LookTypeExpand[argsArray[2], memoryType];
IF val1 # 0
THEN
bVal ← (MicroOps.GetSymbol[val1].sMisc = val2); -- more magic
DoBx[bVal];
};
18 => {
-- ER
fatal: BOOL ← FALSE;
val2 ← IF nArgs < 2 THEN 0 ELSE DoEvalArg[argsArray[2]];
IF nArgs >= 3 THEN val3 ← DoEvalArg[argsArray[3]];
SELECT val2
FROM
0 => errorCount ← errorCount - 1;
1 => fatal ← TRUE;
2 => NULL;
3 => warningCount ← warningCount + 1;
ENDCASE =>
MicroOps.ReportError[
IO.PutFR["\n\t*** Invalid code %g for ER\n", IO.int[val2]],
FALSE];
IF nArgs >= 3
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** %g%g\n",
IO.rope[GetArgAsRope[argsArray[1]]], IO.int[val3] ],
fatal]
ELSE
MicroOps.ReportError[
IO.PutFR["\n\t*** %g\n", IO.rope[GetArgAsRope[argsArray[1]]] ],
fatal];
};
19 =>
-- LIST
IF argsArray[1].lx = 0
THEN listTargetOnlyFlag ← (val1 = 0)
ELSE {
sObj: SymbolObj;
symIndex: INTEGER ← LookTypeExpand[argsArray[1], memoryType];
mem: Memory;
sObj ← MicroOps.GetSymbol[symIndex];
mem ← NARROW[sObj.sData];
mem.listOptions ← LOOPHOLE[val2];
};
20 => XInsert[argsArray[1].aPtr, argsArray[1].lx]; -- INSERT
21 => DoAv[-1 - val1]; -- NOT
22 =>
-- REPEAT
FOR k:
INTEGER
IN [1..val1]
DO
[] ← MicroOps.ProcessStmt[argsArray[2].aPtr, argsArray[2].lx, accumulateVal];
ENDLOOP;
23 => {
-- OR
val1 ← 0;
FOR k:
INTEGER
IN [1..nArgs]
DO
val1 ←
LOOPHOLE[Basics.
BITOR[
LOOPHOLE[MicroOps.EvalArg[aPtr+1, aPtr^-1]], LOOPHOLE[val1]], INTEGER];
aPtr ← aPtr + aPtr^;
ENDLOOP;
DoAv[val1];
};
24 => {
-- XOR
val1 ← 0;
FOR k:
INTEGER
IN [1..nArgs]
DO
val1 ←
LOOPHOLE[Basics.
BITXOR[
LOOPHOLE[MicroOps.EvalArg[aPtr+1, aPtr^-1]], LOOPHOLE[val1]], INTEGER];
aPtr ← aPtr + aPtr^;
ENDLOOP;
DoAv[val1];
};
25 => {
-- AND
val1 ← -1;
FOR k:
INTEGER
IN [1..nArgs]
DO
val1 ←
LOOPHOLE[Basics.
BITAND[
LOOPHOLE[MicroOps.EvalArg[aPtr+1, aPtr^-1]], LOOPHOLE[val1]], INTEGER ];
aPtr ← aPtr + aPtr^;
ENDLOOP;
DoAv[val1];
};
26 => XCommentChar[argsArray[1].aPtr, argsArray[1].lx]; -- COMMENTCHAR
27 => XBitTable[val2, argsArray[1]]; -- BITTABLE
28 => {
-- GETBIT
symb: SymbolObj = MicroOps.GetSymbol[val1];
IF XCheckBT[val2, symb]
THEN {
bt: BitTableObj = NARROW[symb.sData];
val1 ← MicroOps.GetBits[bt.btBits, val2, 1];
DoAv[val1];
};
};
29 => {
-- SETBIT
symb: SymbolObj = MicroOps.GetSymbol[val1];
bt: BitTableObj = NARROW[symb.sData];
val1Bits: WordSeq ← bt.btBits;
val3 ← IF nArgs < 3 THEN 1 ELSE DoEvalArg[argsArray[3]];
val4 ← IF nArgs < 4 THEN 1 ELSE DoEvalArg[argsArray[4]];
val5 ←
IF nArgs < 5
THEN 1
ELSE
LOOPHOLE[Basics.BITAND[LOOPHOLE[DoEvalArg[argsArray[5]]], 1]];
WHILE val3 # 0
DO
IF ~XCheckBT[val2, symb] THEN EXIT;
MicroOps.SetBits[val1Bits, val2, 1, val5];
val2 ← val2 + val4;
val3 ← val3 - 1;
ENDLOOP;
};
30 => {
-- FINDBIT
found: BOOL;
[found, val2] ← XFindBit[val1, val2,
IF nArgs < 3 THEN 1 ELSE DoEvalArg[argsArray[3]],
IF nArgs < 4 THEN 1 ELSE DoEvalArg[argsArray[4]],
IF nArgs < 5 THEN 1 ELSE DoEvalArg[argsArray[5]],
IF nArgs < 6 THEN -1 ELSE DoEvalArg[argsArray[6]] ];
IF found THEN DoAv[val2];
};
32 => DoAv[LOOPHOLE[Basics.BITSHIFT[LOOPHOLE[val1], val2]] ]; -- LSHIFT
33 => DoAv[LOOPHOLE[Basics.BITSHIFT[LOOPHOLE[val1], -val2]] ]; -- RSHIFT
34 => DoAv[MicroOps.GetField[val1]]; -- FVAL
35 => {
-- SELECT
val1 ← MicroOps.EvalArg[aPtr+1, aPtr^-1];
IF (val1 < 0)
OR (val1 > nArgs-2)
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** Index %g too big in 'SELECT' (%g)\n",
IO.int[val1], IO.int[nArgs-2]],
FALSE]
ELSE {
FOR j:
INTEGER
IN [0..val1]
DO
aPtr ← aPtr + aPtr^; ENDLOOP;
DoBa[aPtr+1, aPtr^-1];
};
};
36 => {
-- SETPOST
symb: SymbolObj = MicroOps.GetSymbol[val1];
mem: Memory = NARROW[symb.sData];
IF argsArray[2].lx = 0
THEN mem.memSymPost ← 0
ELSE mem.memSymPost ← MemoryEnter[argsArray[2]];
};
37 => {
-- SETTAG
symb: SymbolObj = MicroOps.GetSymbol[val1];
mem: Memory = NARROW[symb.sData];
IF argsArray[2].lx = 0
THEN mem.tagMacro ← 0
ELSE mem.tagMacro ← MemoryEnter[argsArray[2]];
};
38 =>
-- SETLISTFIELDS
MicroOps.SetListFieldsBuiltin[val1, argsArray[2].aPtr, argsArray[2].lx];
39 => {
-- SETMBEXT
IF binaryFile.strm #
NIL
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** 'SETMBEXT' given after output started\n"],
FALSE];
mbExtn ← MicroUtils.RopeAtPointer[argsArray[1].aPtr, argsArray[1].lx];
};
40 => {
-- SUB
val1 ← LOOPHOLE[MicroOps.EvalArg[aPtr+1, aPtr^-1], INTEGER];
FOR k:
INTEGER
IN [2..nArgs]
DO
aPtr ← aPtr + aPtr^;
val1 ← val1 - MicroOps.EvalArg[aPtr+1, aPtr^-1];
ENDLOOP;
DoAv[val1];
};
41 => {
-- EQUATE
symIndex, sym2Index: INTEGER;
symb, symb2: ATOM;
[sym2Index, symb2] ← ExpandArgForIndex[argsArray[2]];
IF sym2Index = 0
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** %g not defined in EQUATE\n", IO.atom[symb2]],
FALSE]
ELSE {
s2Obj: SymbolObj = MicroOps.GetSymbol[sym2Index];
sObj: SymbolObj;
[symIndex, symb] ← MicroOps.LookupSymbol[argsArray[1].aPtr, argsArray[1].lx];
IF symIndex = 0
THEN
[symIndex, sObj] ← MicroOps.PutInSymbol[symb, s2Obj.sType];
sObj.sMisc ← s2Obj.sMisc;
sObj.sVal ← s2Obj.sVal;
sObj.redef ← s2Obj.redef;
sObj.sData ← s2Obj.sData;
};
};
42 =>
-- PROCESSMODE
SELECT val1
FROM
0 => ignore ← FALSE;
1 => ignore ← TRUE;
ENDCASE => {
MicroOps.ReportError[
IO.PutFR["\n\t*** Invalid argument (%g) for ProcessMode\n", IO.int[val1]],
FALSE];
};
43 =>
-- TRACEMODE
SELECT val1
FROM
0 => traceSyms ← val2#0;
1 => traceCalls ← val2#0;
ENDCASE =>
MicroOps.ReportError[
IO.PutFR["\n\t*** Invalid argument (%g) for TraceMode\n", IO.int[val1]],
FALSE];
44 =>
-- WHILE
WHILE DoEvalArg[argsArray[1]] # 0
DO
[] ← MicroOps.ProcessStmt[argsArray[2].aPtr, argsArray[2].lx, accumulateVal];
ENDLOOP;
ENDCASE =>
MicroOps.ReportError[
IO.PutFR["\n\t*** Invalid argument (%g) for BuiltIn\n", IO.int[biIndex]],
FALSE];
};
MemoryEnter:
PROC[argRef: ArgRef]
RETURNS[symIndex:
INTEGER] = {
Enter symbol for "memory"
symb: ATOM;
[symIndex, symb] ← ExpandArgForIndex[argRef];
IF symIndex = 0 THEN symIndex ← MicroOps.PutInSymbol[symb, nullType].symIndex;
};
EnterArgInSymTab:
PROC[aPtr:
LONG
POINTER
TO
WORD, lx:
INTEGER, typ: SymbolType]
RETURNS[symIndex: INTEGER, sObj: SymbolObj] = {
Put the argument in the symbol table with type typ - Error if already defined
symb: ATOM;
[symIndex, symb] ← MicroOps.LookupSymbol[aPtr, lx];
IF symIndex = 0
THEN [symIndex, sObj] ← MicroOps.PutInSymbol[symb, typ]
ELSE {
sObj ← MicroOps.GetSymbol[symIndex];
IF (sObj.sType = nullType)
THEN sObj.sType ← typ
ELSE {
RedefnError[sObj, typ];
symIndex ← 0;
};
};
};
GetArgAsRope:
PROC[argRef: ArgRef]
RETURNS[
ROPE] = {
aPtr: LONG POINTER TO WORD = argRef.aPtr;
lx: INTEGER = argRef.lx;
IF lx = 2
THEN {
ch: CHAR;
TRUSTED { ch ← MicroUtils.GetCharAtPointer[aPtr+1] };
IF ch = symc
THEN {
symIndex: INTEGER;
TRUSTED { symIndex ← LOOPHOLE[aPtr^] };
RETURN[MicroOps.GetSymbol[symIndex].name];
};
};
RETURN[MicroUtils.RopeAtPointer[argRef.aPtr, argRef.lx]];
};
DoEvalArg:
PROC[argRef: ArgRef]
RETURNS[
INTEGER] =
INLINE
{ RETURN[LOOPHOLE[MicroOps.EvalArg[argRef.aPtr, argRef.lx], INTEGER] ] };
RedefnError:
PROC[sObj: SymbolObj, typ: SymbolType] = {
MicroOps.ReportError[
IO.PutFR["\n\t*** Attempt to redefine %g %g as a %g\n",
IO.rope[TypeName[sObj.sType]], IO.rope[sObj.name], IO.rope[TypeName[typ]] ],
FALSE];
};
TypeName:
PUBLIC
PROC[rTyp: SymbolType]
RETURNS[
ROPE] = {
SELECT rTyp
FROM
nullType => RETURN["null"];
macroType => RETURN["macro"];
fieldType => RETURN["field"];
integerType => RETURN["integer"];
addressType => RETURN["address"];
builtInType => RETURN["builtin"];
neutralType => RETURN["neutral"];
memoryType => RETURN["memory"];
undefnType => RETURN["undefined"];
bitTableType => RETURN["bittable"];
ENDCASE => RETURN["unknown"];
};
DoField:
PUBLIC
PROC[
symIndex: INTEGER, aPtr: LONG POINTER TO WORD, len: INTEGER, set: BOOL] = {
typ: SymbolType;
val: WORD;
[typ, val] ← MicroOps.ProcessStmt[aPtr, len, fieldStoreVal];
SELECT typ
FROM
undefnType =>
IF ~set
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** Forward reference not legal in 'PreAssign'\n"],
FALSE]
ELSE MicroOps.UndefnRef[symIndex, val];
integerType => MicroOps.SetField[symIndex, val, set];
addressType => {
vObj: SymbolObj = MicroOps.GetSymbol[val];
MicroOps.SetField[symIndex, LOOPHOLE[vObj.sVal], set];
};
ENDCASE =>
MicroOps.ReportError[
IO.PutFR["\n\t*** Arg in field store not Integer or Address\n"],
FALSE];
};
AddressTagDefn:
PUBLIC PROC[symIndex:
INTEGER, mem: Memory, val:
INTEGER]
RETURNS[symbolIndex: INTEGER] = {
Define address tag
sObj: SymbolObj = MicroOps.GetSymbol[symIndex];
typ: SymbolType = sObj.sType;
IF (typ # undefnType)
AND (typ # nullType)
AND
( (typ = addressType) AND (sObj.sMisc # mem.symIndex)) THEN {
RedefnError[sObj, addressType];
RETURN[0];
}
ELSE {
newObj: SymbolObj = MicroOps.NewDef[symIndex];
newObj.sType ← addressType;
newObj.sMisc ← mem.symIndex;
newObj.sVal ← val;
mem.lTag ← symbolIndex ← newObj.symIndex;
};
};
MemoryFromNum:
PUBLIC
PROC[memNum:
INTEGER]
RETURNS [Memory] =
{ RETURN[memoryArray[memNum]]; };
SetMemoryFromNum:
PUBLIC PROC[memNum:
INTEGER, mem: MicroDefs.Memory] =
{ memoryArray[memNum] ← mem };
XBuiltin:
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER, num:
INTEGER] = {
"builtin" builtin
symIndex: INTEGER;
sObj: SymbolObj;
IF num < minBI
OR num > maxBI
THEN {
MicroOps.ReportError[
IO.PutFR["\n\t*** Illegal builtin number (%g) for %g\n",
IO.int[num], IO.atom[MicroUtils.AtomAtPointer[aPtr, lx]] ],
FALSE];
RETURN
};
symIndex ← MicroOps.LookupSymbol[aPtr, lx].symIndex;
IF symIndex # 0
THEN {
-- check if redefining a builtin identically
sObj ← MicroOps.GetSymbol[symIndex];
IF (sObj.sType = builtInType) AND (sObj.sMisc = num) THEN RETURN;
};
[symIndex, sObj] ← EnterArgInSymTab[aPtr, lx, builtInType];
IF symIndex = 0 THEN RETURN;
sObj.sMisc ← num;
};
XCommentChar:
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER] = {
"commentchar" builtin
IF lx <=0
THEN commentChar ← '\000
ELSE commentChar ← MicroUtils.GetCharAtPointer[aPtr];
};
XField:
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER, first, last:
INTEGER] = {
Field builtin
symIndex: INTEGER;
sObj: SymbolObj;
IF first < 0
OR last < first
OR last > maxMemWidth
THEN {
MicroOps.ReportError[
IO.PutFR[
"\n\t*** Bad Parameters (%g, %g) for field\n", IO.int[first], IO.int[last] ],
FALSE];
first ← last ← 0;
};
[symIndex, sObj] ← EnterArgInSymTab[aPtr, lx, fieldType];
sObj.sMisc ← first;
sObj.sVal ← LOOPHOLE[last - first + 1, WORD];
};
XInsert:
PROC[aPtr:
LONG POINTER TO WORD, lx:
INTEGER] = {
"Insert" builtin
fullName: ROPE;
ok: BOOL;
fileName: ROPE = MicroUtils.RopeAtPointer[aPtr, lx];
[fullName, ok] ← MicroOps.InPushFile[fileName];
IF ~ok
THEN
MicroOps.ReportError[
IO.PutFR["\n\t*** Could not open %g for Insert\n", IO.rope[fullName]],
FALSE];
};
XMemory:
PROC[symIndex:
INTEGER, symb:
ATOM, width, size, srcIndex, sinkIndex:
INTEGER] = {
Memory builtin
memory: Memory;
sObj: SymbolObj;
quit: ROPE = " ********** quitting\n";
IF symIndex # 0
THEN
{ RedefnError[MicroOps.GetSymbol[symIndex], memoryType]; RETURN };
IF (width < 0)
OR (width > maxMemWidth)
OR (size < 0)
OR (size > maxMemSize)
THEN
ERROR MicroDefs.Error[
IO.PutFR["Illegal width (%g) or size (%g) for 'Memory'\n",
IO.int[width], IO.int[size]] ];
IF lastMemNum = maxMemoryNum THEN ERROR MicroDefs.Error["Too many memories"];
lastMemNum ← lastMemNum + 1;
[symIndex, sObj] ← MicroOps.PutInSymbol[symb, memoryType];
sObj.sData ← memory ← NEW[MemoryRec];
memory.symIndex ← symIndex;
memory.widthInBits ← width;
memory.widthInWords ← (width+Basics.bitsPerWord-1)/Basics.bitsPerWord;
memory.size ← size;
memory.memoryNum ← lastMemNum;
memory.sourceIndex ← srcIndex;
memory.sinkIndex ← sinkIndex;
memory.listFields ← IF width = 0 THEN NIL ELSE NEW[WordSeqRec[width]];
memoryArray[lastMemNum] ← memory;
MicroOps.WriteMemoryDef[memory];
};
XCheckBT:
PROC[index:
INTEGER, symb: SymbolObj]
RETURNS[
BOOL] = {
check that index is valid for bittable
bt: BitTableObj = NARROW[symb.sData];
IF bt =
NIL
THEN {
MicroOps.ReportError[
IO.PutFR["\n\t*** %g is not a bittable\n", IO.rope[symb.name]],
FALSE];
RETURN[FALSE]
};
IF index < bt.btSize THEN RETURN[TRUE];
MicroOps.ReportError[
IO.PutFR["\n\t*** Index %g is too large for bittable %g (max %g)\n",
IO.int[index], IO.rope[symb.name], IO.int[bt.btSize]],
FALSE];
RETURN[FALSE];
};
LookTypeExpand:
PROC[argRef: ArgRef, typ: SymbolType]
RETURNS[symIndex:
INTEGER] = {
aPtr: LONG POINTER TO WORD ← argRef.aPtr;
lx: INTEGER = argRef.lx;
IF lx = 2
THEN {
-- quick check for symc
ch: CHAR;
TRUSTED { ch ← MicroUtils.GetCharAtPointer[aPtr+1] };
IF ch = symc
THEN {
sObj: SymbolObj;
TRUSTED { symIndex ← LOOPHOLE[aPtr^] };
sObj ← MicroOps.GetSymbol[symIndex];
IF sObj.sType = typ THEN RETURN;
MicroOps.ReportError[
IO.PutFR["\n\t*** %g is not of type %g\n",
IO.rope[sObj.name], IO.rope[TypeName[typ]] ],
FALSE
];
RETURN[0];
};
};
RETURN[LookType[aPtr, lx, typ].symIndex];
};
LookType:
PROC[aPtr:
LONG
POINTER
TO
WORD, lx:
INTEGER, typ: SymbolType]
RETURNS[symIndex: INTEGER, sObj: SymbolObj] = {
look up argument, must be of given type
symb: ATOM;
[symIndex, symb] ← MicroOps.LookupSymbol[aPtr, lx];
IF (symIndex # 0)
THEN {
IF MicroOps.GetSymbol[symIndex].sType = typ THEN RETURN;
};
MicroOps.ReportError[
IO.PutFR["\n\t*** %g is not of type %g\n", IO.atom[symb], IO.rope[TypeName[typ]] ],
FALSE];
RETURN[0, NIL];
};
ExpandArgForIndex:
PROC[argRef: ArgRef]
RETURNS[symIndex:
INTEGER, symb:
ATOM] = {
aPtr: LONG POINTER TO WORD = argRef.aPtr;
lx: INTEGER = argRef.lx;
IF lx = 2
THEN
TRUSTED {
IF (aPtr+1)^ < 40B
AND MicroUtils.GetCharAtPointer[aPtr+1] = symc
THEN
RETURN[LOOPHOLE[aPtr^, INTEGER], NIL]
};
[] ← MicroOps.Expand[argRef];
[symIndex, symb] ← MicroOps.LookupSymbol[argRef.aPtr, argRef.lx];
};
XFindBit:
PROC[symbolIndex, start, num, delta, hop, count:
INTEGER]
RETURNS[ok: BOOL, actualStart: INTEGER] = {
"findbit" builtin -- returns true, actualStart if found
sObj: SymbolObj = MicroOps.GetSymbol[symbolIndex];
bt: BitTableObj = NARROW[sObj.sData];
btSize: INTEGER;
moreToTry: BOOL ← TRUE;
IF bt = NIL THEN RETURN[FALSE, 0];
btSize ← bt.btSize;
actualStart ← start;
WHILE count # 0
DO
n: INTEGER ← num;
i: INTEGER ← actualStart;
WHILE n # 0
DO
IF i >= btSize THEN RETURN[FALSE, 0]; -- ran off end of memory
IF MicroOps.GetBits[bt.btBits, i, 1] # 0
THEN {
moreToTry ← FALSE;
EXIT;
};
i ← i + delta;
n ← n - 1;
ENDLOOP;
IF ~moreToTry THEN RETURN[TRUE, actualStart];
actualStart ← actualStart + hop;
count ← count - 1;
ENDLOOP;
};
XBitTable:
PROC[size:
INTEGER, argRef: ArgRef] = {
"bittable" builtin, name is implicit argument in argsArray[1]
sObj: SymbolObj;
symbolIndex, nWords: INTEGER;
[] ← MicroOps.Expand[argRef];
[symbolIndex, sObj] ← EnterArgInSymTab[argRef.aPtr, argRef.lx, bitTableType];
IF symbolIndex = 0 THEN RETURN;
nWords ← 1 + size/Basics.bitsPerWord;
sObj.sData ← NEW[BitTableRec ← [btSize: size, btBits: NEW[WordSeqRec[nWords]]]];
};
start code
builtInAccessTable[0] ← [minNA: min0, maxNA: max0]; -- filler
builtInAccessTable[1] ← [setup: ev2, minNA: min2, maxNA: max2]; -- builtin
builtInAccessTable[2] ← [setup: exp1, minNA: min2, maxNA: max2]; -- m (macro)
builtInAccessTable[3] ← [setup: exp1, minNA: min1, maxNA: max1]; -- n (neutral)
builtInAccessTable[4] ← [setup: ev23, minNA: min5, maxNA: max5]; -- memory
builtInAccessTable[5] ← [setup: look1, minNA: min1, maxNA: max1]; -- target
builtInAccessTable[6] ← [setup: mem1, minNA: min2, maxNA: max2]; -- default
builtInAccessTable[7] ← [setup: ev23, minNA: min3, maxNA: max3]; -- f (field)
builtInAccessTable[8] ← [setup: field1, minNA: min2, maxNA: max2]; -- pf (preassign)
builtInAccessTable[9] ← [setup: ev2, minNA: min2, maxNA: max2]; -- set
builtInAccessTable[10] ← [setup: noSetup, minNA: min0, maxNA: noMax]; -- add
builtInAccessTable[11] ← [setup: look1, minNA: min1, maxNA: max1]; -- ip (integer part)
builtInAccessTable[12] ← [setup: exp1, minNA: min3, maxNA: max4]; -- ifse (if string eq)
builtInAccessTable[13] ←
[setup: field1, minNA: min2, maxNA: max3]; -- ifset (if any bits of field)
builtInAccessTable[14] ← [setup: ev12, minNA: min3, maxNA: max4]; -- ife (if integers equal)
builtInAccessTable[15] ← [setup: ev12, minNA: min3, maxNA: max4]; -- ifg (if int 1 > int 2)
builtInAccessTable[16] ←
[setup: look1, minNA: min2, maxNA: max3]; -- ifdef (if sym in symtab and not unbound address
builtInAccessTable[17] ←
[setup: look1, minNA: min3, maxNA: max4]; -- ifme (if mem part = string)
builtInAccessTable[18] ← [setup: exp1, minNA: min1, maxNA: max3]; -- er
builtInAccessTable[19] ← [setup: ev2, minNA: min2, maxNA: max2]; -- set list mode for memory
builtInAccessTable[20] ← [setup: exp1, minNA: min1, maxNA: max1]; -- insert file
builtInAccessTable[21] ← [setup: ev1, minNA: min1, maxNA: max1]; -- 1's complement
builtInAccessTable[22] ← [setup: ev1, minNA: min2, maxNA: max2]; -- repeat text #2 #1 times
builtInAccessTable[23] ← [setup: noSetup, minNA: min1, maxNA: noMax]; -- logical or
builtInAccessTable[24] ← [setup: noSetup, minNA: min1, maxNA: noMax]; -- logical xor
builtInAccessTable[25] ← [setup: noSetup, minNA: min1, maxNA: noMax]; -- logical and
builtInAccessTable[26] ← [setup: exp1, minNA: min1, maxNA: max1]; -- set comment char
builtInAccessTable[27] ← [setup: ev2, minNA: min2, maxNA: max2]; -- bittable
builtInAccessTable[28] ← [setup: btLev2, minNA: min2, maxNA: max2]; -- get bit
builtInAccessTable[29] ← [setup: btLev2, minNA: min2, maxNA: max5]; -- set bit(s)
builtInAccessTable[30] ← [setup: btLev2, minNA: min2, maxNA: max6]; -- find bit(s)
builtInAccessTable[31] ← emptyEntry; -- ** unused
builtInAccessTable[32] ← [setup: ev12, minNA: min2, maxNA: max2]; -- lshift
builtInAccessTable[33] ← [setup: ev12, minNA: min2, maxNA: max2]; -- rshift
builtInAccessTable[34] ← [setup: field1, minNA: min1, maxNA: max1]; -- get field value
builtInAccessTable[35] ← [setup: noSetup, minNA: min1, maxNA: noMax]; -- select
builtInAccessTable[36] ← [setup: mem1, minNA: min2, maxNA: max2]; -- set postmacro
builtInAccessTable[37] ← [setup: mem1, minNA: min2, maxNA: max2]; -- set tag macro
builtInAccessTable[38] ← [setup: mem1, minNA: min2, maxNA: max2]; -- set listing fields
builtInAccessTable[39] ←
[setup: exp1, minNA: min1, maxNA: max1]; -- set binary output extension
builtInAccessTable[40] ← [setup: noSetup, minNA: min1, maxNA: noMax]; -- subtract
builtInAccessTable[41] ← [setup: exp1, minNA: min2, maxNA: max2]; -- equate
builtInAccessTable[42] ← [setup: ev1, minNA: min1, maxNA: max1]; -- set ignore mode
builtInAccessTable[43] ← [setup: ev12, minNA: min2, maxNA: max2]; -- set trace mode
builtInAccessTable[44] ←
[setup: noSetup, minNA: min2, maxNA: max2]; -- while #1 repeat #2
builtInAccessTable[I] ← [setup: I, minNA: I, maxNA: I]; -- I
END.