
<<SMReaderImpl.mesa>>
<<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
<<last edit by Satterthwaite, May 12, 1986 11:48:10 am PDT>>

DIRECTORY
CS: TYPE USING [RopeFromStamp, z],
IO: TYPE USING [
atom, card, EndOf, GetChar, GetIndex, int, Put, PutChar, PutF, PutRope,
rope, SetIndex, STREAM],
PrincOpsUtils: TYPE USING [Codebase],
Rope: TYPE USING [Map, ROPE],
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],
SMP1: TYPE P1 USING [InstallParseTable, Parse],
SMParseData: 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],
SMUtil: TYPE USING [];

SMReaderImpl: CEDAR MONITOR    -- this monitor protects the model parsing code
IMPORTS
CS, IO, PrincOpsUtils, Rope, SMCommentTableOps, SMLDriver, SMP1, SMTreeOps,
SMParseData
EXPORTS SMUtil, SMOps ~ {
OPEN P1~~SMP1, Tree~~SMTree, TreeOps~~SMTreeOps;

tabSize: CARDINAL ~ 4;

<<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};


<<basic io>>

WriteQuotedText: PROC[s: Rope.ROPE, out: IO.STREAM] ~ {

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.STREAM] ~ {
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).PutChar['\n];
IF m.comments # NIL THEN {
index: SMCommentTable.Index _ 0;
comments: BOOL _ FALSE;
DO
ref: SMCommentTable.Ref ~ (m.comments).FindNext[index];
IF ref = NIL THEN EXIT;
IF ~comments THEN (m.out).PutRope["\nComments:"];  comments _ TRUE;
(m.out).PutChar['\n]; (m.out).PutChar[' ];  (m.out).Put[IO.card[index]];
index _ SMCommentTableOps.Explode[ref].start + 1;
ENDLOOP;
IF comments THEN (m.out).PutChar['\n]};
};

PrintSubTree: PUBLIC PROC[out: IO.STREAM, t: Tree.Link, nBlanks: NAT] ~ {

Printer: TreeOps.Scan ~ {
Indent[nBlanks, out];
IF t = Tree.null THEN out.PutRope["<empty>"]
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.PutRope["  info="];  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: %g)", IO.rope[fiSrc.localName]];
fiBcd: SMFI.BcdFileInfo => out.PutF["(fiBcd: %g)", IO.rope[fiBcd.localName]];
ENDCASE => PrintLiteral[t, out];
};

Printer[t]};

WriteNodeName: PROC[n: Tree.NodeName, out: IO.STREAM] ~ {
out.PutRope[SELECT n FROM
$none => "node",
$lambda => "lambda",
$let => "let",
$arrow => "arrow",
$arrow2 => "arrow2",
$apply => "apply",
$applyDefault => "applyDefault",
$subscript => "subscript",
$union => "union",
$then => "then",
$exclusion => "exclusion",
$restriction => "restriction",
$splitUpper => "splitUpper",
$splitLower => "splitLower",
$group => "group",
$decl => "decl",
$declElem => "declElem",
$bind => "bind",
$bindRec => "bindRec",
$bindElem => "bindElem",
$type => "type",
$env => "env",
$nil => "nil",
$control => "control",
$unitId => "unitId",
$uiList => "uiList",
$unQuote => "unQuote",
$typeTYPE => "typeTYPE",
$typeDECL => "typeDECL",
$typeBINDING => "typeBINDING",
$typePATTERN => "typePATTERN",
$typeSTRING => "typeSTRING",
$nBind => "nBind",
$nBindRec => "nBindRec",
$stamp => "stamp",
$cross => "cross",
$cross2 => "cross2",
$locator => "locator",
ENDCASE => ERROR]
};

PrintLiteral: PROC[t: Tree.Link, out: IO.STREAM] ~ {
WITH t SELECT FROM
text: Tree.Text => WriteQuotedText[text, out];
num: Tree.Number => out.Put[IO.int[num^]];
stamp: Tree.Stamp => out.PutRope[CS.RopeFromStamp[stamp^]];
n: REF LONG CARDINAL => out.Put[IO.card[n^]];
ENDCASE => out.PutChar['?];
};

PrintName: PROC[name: Tree.Name, out: IO.STREAM] ~ {
out.Put[IF name = Tree.nullName THEN IO.rope["(anon)"] ELSE IO.atom[name]]};

PrintId: PROC[id: Tree.Id, out: IO.STREAM] ~ {
IF id = Tree.nullId THEN out.PutRope["<null>"]
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[']]};
};


<<overall control>>

NewModel: PUBLIC PROC[in, out, msgout: IO.STREAM] RETURNS[SMOps.MS] ~ {
tm: TreeOps.TM;
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]]]]
};


ErrorContext: PUBLIC PROC[source, out: IO.STREAM, 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 for 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];
UNTIL source.GetIndex[] = tokenIndex OR source.EndOf DO
char _ source.GetChar[];    -- print out the right number of spaces
out.PutChar[IF char = '\t THEN '\t ELSE ' ];
ENDLOOP;
out.PutF["^ %g [%d]\n", IO.rope[message], IO.card[tokenIndex]];
source.SetIndex[saveIndex]};


<<initialization code>>

TRUSTED {
P1.InstallParseTable[LOOPHOLE[PrincOpsUtils.Codebase[LOOPHOLE[SMParseData]]]]};

}.