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

  }.