[_CDCSL_93-16_]<1>Cedar>release>NPGS>NPGSScan.pgs

-- NPGSScan.pgs
-- Copyright Ó 1985, 1986, 1988, 1990 by Xerox Corporation. All rights reserved.
-- DO NOT CONVERT TO TIOGA FORMAT! (NPGS requires the mesa-style comments)
-- Russ Atkinson (RRA) March 17, 1988 10:14:22 am PST
-- Doug Wyatt, May 15, 1986 5:36:01 pm PDT
-- JKF May 24, 1990 10:02:00 am PDT

-- NPGS [defs: NPGSParseTable, grammar: NPGS] ¬ NPGSScan.pgs

DIRECTORY
IO USING [STREAM],
NPGS1 USING [
ActionStack, Index, LinkStack, Token, Value, ValueStack, nullValue, InputLoc],
NPGSParseTable USING [
endMarker, HashIndex, HashTableRef, IndexTableRef,
InitHashTable, InitIndexTable, InitScanTable, InitVocabulary,
ProdDataRef, ScanTableRef, TSymbol, VocabularyRef, tokenID, tokenNUM,
tokenTAB3, tokenTAB4],
NPGSConDefs USING [
aliases, alternateLim,
CuspPreSetPriorityTokenArray, -- new for CUSP
eofMark, ExpandAliases, ExpandProdInfo, ExpandRhsChar,
ExpandSymTab, flags, getindex, inchar, MakeAliases, MakeProdInfo,
MakeRhsChar, MakeSymInfo, MakeSymTab, MakeTokenInfo, maxProd,
maxRhsSymbols, maxRule, nextAlias, numProd, numRules, outbufLim,
outchar, outeol, outnum, outstring, prodInfo, pssLim, resetoutstream,
rhsChar, rhsLim, seterrstream, setindex, setoutstream, symInfo, symTab,
symTabSize, tokenInfo, tokenSize, totalTokens, warningsLogged],
NPGSTypes USING [Options],
Rope USING [FromRefText, Length, ROPE];

