DIRECTORY
Ascii USING [Digit],
Basics USING [BITAND],
IO,
Rope,
VM USING [AddressForPageNumber, SimpleAllocate, WordsForPages],
MicroDefs,
MicroGlobalVars,
MicroOps,
MicroUtils USING [GetCharAtPointer, PutCharAtPointer];
MicroMacroOpsImpl:
CEDAR
PROGRAM
IMPORTS
Ascii, IO, VM,
MicroDefs, MicroGlobalVars, MicroOps, MicroUtils
= BEGIN OPEN MicroDefs, MicroGlobalVars;
argumentBuffer: LONG POINTER TO WORD ← NIL;
argBufEnd, argPtr: LONG POINTER TO WORD ← NIL;
macDefnBuffer: LONG POINTER TO WORD ← NIL;
numMacroPages: INT = 256; -- be generous, we can only do this once!
macroInitialFree: INT = VM.WordsForPages[numMacroPages];
macroIndex: PUBLIC INT;
freeMacroSpace: INT;
InitMacroOps:
PUBLIC
PROC =
TRUSTED {
numPages: INT = 4;
IF argumentBuffer =
NIL
THEN {
buf: LONG POINTER ← VM.AddressForPageNumber[VM.SimpleAllocate[numPages].page];
argumentBuffer ← LOOPHOLE[buf, LONG POINTER TO WORD];
buf ← VM.AddressForPageNumber[VM.SimpleAllocate[2*numPages].page];
macDefnBuffer ← LOOPHOLE[buf, LONG POINTER TO WORD];
AllocMacroStorage[];
};
argBufEnd ← argumentBuffer + VM.WordsForPages[numPages];
argPtr ← argBufEnd;
nextMacroIndex ← 1; -- 0 means no macro defn!
freeMacroSpace ← macroInitialFree;
};
ArgString:
PUBLIC
PROC[nChars:
INTEGER]
RETURNS[
LONG POINTER TO WORD] =
TRUSTED {
Allocate an n-char. argument string
maybeArgP: INT = LOOPHOLE[argPtr - nChars - 1];
IF maybeArgP <
LOOPHOLE[argumentBuffer,
INT]
THEN
MicroDefs.Error["Macro argument storage full\n"];
argPtr ← argPtr - nChars - 1;
argPtr^ ← nChars + 1;
RETURN[argPtr+1];
};
CollectArgs:
PUBLIC
PROC
RETURNS[nArgs:
INT] =
TRUSTED {
Collect macro arguments, return # of args.
Note: the statement reading routine guarantees proper nesting
of parens and brackets, and nothing in the language can destroy it,
so no stack is necessary here.
Note we read the buffer backwards, so we see ]'s and )'s first
nesting: INT ← 0;
stPtr, oldStPtr: NAT ← stmtBufferTop;
nWords: NAT;
nArgs ← 0;
DO
ch: CHAR ← MicroOps.GetStmtChar[stPtr ← stPtr - 1];
SELECT ch
FROM
endc => ERROR MicroDefs.Error["Brackets mismatched - bug"];
symc, numc, num6c => stPtr ← stPtr - 1;
'( => nesting ← nesting - 1;
'[ => {
IF nesting # 0 THEN { nesting ← nesting - 1; LOOP};
MicroOps.PutStmtValue[stPtr, oldStPtr - stPtr];
nArgs ← nArgs + 1;
EXIT
};
', => {
-- comma
IF nesting # 0 THEN LOOP; -- enclosed in () or []
MicroOps.PutStmtValue[stPtr, oldStPtr - stPtr];
nArgs ← nArgs + 1;
oldStPtr ← stPtr;
LOOP;
};
'), '] => nesting ← nesting + 1;
ENDCASE => stPtr ← stPtr; -- so can set a breakpoint here
ENDLOOP;
nWords ← stmtBufferTop - stPtr;
stmtBufferTop ← stPtr;
IF
LOOPHOLE[argPtr - nWords,
INT] <
LOOPHOLE[argumentBuffer,
INT]
THEN {
MicroOps.ReportError["\n ***Macro argument storage full\n", FALSE];
RETURN[0];
};
argPtr ← argPtr - nWords;
FOR i:
NAT
DECREASING IN [stPtr .. stPtr+nWords)
DO
argPtr ← argPtr - 1;
argPtr^ ← (stmtBuffer+i)^;
ENDLOOP;
RETURN[nArgs]; -- redundant, for info only
};
stmtTooLong: ROPE = "\n ***Statement too long\n";
MacroCall:
PUBLIC
PROC[symIndex:
INTEGER, nArgs:
INTEGER] = {
Do macro call
dP: LONG POINTER TO WORD;
symb: SymbolObj;
sType: SymbolType;
free: INTEGER;
myArgsPtr: LONG POINTER TO WORD ← argPtr;
CopyArgument:
PROC[nP:
LONG POINTER TO WORD]
RETURNS[continue:
BOOL] = {
nL: INTEGER;
TRUSTED { nL ← nP^ - 1};
IF nL = 0 THEN RETURN[TRUE];
IF nL >= free
THEN {
MicroOps.ReportError[stmtTooLong, FALSE];
RETURN[FALSE];
};
free ← free - nL;
FOR i:
INTEGER
IN [0..nL)
DO
TRUSTED {
nP ← nP + 1;
[] ← MicroOps.PushStmtValue[nP^]
};
ENDLOOP;
RETURN[TRUE];
};
IF traceCalls THEN TraceMacroCall[symIndex, nArgs];
symb ← MicroOps.GetSymbol[symIndex];
sType ← symb.sType;
IF sType = macroType
THEN
TRUSTED {
-- expand macro
nP: LONG POINTER TO WORD;
dpI: REF INT ← NARROW[symb.sData];
dP ← MacroDefnFromIndex[dpI^];
TRUSTED { free ← stmtTailBottom - stmtBufferTop - dP^ };
IF free <= 0
THEN {
MicroOps.ReportError[stmtTooLong, FALSE];
RETURN
};
DO
ch: CHAR;
dP ← dP + 1;
ch ← MicroUtils.GetCharAtPointer[dP];
SELECT ch
FROM
Aargn => {
-- Copy param'th argument
param: INTEGER;
dP ← dP + 1;
param ← dP^;
IF param > nArgs THEN LOOP;
nP ← myArgsPtr;
FOR i:
INTEGER
IN [2..param]
DO
nP ← nP + nP^; ENDLOOP;
IF ~CopyArgument[nP] THEN EXIT;
};
Aarg1 => {
-- Copy argument 1
IF nArgs = 0 THEN LOOP;
IF ~CopyArgument[myArgsPtr] THEN EXIT;
};
Aarg2 => {
-- Copy argument 2
IF nArgs <= 1 THEN LOOP;
IF ~CopyArgument[myArgsPtr + myArgsPtr^] THEN EXIT;
};
Anargs => {
-- Give number of args
IF nArgs >= 8 THEN [] ← MicroOps.PushStmtChar[(nArgs/8) + '0];
[] ← MicroOps.PushStmtChar[Basics.BITAND[LOOPHOLE[nArgs], 7] + '0];
};
symc, numc, num6c => {
-- Packed value, short (push in reverse order)
[] ← MicroOps.PushStmtValue[(dP+1)^];
[] ← MicroOps.PushStmtValue[dP^];
dP ← dP + 1;
};
40C => {
-- Packed value, long
ERROR; -- should not occur
};
Aend => EXIT; -- End of definition
ENDCASE => [] ← MicroOps.PushStmtValue[dP^]; -- default
ENDLOOP;
}
ELSE
SELECT sType
FROM
fieldType =>
IF nArgs = 1
THEN
TRUSTED {
lx: INTEGER ← LOOPHOLE[myArgsPtr^, INTEGER] - 1;
MicroOps.DoField[symIndex, myArgsPtr+1, lx, TRUE]
}
ELSE MacroError[symb, nArgs];
builtInType => MicroOps.DoBuiltIn[symIndex, nArgs, myArgsPtr];
memoryType =>
IF nArgs = 2
THEN
TRUSTED {
sP: LONG POINTER TO WORD ← myArgsPtr + 1;
secondParam: LONG POINTER TO WORD = myArgsPtr + myArgsPtr^;
sLen: INTEGER = LOOPHOLE[secondParam^, INTEGER] - 1;
loc: INTEGER = MicroOps.EvalArg[secondParam+1, sLen];
memSymb: SymbolObj = MicroOps.GetSymbol[symIndex];
memory: Memory = NARROW[memSymb.sData];
atm: ATOM;
s2Index: INTEGER;
s2Len: INTEGER = LOOPHOLE[myArgsPtr^, INTEGER] - 1;
[s2Index, atm] ← ExpandArgForIndex[sP, s2Len];
IF s2Index = 0
THEN
s2Index ← MicroOps.PutInSymbol[atm, nullType].symIndex;
[] ← MicroOps.AddressTagDefn[s2Index, memory, loc];
}
ELSE MacroError[symb, nArgs];
addressType =>
TRUSTED {
IF nArgs = 1
THEN {
lx: INTEGER = LOOPHOLE[myArgsPtr^, INTEGER] - 1;
MicroOps.StoreBuiltin[symIndex, myArgsPtr+1, lx]
}
ELSE MacroError[symb, nArgs];
};
ENDCASE =>
MicroOps.ReportError[
IO.PutFR["\n *** %g may not be followed by []\n",
IO.rope[symb.name]],
FALSE];
clear away argList
FOR i:
INTEGER
IN [1..nArgs]
DO
TRUSTED {argPtr ← argPtr + argPtr^}; ENDLOOP;
};
MacroDefn:
PUBLIC
PROC[argP:
LONG POINTER TO WORD, lx:
INTEGER]
RETURNS[macroDefnIndex: INT] = TRUSTED {
Parse macro definition.
Ok to do this into macDefnBuffer, one char (integer) per word; parsed version is always smaller than unpacked original, so macDefnBuffer need only be twice as big as the argumentBuffer.
endP: LONG POINTER TO WORD = argP+lx;
cP: LONG POINTER TO WORD ← endP;
di: INTEGER ← lx;
ckLen: INTEGER ← lx; -- Length for initial check at call time
ch: CHAR ← LAST[CHAR];
nWords: INT;
IF lx = 0
THEN {
-- avoids negative di below
macroDefnIndex ← AllocMacroDefn[2];
(macroStorageStart+macroDefnIndex)^ ← 0;
MicroUtils.PutCharAtPointer[macroStorageStart+macroDefnIndex+1, Aend];
RETURN[macroDefnIndex];
};
UNTIL cP = argP
DO
lastCh: CHAR ← ch;
cP ← cP - 1;
di ← di - 1;
ch ← MicroUtils.GetCharAtPointer[cP];
IF (ch = '#)
AND Ascii.Digit[lastCh]
THEN {
-- Argument
aC: CHAR = MicroUtils.GetCharAtPointer[cP+1];
di ← di + 1; -- we eliminate the #
SELECT aC
FROM
'0 => ch ← Anargs;
'1 => ch ← Aarg1;
'2 => ch ← Aarg2;
ENDCASE => {
(macDefnBuffer+di)^ ← LOOPHOLE[aC - '0];
di ← di - 1;
ch ← Aargn;
};
IF aC # '0 THEN ckLen ← ckLen - 1;
} -- end of Argument
ELSE
IF ch < 40C
THEN {
-- Packed value (no need for long format stuff)
(macDefnBuffer+di)^ ← (cP ← cP - 1)^;
di ← di - 1;
};
MicroUtils.PutCharAtPointer[macDefnBuffer+di, ch];
ENDLOOP;
get space for unpacked body of macro defn
nWords ← lx - di;
macroDefnIndex ← AllocMacroDefn[nWords + 2];
FOR i:
INT
IN [1..nWords]
DO
(macroStorageStart+macroDefnIndex+i)^ ← (macDefnBuffer+di+i-1)^;
ENDLOOP;
MicroUtils.PutCharAtPointer[macroStorageStart+macroDefnIndex+nWords+1, Aend];
(macroStorageStart+macroDefnIndex)^ ← ckLen;
RETURN[macroDefnIndex];
};
Internal procedures
ExpandArgForIndex:
PROC[aPtr:
LONG
POINTER
TO
WORD, len:
INTEGER]
RETURNS[symIndex: INTEGER, symb: ATOM] = {
argRef: ArgRef;
IF len = 2
THEN
TRUSTED {
IF (aPtr+1)^ < 40B
AND MicroUtils.GetCharAtPointer[aPtr+1] = symc
THEN
RETURN[LOOPHOLE[aPtr^, INTEGER], NIL]
};
argRef ← NEW[ArgRec ← [aPtr, len]];
[] ← MicroOps.Expand[argRef];
[symIndex, symb] ← MicroOps.LookupSymbol[argRef.aPtr, argRef.lx];
};
MacroError:
PROC[symb: SymbolObj, nArgs:
INTEGER] = {
MicroOps.ReportError[
IO.PutFR["\n *** Wrong number (%g) of args for %g\n",
IO.int[nArgs], IO.rope[symb.name] ],
FALSE];
};
TraceMacroCall:
PROC[symIndex:
INTEGER, nArgs:
INTEGER] = {
Trace the call for debugging
ap: LONG POINTER TO WORD ← argPtr;
lStrm: STREAM = listingFileRec.strm;
ListArgsBlock:
PROC[aP:
LONG POINTER TO WORD, nChars:
INTEGER] = {
lx: INTEGER;
IF lx = -1
THEN {
-- no expansion
FOR i:
NAT
IN [0..nChars)
DO
TRUSTED { lStrm.PutChar[MicroUtils.GetCharAtPointer[aP+i]] };
ENDLOOP;
}
ELSE { -- nyi
};
lStrm.PutF["* %g\n", IO.rope[MicroOps.GetSymbol[symIndex].name] ];
FOR i:
NAT
IN [0..nArgs)
DO
lStrm.PutRope["\n*\t"];
TRUSTED {
lx: INTEGER = LOOPHOLE[ap^, INTEGER] - 1;
ListArgsBlock[ap+1, lx];
ap ← ap + ap^;
};
ENDLOOP;
lStrm.PutChar['\n];
};
MacroDefnFromIndex:
PUBLIC
PROC[macroDefnIndex:
INT]
RETURNS[LONG POINTER TO WORD] = TRUSTED {
RETURN[macroStorageStart+macroDefnIndex];
};
AllocMacroDefn:
PROC[len:
INT]
RETURNS[new:
INT] =
TRUSTED {
IF freeMacroSpace < len THEN MicroDefs.Error["Macro storage full\n"];
new ← nextMacroIndex;
nextMacroIndex ← nextMacroIndex + len;
freeMacroSpace ← freeMacroSpace - len;
};
AllocMacroStorage:
PROC =
TRUSTED {
numPages: INT = 256; -- be generous, we only do this once!
buf: LONG POINTER ← VM.AddressForPageNumber[VM.SimpleAllocate[numPages].page];
macroStorageStart ← LOOPHOLE[buf, LONG POINTER TO WORD];
freeMacroSpace ← macroInitialFree;
};
END.