-- file SMReaderImpl.mesa
-- last modified by Satterthwaite, August 4, 1983 10:01 am
-- last edit by Schmidt, May 16, 1983 5:27 pm
DIRECTORY
CS: TYPE USING [RopeFromStamp, SetPFCodes, z],
IO: TYPE USING [
atom, card, EndOf, GetChar, GetIndex, Handle, int, Put, PutChar, PutF,
rope, SetIndex, STREAM, string],
SMP1: TYPE --P1-- USING [InstallParseTable, Parse],
Runtime: TYPE USING [GetTableBase],
Rope: TYPE USING [Map, ROPE, Text],
SMCommentTable: TYPE USING [Index, Ref, Text],
SMCommentTableOps: TYPE USING [Create, Explode, FindNext, Reset],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMLDriver: TYPE USING [Create],
SMOps: TYPE USING [ModelState, MS],
SMParseData: TYPE USING [],
SMUtil: TYPE USING [],
SMTree: TYPE Tree USING [
AttrId, Handle, Id, Link, NodeName, Name, Number, Stamp, Text,
null, nullId, nullName],
SMTreeOps: TYPE --TreeOps-- USING [
TM, Scan, Create, GetName, NthSon, PopTree, ScanSons];
-- this monitor protects the model parsing code
SMReaderImpl: CEDAR MONITOR
IMPORTS
CS, IO, SMP1, Rope, Runtime, SMCommentTableOps, SMLDriver, SMTreeOps,
SMParseData
EXPORTS SMUtil, SMOps ~ {
OPEN P1~~SMP1, Tree~~SMTree, TreeOps~~SMTreeOps;
tabSize: CARDINAL ~ 8; -- usually 8
-- mds usage
parserCondition: CONDITION;
parserBusy: BOOL ← FALSE;
-- end of mds usage
AcquireModelParser: ENTRY PROC ~ {
ENABLE UNWIND => {NULL};
WHILE parserBusy DO WAIT parserCondition ENDLOOP;
parserBusy ← TRUE};
ReleaseModelParser: ENTRY PROC ~ {
ENABLE UNWIND => {NULL};
parserBusy ← FALSE;
NOTIFY parserCondition};
-- parsing sequencing
ParseStream: PUBLIC PROC[m: SMOps.MS, source: IO.STREAM] RETURNS[root: Tree.Link] ~ {
ENABLE UNWIND => {ReleaseModelParser[]};
AcquireModelParser[];
IF m.comments # NIL THEN (m.comments).Reset;
{complete: BOOL ← TRUE;
nTokens, nErrors: CARDINAL ← 0;
TRUSTED {[complete, nTokens, nErrors] ← P1.Parse[m, source]};
root ← (IF complete --AND nErrors = 0-- THEN (m.tm).PopTree ELSE Tree.null);
};
ReleaseModelParser[]};
SourceIndex: TYPE ~ SMCommentTable.Index;
-- basic io
WriteQuotedText: PROC[s: Rope.ROPE, out: IO.Handle] ~ {
EachChar: PROC[c: CHAR] RETURNS[BOOL←FALSE] ~ {
out.PutChar[c];
IF c = '" THEN out.PutChar['"]};
IF s # NIL THEN {
out.PutChar['"]; [] ← Rope.Map[base~s, action~EachChar]; out.PutChar['"]};
};
Indent: PROC[n: NAT, out: IO.Handle] ~ {
out.PutChar['\n];
THROUGH [1..n/tabSize] DO out.PutChar['\t] ENDLOOP;
THROUGH [1.. n MOD tabSize] DO out.PutChar[' ] ENDLOOP};
-- tree printing
PrintTree: PUBLIC PROC[m: SMOps.MS, t: Tree.Link] ~ {
PrintSubTree[m.out, t, 0];
(m.out).PutF["\n"];
IF m.comments # NIL THEN {
index: SourceIndex ← 0;
comments: BOOL ← FALSE;
DO
ref: SMCommentTable.Ref ~ (m.comments).FindNext[index];
IF ref = NIL THEN EXIT;
IF ~comments THEN (m.out).Put[IO.string["\nComments:"L]]; comments ← TRUE;
(m.out).Put[IO.string["\n "L]]; (m.out).Put[IO.card[index]];
index ← SMCommentTableOps.Explode[ref].start+1;
ENDLOOP;
IF comments THEN (m.out).PutF["\n"]};
};
PrintSubTree: PUBLIC PROC[out: IO.Handle, t: Tree.Link, nBlanks: NAT] ~ {
OPEN Tree;
Printer: TreeOps.Scan ~ TRUSTED {
Indent[nBlanks, out];
IF t = Tree.null THEN out.Put[IO.string["<empty>"L]]
ELSE
WITH t SELECT FROM
name: Tree.Name => PrintName[name, out];
id: Tree.Id => PrintId[id, out];
node: Tree.Handle => {
WriteNodeName[node.name, out];
IF node.info # 0 THEN {
out.Put[IO.string[" info="L]]; out.Put[IO.card[node.info]]};
IF node.attrs # ALL[FALSE] THEN {
IF node.info = 0 THEN out.PutChar[' ];
out.PutChar['(];
FOR i: Tree.AttrId IN Tree.AttrId DO
IF node.attrs[i] THEN out.PutChar[VAL[i+'0.ORD]] ENDLOOP;
out.PutChar[')]};
nBlanks ← nBlanks + 2;
TreeOps.ScanSons[t, Printer];
nBlanks ← nBlanks - 2};
fiSrc: SMFI.SrcFileInfo => out.PutF["(fiSrc: %s)", IO.rope[fiSrc.localName]];
fiBcd: SMFI.BcdFileInfo => out.PutF["(fiBcd: %s)", IO.rope[fiBcd.localName]];
ENDCASE => PrintLiteral[t, out];
};
Printer[t]};
WriteNodeName: PROC[n: Tree.NodeName, out: IO.Handle] ~ {
out.Put[IO.string[SELECT n FROM
$none => "none"L,
$lambda => "lambda"L,
$let => "let"L,
$arrow => "arrow"L,
$apply => "apply"L,
$applyDefault => "apply*"L,
$subscript => "subscript"L,
$union => "union"L,
$then => "then"L,
$exclusion => "exclusion"L,
$restriction => "restriction"L,
$splitUpper => "splitUpper"L,
$splitLower => "splitLower"L,
$group => "group"L,
$decl => "decl"L,
$declElem => "declElem"L,
$bind => "bind"L,
$bindRec => "bindRec"L,
$bindElem => "bindElem"L,
$type => "type"L,
$env => "env"L,
$nil => "nil"L,
$control => "control"L,
$unitId => "unitId"L,
$uiList => "uiList"L,
$unQuote => "unQuote"L,
$typeTYPE => "typeTYPE"L,
$typeDECL => "typeDECL"L,
$typeBINDING => "typeBINDING"L,
$typePATTERN => "typePATTERN"L,
$typeSTRING => "typeSTRING"L,
$nBind => "nBind"L,
$nBindRec => "nBindRec"L,
$stamp => "stamp"L,
$cross => "cross"L,
$cross2 => "cross2"L,
$locator => "locator"L,
ENDCASE => ERROR]]
};
PrintLiteral: PROC[t: Tree.Link, out: IO.Handle] ~ {
WITH t SELECT FROM
text: Tree.Text => WriteQuotedText[text, out];
num: Tree.Number => out.Put[IO.int[num↑]];
stamp: Tree.Stamp => out.Put[IO.rope[CS.RopeFromStamp[stamp↑]]];
n: REF LONG CARDINAL => out.Put[IO.card[n↑]];
ENDCASE => out.PutChar['?]
};
PrintName: PROC[name: Tree.Name, out: IO.Handle] ~ {
out.Put[IF name = Tree.nullName THEN IO.string["(anon)"L] ELSE IO.atom[name]]};
PrintId: PROC[id: Tree.Id, out: IO.Handle] ~ {
IF id = Tree.nullId THEN out.Put[IO.string["<null>"L]]
ELSE {
d: Tree.Handle ~ (IF id.db.name = $decl THEN id.db ELSE NARROW[id.db[1]]);
out.Put[IO.atom[TreeOps.GetName[TreeOps.NthSon[d[id.p], 1]]]];
out.PutChar['[]; out.Put[IO.card[id.p]]; out.PutChar[']]};
};
NewModel: PUBLIC PROC[in, out, msgout: IO.Handle] RETURNS[SMOps.MS] ~ {
tm: TreeOps.TM;
CS.SetPFCodes[out]; -- causes start trap, which initializes CS.z
tm ← TreeOps.Create[CS.z];
RETURN [(CS.z).NEW[SMOps.ModelState ← [
in~in, out~out, msgOut~msgout,
z~CS.z,
tm~tm,
comments~SMCommentTableOps.Create[CS.z],
ls~SMLDriver.Create[CS.z, tm, out]]]]
};
-- source is the input file
-- out is where to print the error message
-- message is the message
-- tokenIndex is the position of the error in the text
ErrorContext: PUBLIC PROC[source, out: IO.Handle, message: Rope.ROPE, tokenIndex: INT] ~ {
saveIndex: INT ~ source.GetIndex[];
lineIndex, start: INT ← tokenIndex;
char: CHAR;
FOR n: NAT IN [1..100] UNTIL lineIndex = 0 DO
lineIndex ← lineIndex - 1;
source.SetIndex[lineIndex];
IF source.GetChar[] = '\n THEN EXIT;
start ← lineIndex;
ENDLOOP;
source.SetIndex[start]; -- start points to the first char on the line
FOR n: NAT IN [1..100] UNTIL source.EndOf[] DO
char ← source.GetChar[];
SELECT char FROM
'\n => EXIT;
ENDCASE => out.PutChar[char];
ENDLOOP;
out.PutChar['\n];
source.SetIndex[start]; -- start points to the first char on the line
UNTIL source.GetIndex[] = tokenIndex OR source.EndOf[] DO
char ← source.GetChar[]; -- print out right number of spaces
out.PutChar[IF char = '\t THEN '\t ELSE ' ];
ENDLOOP;
out.PutF["↑ %s [%d]\n", IO.rope[message], IO.card[tokenIndex]];
source.SetIndex[saveIndex]};
-- initialization code
TRUSTED {P1.InstallParseTable[Runtime.GetTableBase[LOOPHOLE[SMParseData]]]};
}.