NPGSScan: CEDAR PROGRAM
IMPORTS NPGS1, NPGSConDefs, NPGSParseTable, Rope
EXPORTS NPGS1, NPGSConDefs
= { OPEN NPGS1, NPGSParseTable, NPGSConDefs;

ROPE: TYPE = Rope.ROPE;
STREAM: TYPE = IO.STREAM;

-- TreeBuild: interpreter section

-- interpreter state

check: NAT = 3;
warning: NAT = 0;
specErrorCases: NAT = 5;

token, numRhsChars: CARDINAL ¬ 0;
lineWidth: INTEGER;
insertFlag: CARDINAL;

HashChainArray: TYPE = ARRAY [1..symTabSize/4] OF CARDINAL;
hashChain: REF HashChainArray;

-- local data base (supplied by parser)

v: NPGS1.ValueStack;
l: NPGS1.LinkStack;

q: NPGS1.ActionStack;

prodData: ProdDataRef;

-- initialization/termination

AssignDescriptors: PUBLIC PROC [
qd: NPGS1.ActionStack, vd: NPGS1.ValueStack, ld: NPGS1.LinkStack, pp: ProdDataRef] = {
q ¬ qd;
v ¬ vd;
l ¬ ld;
prodData ¬ pp;
};

OutToken: PUBLIC PROC [symbol: CARDINAL] RETURNS [CARDINAL] = {
r: ROPE = "* * *";
IF symbol = 0 THEN {outstring[r]; RETURN[Rope.Length[r]]};
FOR i: CARDINAL IN [0..symInfo[symbol].length) DO
outchar[symTab[symbol*tokenSize+i],1];
ENDLOOP;
RETURN [symInfo[symbol].length];
};

-- the interpretation rules

prix, chix: CARDINAL ¬ 0; --indexes into prodInfo and rhsChar
rhsFlag: BOOL;
lastSymbol, lhsDef: CARDINAL ¬ 0;

ProcessQueue: PUBLIC PROC [qI, top: CARDINAL, cusp: BOOL] = {
i, j, k: CARDINAL;

-- local procedures
PrintTableHead: PROC [c: CHAR] = {
IF flags[echo] THEN {outeol[2]; outstring["||TABLE"]; outchar[c,1]; outeol[1]};
};

SetRuleChain: PROC [rule: CARDINAL, chain: BOOL] = {
FixLastProd[];
IF prix=prodInfo.length THEN --production table overflow
prodInfo ¬ ExpandProdInfo[prodInfo, prodInfo.length/8];
prodInfo[prix].chain ¬ chain;
numRules ¬ MAX[numRules, rule];
IF rule>maxRule THEN Error[check+10,-5,InputLoc[]] ELSE prodInfo[prix].rule ¬ rule;
};

FixLastProd: PROC = {
eofMark: CARDINAL ¬ NPGSConDefs.eofMark;
prodInfo[prix-1].lhs ¬ lhsDef;
IF prodInfo[prix-1].count=0 THEN tokenInfo[lhsDef-eofMark].empty ¬ TRUE;
IF rhsFlag THEN {
-- too many rhsChars
rhsFlag ¬ FALSE;
Error[check+5, (prix-1+specErrorCases), InputLoc[]];
};
};

ProdHeader: PROC [new: BOOL] = {
prodInfo[prix].index ¬ chix;
IF lhsDef>eofMark THEN {
IF tokenInfo[lhsDef-eofMark].count=alternateLim THEN {
Error[check+1, lhsDef,InputLoc[]]; --too many alternatives
tokenInfo[lhsDef-eofMark].count ¬1;
};
tokenInfo[lhsDef-eofMark].count ¬ tokenInfo[lhsDef-eofMark].count + 1;
};
IF flags[echo] THEN {
lineWidth ¬ outbufLim-tokenSize-14;
outeol[IF new THEN 2 ELSE 1];
outnum[prix,3];
outstring[IF prodInfo[prix].chain THEN " C " ELSE " "];
outnum[prodInfo[prix].rule,3]; outchar[' ,2];
outchar[' ,tokenSize-(IF new THEN OutToken[lhsDef] ELSE 0)];
outstring[IF new THEN " ::= " ELSE " | "];
};
prix ¬ prix+1;
};

LhsSymbol: PROC [symbol: CARDINAL] = {
lhsDef ¬ symbol;
IF lhsDef<=eofMark
THEN Error[check+4,lhsDef,InputLoc[]]
-- undefined or terminal symbol before ::=
ELSE
IF tokenInfo[lhsDef-eofMark].index = 0
THEN tokenInfo[lhsDef-eofMark].index ¬ prix
ELSE Error[check+2,lhsDef,InputLoc[]]; --multiple definitions
ProdHeader[TRUE];
};
-- end of local procedures

FOR qj: CARDINAL IN [0..qI) DO
top ¬ top-q[qj].tag.pLength+1;
SELECT prodData[q[qj].transition].rule FROM

0 => -- TYPE: NPGSParseTable EXPORTS: SELF
-- GOAL: grammar
-- TERMINALS:
-- symbol num '? '| "::=" 'C "||TABLE1" "||TABLE2" "||TABLE3"
-- "||TABLE4" "||INPUT" "||CHAIN" "||LISTS" "||PRINTLR"
-- "||PRINTLALR" "||FIRST" "||IDS" "GOAL"
-- ALIASES: symbol tokenID num tokenNUM '? tokenQUERY
-- "||TABLE3" tokenTAB3 "||TABLE4" tokenTAB4 '? initialSymbol
-- PRODUCTIONS:
-- grammar ::= '? head ruleset
{
FixLastProd[];
numProd ¬ prix-1;
numRhsChars ¬ chix-1;
i ¬ 1;
IF flags[echo] THEN outeol[1];
IF numProd > pssLim OR totalTokens > pssLim THEN Error[check+6,0,InputLoc[]];
IF cusp THEN CuspPreSetPriorityTokenArray[hashChain]; -- new for CUSP
hashChain ¬ NIL;
WHILE symInfo[i].used AND i <= totalTokens DO
IF i > eofMark AND tokenInfo[i-eofMark].index = 0 THEN EXIT;
i ¬ i+1;
ENDLOOP;
IF i <= totalTokens THEN {
defflag: BOOL ¬ FALSE;
lineWidth ¬ 0; Error[warning+3,0,InputLoc[]]; seterrstream[];
FOR i IN [i..totalTokens] DO
j ¬ 0; IF ~symInfo[i].used THEN j ¬ j+1;
IF i > eofMark AND tokenInfo[i-eofMark].index = 0 THEN j ¬ j+2;
IF j # 0 THEN {
IF (lineWidth ¬ lineWidth+(k¬(11+j)/2)) > outbufLim THEN {
outeol[1]; lineWidth ¬ k};
outnum[i,5];
IF j#2 THEN outchar['U,1] ELSE defflag ¬ TRUE;
IF j>1 THEN outchar['D,1]};
ENDLOOP;
outeol[1]; resetoutstream[];
IF defflag THEN
-- nonterminal used but not defined
Error[check+3,-2,InputLoc[]];
};
FOR i IN [1..numProd] DO
IF prodInfo[i].chain THEN
IF prodInfo[i].count # 1 OR rhsChar[prodInfo[i].index] <= eofMark THEN {
Error[warning+2, -(i+specErrorCases), InputLoc[]];
prodInfo[i].chain ¬ FALSE;
};
ENDLOOP;
FinishInput[];
};

1 => -- head ::= directives terminals nonterminals "||TABLE4"
-- head ::= directives terminals nonterminals aliases "||TABLE4"
{
totalTokens ¬ lastSymbol; PrintTableHead['4];
tokenInfo ¬ MakeTokenInfo[totalTokens-eofMark+1];
numRules ¬ 0;
prodInfo ¬ MakeProdInfo[maxProd+1];
rhsChar ¬ MakeRhsChar[maxRhsSymbols+1];
FOR i IN [0..totalTokens-eofMark] DO
tokenInfo[i] ¬ [count:0, empty:FALSE, index:0];
ENDLOOP;
prodInfo[0] ¬ [count:2, rule:0, chain:FALSE, lhs:0, index:0];
FOR i IN [1..maxProd] DO
prodInfo[i] ¬ [count:0, rule:0, chain:FALSE, lhs:0, index:0];
ENDLOOP;
IF flags[echo] THEN {
outeol[1];
outchar[' ,20];
outstring["GOAL ::= "];
[] ¬ OutToken[eofMark+1]; outchar[' ,1];
[] ¬ OutToken[eofMark];
};
rhsChar[0] ¬ eofMark+1;
rhsChar[1] ¬ eofMark;
symInfo[eofMark+1].used ¬ symInfo[eofMark].used ¬ TRUE;
prix ¬ 1; chix ¬ 2; lhsDef ¬ 0; rhsFlag ¬ FALSE;
};

2 => -- directives ::=
{flags ¬ ALL[FALSE]; l[top] ¬ InputLoc[]};

3 => -- directive ::= "||INPUT"
{flags[echo] ¬ TRUE; setoutstream[".echo"]};

4 => -- directive ::= "||CHAIN"
flags[chain] ¬ TRUE;

5 => -- directive ::= "||LISTS"
flags[lists] ¬ TRUE;

6 => -- directive ::= "||PRINTLR"
flags[printLR] ¬ TRUE;

7 => -- directive ::= "||PRINTLALR"
flags[printLALR] ¬ TRUE;

8 => -- directive ::= "||FIRST"
flags[first] ¬ TRUE;

9 => -- directive ::= "||IDS"
flags[ids] ¬ TRUE;

10 => -- terminals ::= "||TABLE1"
{
IF flags[echo] THEN {
outeol[1];
FOR opt: NPGSTypes.Options IN NPGSTypes.Options DO
IF flags[opt] THEN outstring[
SELECT opt FROM
echo => "||INPUT ",
chain => "||CHAIN ",
lists => "||LISTS ",
printLR => "||PRINTLR ",
printLALR => "||PRINTLALR ",
first => "||FIRST ",
ENDCASE => "||IDS "];
ENDLOOP;
};
PrintTableHead['1];
};

11 => -- terminals ::= terminals discard symbol
-- nonterminals ::= nonterminals discard symbol
{
lastSymbol ¬ v[top+2].s;
IF flags[echo] THEN {
outnum[lastSymbol, 3]; outchar[' , 2];
[] ¬ OutToken[lastSymbol];
outeol[1]};
};

12 => -- nonterminals ::= "||TABLE2"
{
PrintTableHead['2]; eofMark ¬ lastSymbol;
nextAlias ¬ 0; -- assert TABLE3 empty in case it is omitted
aliases ¬ NIL;
};

13 => -- aliases ::= "||TABLE3"
{
PrintTableHead['3];
aliases ¬ MakeAliases[64];
};

14 => -- aliases ::= aliases symbol symbol
{temp: UNSPECIFIED ¬ NPGSConDefs.eofMark;
IF v[top+1].s>temp THEN Error[check+7,v[top+1].s,InputLoc[]];
IF v[top+2].s<=temp THEN Error[check+8,v[top+2].s,InputLoc[]];
IF nextAlias=aliases.length THEN
aliases ¬ ExpandAliases[aliases, aliases.length/8];
aliases[nextAlias] ¬ [v[top+1].s,v[top+2].s]; nextAlias ¬ nextAlias+1;
IF flags[echo] THEN {
outchar[' ,tokenSize+1-OutToken[v[top+1].s]]; outchar[' ,1];
j ¬ CARDINAL[v[top+2].s]*tokenSize;
FOR i IN [j..j+tokenSize) WHILE symTab[i]#0C DO outchar[symTab[i],1] ENDLOOP;
outeol[1]};
};

15 => -- discard ::=
l[top] ¬ InputLoc[]; -- keep the parser error recovery happy

16 => -- rulegroup ::= symbol "::="
{SetRuleChain[prix, FALSE]; LhsSymbol[v[top].s]};

17 => -- rulegroup ::= prefix symbol "::="
LhsSymbol[v[top+1].s];

18 => -- rulegroup ::= rulegroup symbol "::="
{SetRuleChain[prix, FALSE]; LhsSymbol[v[top+1].s]};

19 => -- rulegroup ::= rulegroup prefix symbol "::="
LhsSymbol[v[top+2].s];

20 => -- rulegroup ::= rulegroup '|
{SetRuleChain[prix, FALSE]; ProdHeader[FALSE]};

21 => -- rulegroup ::= rulegroup prefix '|
ProdHeader[FALSE];

22 => -- rulegroup ::= rulegroup symbol
{temp: CARDINAL ¬ 0;
i ¬ v[top+1].s; symInfo[i].used ¬ TRUE;
IF i=eofMark OR i=eofMark+1 THEN Error[check+9,0,InputLoc[]]; --goal symbols
IF flags[echo] THEN {
IF lineWidth<symInfo[i].length THEN {
outeol[1]; outchar[' ,tokenSize+18]; lineWidth ¬ outbufLim - tokenSize-18};
IF (lineWidth ¬ (lineWidth-OutToken[i]-1)) > 0 THEN outchar[' , 1]};
IF chix=rhsChar.length THEN
rhsChar ¬ ExpandRhsChar[rhsChar, rhsChar.length/8];
rhsChar[chix]¬i; chix ¬ chix +1;
IF prodInfo[prix-1].count = rhsLim THEN {
prodInfo[prix-1].count ¬ 1; rhsFlag ¬ TRUE};
temp ¬ prodInfo[prix-1].count;
prodInfo[prix-1].count ¬ temp+1;
};

23 => -- prefix ::= num
SetRuleChain[v[top].s, FALSE];

24 => -- prefix ::= num num
-- prefix ::= '? num
SetRuleChain[v[top+1].s, FALSE];

25 => -- prefix ::= discard 'C
SetRuleChain[prix, TRUE];

26 => -- prefix ::= discard 'C num
SetRuleChain[v[top+2].s, TRUE];

27 => -- prefix ::= '?
SetRuleChain[prix, FALSE];

28 => -- directives ::= directives directive
-- discard ::= num
-- discard ::= '?
-- ruleset ::=C rulegroup
-- ruleset ::= goalrule rulegroup
-- goalrule ::= "GOAL" "::=" symbol symbol
NULL;
ENDCASE => ERROR;
ENDLOOP;
};

-- the following procedure is called from the ScanReset if no errors

FinishInput: PROC = {
emptyFlag: BOOL ¬ TRUE;
j, k: CARDINAL;
-- compute nonterminals deriving empty
WHILE emptyFlag DO
emptyFlag ¬ FALSE;
FOR i: CARDINAL IN [1..totalTokens-eofMark] DO -- each nonterminal
IF tokenInfo[i].empty THEN LOOP; --which does not derive empty
j ¬ tokenInfo[i].index;
FOR prix: CARDINAL IN [j..j+tokenInfo[i].count) DO
-- each production of the nonterminal
k ¬ prodInfo[prix].index;
FOR chix: CARDINAL IN [k..k+prodInfo[prix].count) DO -- each rhs character
IF rhsChar[chix]<=eofMark OR ~tokenInfo[rhsChar[chix]-eofMark].empty THEN EXIT;
REPEAT FINISHED => {tokenInfo[i].empty ¬ emptyFlag ¬ TRUE; EXIT};
ENDLOOP
ENDLOOP
ENDLOOP
ENDLOOP;
};

-- the following procedure outputs the data structure contents in the tables:
-- PRODUCTIONINFO TOKENINFO SYMINFO
-- num count rule chain lhs index count empty index link used length symbol
-- 4 1 3 5 1 4 5 2 3 1 5 2 4 1 3 1 ...

CheckOut: PUBLIC PROC = {
IF flags[ids] THEN {
seterrstream[]; outeol[1];
outstring[" PRODUCTIONINFO TOKENINFO SYMINFO"];
FOR i: CARDINAL IN [0..MAX[numProd,totalTokens]] DO
outeol[1]; outnum[i,4]; outchar[' ,1];
IF i>numProd THEN outchar[' ,20]
ELSE {
outnum[prodInfo[i].count,3]; outnum[prodInfo[i].rule,5];
outchar[IF prodInfo[i].chain THEN 'C ELSE ' , 1];
outnum[prodInfo[i].lhs,4]; outnum[prodInfo[i].index,5]; outchar[' ,2]};
IF i IN (0..totalTokens] THEN {
IF i<=eofMark THEN outchar[' ,11] ELSE {
outnum[tokenInfo[i-eofMark].count,3];
outchar[IF tokenInfo[i-eofMark].empty THEN 'E ELSE ' ,1];
outnum[tokenInfo[i-eofMark].index,5]; outchar[' ,2]};
outnum[symInfo[i].link,4]; outchar[IF symInfo[i].used THEN 'U ELSE ' ,1];
outnum[symInfo[i].length,3]; outchar[' ,1]; [] ¬ OutToken[i]}
ENDLOOP;
outeol[1]; outstring["RHSCHAR"]; lineWidth ¬ outbufLim;
FOR i: CARDINAL IN [0..numRhsChars] DO
lineWidth ¬ lineWidth+tokenSize+1;
IF lineWidth > outbufLim THEN {outeol[1]; outnum[i,4]; lineWidth ¬ 4};
outchar[' ,1]; [] ¬ OutToken[rhsChar[i]];
ENDLOOP;
outeol[1]; resetoutstream[];
};
};

-- error recovery

TokenValue: PUBLIC PROC [s: TSymbol] RETURNS [NPGS1.Value] = {
RETURN [NPGS1.nullValue];
};

-- Scanner: text input and error routines

-- table installation

hashTab: HashTableRef;
scanTab: ScanTableRef;
vocab: VocabularyRef;
vocabIndex: IndexTableRef;

InstallScanTable: PUBLIC PROC = {
hashTab ¬ NPGSParseTable.InitHashTable[];
scanTab ¬ NPGSParseTable.InitScanTable[];
vocab ¬ NPGSParseTable.InitVocabulary[];
vocabIndex ¬ NPGSParseTable.InitIndexTable[];
};

-- scanner state

stream: STREAM ¬ NIL; -- the input stream (a dummy for now)
Logger: PROC [PROC [log: STREAM]] ¬ NIL;

NUL: CHAR = '\000;

buffer: REF TEXT ¬ NIL; -- token assembly area

nTokens: CARDINAL ¬ 0; -- token count
nErrors: CARDINAL; -- lexical errors

char: CHAR; -- current (most recently scanned) character
tI: CARDINAL ¬ 0; -- its (stream) index
eof: BOOL;

NextChar: PROC = { -- also expanded inline within Atom
tI ¬ tI + 1; [char, eof] ¬ inchar[]};

NextToken: PUBLIC PROC RETURNS[t: Token] = {
--OPEN t;

LocateToken: PROC[string: REF TEXT] RETURNS[CARDINAL] = {
-- returns token corresponding to string
i, j: CARDINAL;
j ¬ hashChain[(string.length*256+(string[0].ORD)) MOD (symTabSize/4) + 1];
WHILE j # 0 DO
IF symInfo[j].length = string.length THEN {
i ¬ j*tokenSize;
FOR k: CARDINAL IN [0..string.length) DO
IF symTab[i+k]#string[k] THEN EXIT
REPEAT FINISHED => RETURN [j]
ENDLOOP;
};
j ¬ symInfo[j].link;
ENDLOOP;
RETURN [0];
};

TokenToSymTab: PROC[string: REF TEXT, token: CARDINAL] = {
i, j: CARDINAL;
i ¬ token*tokenSize;
FOR j IN [0..string.length) DO symTab[i+j] ¬ string[j] ENDLOOP;
symInfo[token].length ¬ string.length; symInfo[token].used ¬ FALSE;
j ¬ (string.length*256+(string[0].ORD)) MOD (symTabSize/4) + 1;
symInfo[token].link ¬ hashChain[j];
hashChain[j] ¬ token;
};

TokenOrId: PROC[sub: CARDINAL] = {
j, s1, s2: CARDINAL;
h: HashIndex;
WHILE char NOT IN [NUL..' ] DO
IF sub<tokenSize THEN buffer[sub] ¬ char;
sub ¬ sub + 1; NextChar[];
ENDLOOP;
IF sub>tokenSize THEN {
buffer.length ¬ sub ¬ tokenSize; Error[1,-1,t.index]}; --overlength
IF sub = 1 THEN {
t.class ¬ scanTab[buffer[0]];
IF t.class # 0 THEN RETURN};
j ¬ buffer[0] - 0C;
h ¬ ((j*128-j) + CARDINAL[buffer[sub-1]-0C]) MOD HashIndex.LAST + 1;
WHILE (j ¬ hashTab[h].symbol) # 0 DO
IF vocabIndex[j]-(s2¬vocabIndex[j-1]) = sub THEN
FOR s1 IN [0 .. sub) DO
IF buffer[s1] # vocab.text[s2] THEN EXIT;
s2 ¬ s2+1;
REPEAT FINISHED => {
IF j = tokenTAB3 THEN insertFlag ¬ 2 ELSE
IF j = tokenTAB4 THEN insertFlag ¬ 3;
IF j<=tokenNUM THEN EXIT;
t.class ¬ j; RETURN};
ENDLOOP;
IF (h ¬ hashTab[h].link) = 0 THEN EXIT;
ENDLOOP;
buffer.length ¬ sub; t.class ¬ tokenID; t.value.s ¬ LocateToken[buffer];
SELECT insertFlag FROM
1 =>
-- reading terminals and nonterminals
IF t.value # NPGS1.nullValue
THEN Error[check+2,t.value.s,t.index] -- multiply defined symbol
ELSE {
IF token=symTab.length THEN {
symTab ¬ ExpandSymTab[symTab, symTab.length/16];
symTab ¬ ExpandSymTab[symTab, symInfo.length/16];
};
TokenToSymTab[buffer, token];
t.value.s ¬ token; --[scalar[token]];
token ¬ token+1;
};
2 =>
-- processing aliases
IF t.value=NPGS1.nullValue THEN {
s1 ¬ token*tokenSize;
IF token=symTab.length THEN
symTab ¬ ExpandSymTab[symTab, symTab.length/16];
FOR j IN [0..buffer.length) DO symTab[s1+j] ¬ buffer[j] ENDLOOP;
t.value.s ¬ token; --[scalar[token]];
token ¬ token+1;
};
3 =>
-- processing productions
IF t.value = NPGS1.nullValue THEN Error[check+3,-3,t.index]; --symbol not defined
ENDCASE;
};

DO
WHILE char IN [NUL..' ] DO
SELECT char FROM
'\032 --^Z-- =>
UNTIL char = '\n DO
IF eof THEN GO TO EndFile;
NextChar[];
ENDLOOP;
ENDCASE;
IF eof THEN GO TO EndFile;
NextChar[];
ENDLOOP;
t.index ¬ tI;
t.value.s ¬ NPGS1.nullValue;

SELECT char FROM
IN ['0..'9] => {
val: CARDINAL ¬ 0;
valid: BOOL ¬ TRUE;
maxVal: CARDINAL = CARDINAL.LAST;
WHILE char IN ['0..'9] DO
IF valid THEN {
d: [0..9] = char.ORD-'0.ORD;
valid ¬ val<maxVal/10 OR (val=maxVal/10 AND d<=(maxVal MOD 10));
IF valid THEN val ¬ 10*val+d};
NextChar[];
ENDLOOP;
IF ~valid THEN val ¬ maxVal;
t.class ¬ tokenNUM; t.value.s ¬ val; GO TO GotNext}; --[scalar[val]]; GO TO GotNext};
'- => {
NextChar[];
IF char # '- THEN {buffer[0] ¬ '-; TokenOrId[1]; GO TO GotNext};
char ¬ NUL;
DO
pChar: CHAR = char;
IF eof THEN GO TO EndFile;
NextChar[];
SELECT char FROM
'- => IF pChar = '- THEN EXIT;
'\n => EXIT;
ENDCASE;
ENDLOOP;
NextChar[];
};
ENDCASE => {TokenOrId[0]; GO TO GotNext};
REPEAT
GotNext => NULL;
EndFile => {t.class ¬ endMarker; t.index ¬ tI; t.value.s ¬ NPGS1.nullValue};
ENDLOOP;
nTokens ¬ nTokens + 1;
};

-- initialization/finalization

ScanInit: PUBLIC PROC [source: STREAM, logger: PROC [PROC [log: STREAM]]] = {
stream ¬ source; Logger ¬ logger;
buffer ¬ NEW[TEXT[tokenSize]];
tI ¬ 0;
[char, eof] ¬ inchar[];
nTokens ¬ nErrors ¬ 0;
buffer.length ¬ tokenSize;

-- initialise symbol table
token ¬ 1; insertFlag ¬ 1;
symTab ¬ MakeSymTab[(symTabSize+1)*tokenSize];
symInfo ¬ MakeSymInfo[symTabSize+1];
FOR i: CARDINAL IN [1..symTabSize] DO
symInfo[i] ¬ [link:0, length:0, used:FALSE];
ENDLOOP;
hashChain ¬ NEW[HashChainArray ¬ ALL[0]];
};

ScanReset: PUBLIC PROC = {
stream ¬ NIL;
Logger ¬ NIL;
CheckOut[];
buffer ¬ NIL;
};

ScanStats: PUBLIC PROC RETURNS[CARDINAL, CARDINAL] = {
RETURN [nTokens, nErrors];
};

-- error handling

ResetScanIndex: PUBLIC PROC[index: CARDINAL] RETURNS[success: BOOL¬TRUE] = {
IF index = tI THEN RETURN;
setindex[index];
[char, eof] ¬ inchar[];
tI ¬ index;
};

PrintTextLine: PROC[origin: CARDINAL] RETURNS[start: CARDINAL] = {
lineIndex: CARDINAL;
char: CHAR;
n: [1..100];
start ¬ lineIndex ¬ origin;
FOR n IN [1..100] UNTIL lineIndex = 0 DO
lineIndex ¬ lineIndex - 1;
setindex[lineIndex];
IF inchar[].c = '\n THEN EXIT;
start ¬ lineIndex;
ENDLOOP;
setindex[start];
FOR n IN [1..100] UNTIL ([c: char] ¬ inchar[]).end DO
SELECT char FROM
'\n, '\032 --^Z-- => EXIT;
ENDCASE => outchar[char,1];
ENDLOOP;
outeol[1];
};

ErrorContext: PUBLIC PROC [to: STREAM, message: ROPE, tokenIndex: CARDINAL] = {
saveIndex: CARDINAL = getindex[];
origin: CARDINAL = tokenIndex;
char: CHAR;
setindex[PrintTextLine[origin]];
UNTIL getindex[] = origin OR ([c: char] ¬ inchar[]).end DO
outchar[IF char = '\n THEN '\n ELSE ' ,1];
ENDLOOP;
outstring["^ ["]; outnum[tokenIndex,1];
outchar['],1]; outeol[1]; outstring[message];
setindex[saveIndex];
};

Error: PROC [code: CARDINAL, control: INTEGER, index: CARDINAL] = {

Inner: PROC [log: STREAM -- a dummy for now --] ~ {
ErrorContext[log,
SELECT code FROM
1 => "WARNING - Overlength symbol (increase TOKENSIZE?) truncated to - ",
2 => "WARNING - Not a chain production - ",
3 => "WARNING - Unused(U) or undefined(D)symbols (refer to TABLE1 and 2)",
4 => "ERROR - Nonterminal with too many rules (increase ALTERNATELIM?) - ",
5 => "ERROR - Multiple definitions of symbol - ",
6 => "ERROR - Symbol not defined - ",
7 => "ERROR - Terminal precedes ::= - ",
8 => "ERROR - Too many rhs symbols in production (increase RHSLIM?) - ",
9 => "ERROR - Internal field will overflow - increase PSSLIM",
10 => "ERROR - Aliased symbol not a terminal symbol - ",
11 => "ERROR - Aliases must not be terminal symbols - ",
12 => "ERROR - Goal symbols used in rhs",
13 => "ERROR - Number greater than ",
ENDCASE => NIL,
index];
SELECT -control FROM
<0 => [] ¬ OutToken[control];
0 => NULL;
1 => outstring[Rope.FromRefText[buffer]];
2 => outstring["see previous message"];
3 => {outstring[Rope.FromRefText[buffer]]; outstring[" not in TABLE1 or 2"]};
4 => NULL; -- not used
5 => outstring["MAXRULE"];
ENDCASE => outnum[-control-specErrorCases, 5];
outeol[2];
};

Logger[Inner];
IF code>check THEN nErrors ¬ nErrors+1 ELSE warningsLogged ¬ TRUE;
};

}.