-- File: MailParserB.mesa
-- Last edited by Levin: 19-Feb-81  9:22:14

DIRECTORY
  Ascii USING [CR, SP, TAB],
  Inline USING [LowHalf],
  MailParse USING [BracketType, endOfInput, endOfList, ParseError],
  MailParsePrivate,
  Storage USING [Free, FreePages, FreeString, Node, Pages],
  String USING [StringBoundsFault];

MailParserB: PROGRAM
  IMPORTS Inline, MailParse, MailParsePrivate, Storage, String
  EXPORTS MailParse, MailParsePrivate =

  BEGIN OPEN Ascii, MailParse, MailParsePrivate;


  -- Miscellaneous --

  CharCacheError: ERROR = CODE;
  CommentsFlushBug: ERROR = CODE;
  MSGdlHandlingBug: ERROR = CODE;
  PreludeListDanglingBug: ERROR = CODE;
  NotAllowed: ERROR = CODE;
  TagListDanglingBug: ERROR = CODE;


  -- Types and Procedures exported to MailParse  --
  
  ParseHandle: PUBLIC TYPE = MailParsePrivate.ParseHandle;
  

  InitializeParse: PUBLIC PROCEDURE [next: PROCEDURE RETURNS [CHARACTER],
    backup: PROCEDURE, notifyTruncation: BOOLEAN _ FALSE] RETURNS [pH: ParseHandle] =
    BEGIN
    pH _ Storage.Node[SIZE[ParseInfo]];
    pH^ _ [nextChar:  next, backUp: backup, signalTruncation: notifyTruncation];
    END;

  FinalizeParse: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN
    IF pH.cantFinalize THEN ERROR NotAllowed;
    IF pH.preludeLexList ~= NIL THEN ERROR PreludeListDanglingBug;
    IF pH.tagLexList ~= NIL THEN ERROR TagListDanglingBug;
    FinalizeLexicalStorage[pH];
    IF pH.simpleName ~= NIL THEN Storage.FreeString[pH.simpleName];
    IF pH.registry ~= NIL THEN Storage.FreeString[pH.registry];
    IF pH.arpaHost ~= NIL THEN Storage.FreeString[pH.arpaHost];
    Storage.Free[Inline.LowHalf[pH]];
    END;

  GetListOrGroupName: PUBLIC PROCEDURE [pH: ParseHandle, name: STRING] =
    {GetAtomSequence[pH, name, pH.preludeLexList]};

  GetTag: PUBLIC PROCEDURE [pH: ParseHandle, tag: STRING] =
    {GetAtomSequence[pH, tag, pH.tagLexList]};

  GetAtomSequence: PROCEDURE [pH: ParseHandle, target: STRING, list: Lexeme] =
    BEGIN OPEN pH;
    target.length _ 0;
    IF list = NIL THEN RETURN;
    [] _ AppendSublistToString[pH, target, list, list
	    ! String.StringBoundsFault => GO TO truncated];
    EXITS
      truncated => IF signalTruncation THEN ERROR ParseError[truncated];
    END;


  -- Procedures exported to MailParsePrivate --

  RecurForBrackets: PUBLIC PROCEDURE [pH: ParseHandle, opener, terminator: CHARACTER] =
    BEGIN OPEN pH;
    savedOutputFlag: BOOLEAN = outputThisLevel;
    oldNesting: BracketType = nameInfo.nesting;
    oldPreludeLexList: Lexeme = preludeLexList;

    FlushCommentsAfterList: PROCEDURE = -- INLINE --
      -- accumulates and disposes of comments and white space following a list
      BEGIN
      lex: Lexeme;
      DO
	char: CHARACTER;
	SELECT char _ Get[pH ! EndOfInput => RESUME] FROM
	  nameSeparator, endOfList, CR, '>, '; => EXIT;
	  openComment => AccumulateComment[pH];
	  SP, TAB => {MaybeNewLexeme[pH, space]; WriteToStore[pH, char]};
	  ENDCASE => ERROR SyntaxError;
	ENDLOOP;
      backUp[];
      TerminateLexeme[pH];
      SELECT LexemeCount[pH] FROM
	none => RETURN;
	one =>
	  IF (lex _ lexHead.next).type = space THEN
	    BEGIN
	    IF outputThisLevel AND write ~= NIL THEN
	      {spaceState _ black; OutputLexeme[pH, lex]};
	    TruncateCharacterStorage[pH, lex.start];
	    ResetLexicalStorage[pH];
	    RETURN
	    END;
	ENDCASE;
      ERROR CommentsFlushBug;
      END;

    Cleanup: PROCEDURE =
      BEGIN
      IF preludeLexList ~= NIL THEN
	BEGIN
	TruncateCharacterStorage[pH, preludeLexList.start];
	DiscardLexemeList[pH, preludeLexList];
	END;
      preludeLexList _ oldPreludeLexList;
      outputThisLevel _ savedOutputFlag OR outputThisLevel;
      nameInfo.nesting _ oldNesting;
      END;

    IF scanningTag THEN ERROR SyntaxError;
    DiscardLexemeList[pH, tagLexList]; tagLexList _ NIL;
    TerminateLexeme[pH];
    preludeLexList _ RemoveLexemeList[pH];
    nameInfo.nesting _ IF opener = ': THEN group ELSE list;
    WriteToStore[pH, opener];
    ResetLexicalStorage[pH];  -- leaves the prelude in character storage
    BEGIN
    ENABLE UNWIND => Cleanup[];
    ParseList[pH, terminator];
    FlushCommentsAfterList[];
    END;
    Cleanup[];
    END;

  AccumulateComment: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN
    char: CHARACTER _ openComment;
    MaybeNewLexeme[pH, space];
    WriteToStore[pH, char];
    DO
      SELECT char _ Get[pH] FROM
	openComment => {AccumulateComment[pH]; LOOP};
	closeComment => EXIT;
	CR => GO TO Trouble;
	quoteNext =>
	  BEGIN
	  WriteToStore[pH, char];
	  char _ GetNaked[pH];
	  IF char = endOfList OR char = endOfInput THEN GO TO Trouble;
	  END;
	ENDCASE;
      WriteToStore[pH, char];
      ENDLOOP;
    WriteToStore[pH, char];
    EXITS Trouble => ERROR SyntaxError;
    END;

  AccumulateQuotedString: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN OPEN pH;
    char: CHARACTER _ stringQuote;
    IF curLexType = atom OR scanningTag THEN GO TO Trouble;
    MaybeNewLexeme[pH, atom];
    curLexType _ space; -- hack to prevent breaking lexeme in Get
    DO
      WriteToStore[pH, char];
      SELECT char _ Get[pH] FROM
	stringQuote => {WriteToStore[pH, char]; EXIT};
	quoteNext =>
	  BEGIN
	  WriteToStore[pH, char];
	  char _ GetNaked[pH];
	  IF char = endOfList OR char = endOfInput THEN GO TO Trouble;
	  END;
	CR => GO TO Trouble;
	ENDCASE;
      ENDLOOP;
    curLexType _ atom; -- undo hack
    EXITS Trouble => ERROR SyntaxError;
    END;

  AccumulateFileName: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN OPEN pH;
    char: CHARACTER _ '@;
    IF nameInfo.nesting ~= none OR scanningTag THEN ERROR SyntaxError;
    curLexType _ space; -- hack to prevent breaking lexeme in Get
    DO
      WriteToStore[pH, char];
      SELECT char _ Get[pH ! EndOfInput => RESUME] FROM
	nameSeparator, SP, TAB, openComment, endOfInput, endOfList, CR => EXIT;
	ENDCASE;
      ENDLOOP;
    backUp[];
    curLexType _ atom; -- undo hack
    END;

  AccumulateTagOrPrelude: PUBLIC PROCEDURE [pH: ParseHandle]
    RETURNS [TagOrPrelude] =
    BEGIN OPEN pH;
    
    LexemeListIsSingleAtom: PROCEDURE RETURNS [BOOLEAN] = INLINE
      BEGIN
      lex: Lexeme;
      IF (lex _ lexHead.next).type ~= space THEN RETURN[FALSE];
      IF (lex _ lex.next).type = space THEN lex _ lex.next;
      IF lex.type ~= atom THEN RETURN[FALSE];
      IF (lex _ lex.next).type ~= space THEN RETURN[FALSE];
      RETURN[lex.next.type = head]
      END;
      
    AppendNewTag: PROCEDURE = INLINE
      BEGIN
      newTagList: Lexeme _ RemoveLexemeList[pH];
      newEnd: Lexeme _ newTagList.prev;
      IF tagLexList = NIL THEN {tagLexList _ newTagList; RETURN};
      tagLexList.prev.next _ newTagList; newTagList.prev.next _ tagLexList;
      newTagList.prev _ tagLexList.prev; tagLexList.prev _ newEnd;
      END;

    IF ~scanningTag THEN
      BEGIN
      TerminateLexeme[pH];
      IF ~EmptyLexemeListOrSpace[pH] THEN RETURN[prelude];
      scanningTag _ TRUE;
      curLexType _ space;
      WriteToStore[pH, ':];
      RETURN[tag]
      END;
    MaybeNewLexeme[pH, space];
    WriteToStore[pH, ':];
    TerminateLexeme[pH];
    IF ~LexemeListIsSingleAtom[] THEN GO TO Trouble;
    scanningTag _ FALSE;
    AppendNewTag[];
    RETURN[tag];
    EXITS
      Trouble => ERROR SyntaxError;
    END;
 
  BuildMSGdlAtom: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN OPEN pH;
    first, last: CharIndex;
    FlushLexemeList[pH];
    IF preludeLexList = NIL THEN GO TO Trouble;
    last _ preludeLexList.prev.start + preludeLexList.prev.length;
    IF ReadFromStore[pH, last] ~= ': THEN GO TO Trouble;
    IF preludeLexList.type = space THEN
      BEGIN
      IF preludeLexList.next = preludeLexList THEN GO TO Trouble;
      AddLexeme[pH, MakeLexeme[pH, space, preludeLexList.start, preludeLexList.length]];
      preludeLexList _ preludeLexList.next;
      END;
    first _ preludeLexList.start;
    DiscardLexemeList[pH, preludeLexList]; preludeLexList _ NIL;
    AddLexeme[pH, MakeLexeme[pH, atom, first, last - first + 1]];
    EXITS
      Trouble => ERROR MSGdlHandlingBug;
    END;

  OutputName: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN OPEN pH;
    lex: Lexeme _ lexHead.next;

    OutputPreludes: PROCEDURE = INLINE
      BEGIN
      tempL: Lexeme;
      IF lex.start = preludeOut THEN RETURN;
      tempL _ MakeLexeme[pH, space, preludeOut, lex.start - preludeOut];
      OutputLexeme[pH, tempL];
      DeleteLexeme[pH, tempL];
      preludeOut _ lex.start;
      END;

    OutputQualifier: PROCEDURE [s: STRING] =
      BEGIN
      IF s.length = 0 THEN -- omit qualifier
	BEGIN
	IF (lex _ lex.next).type = space THEN lex _ lex.next;
	IF (lex _ lex.next).type ~= space THEN lex _ lex.prev;
	END
      ELSE -- output qualifier
	BEGIN
	qL: Lexeme = MakeLexemeFromString[pH, atom, s];
	OutputLexeme[pH, lex];
	IF (lex _ lex.next).type = space THEN {OutputLexeme[pH, lex]; lex _ lex.next};
	OutputLexeme[pH, qL];
	DeleteLexeme[pH, qL];
	END;
      END;

    spaceState _ initial;
    IF nameOutput THEN {write[nameSeparator]; spaceState _ black};
    OutputPreludes[];
    UNTIL lex.type = head DO
      SELECT lex FROM
	dotLex => OutputQualifier[registry];
	atLex => OutputQualifier[arpaHost];
	ENDCASE => OutputLexeme[pH, lex];
      lex _ lex.next;
      ENDLOOP;
    END;


  OutputLexeme: PUBLIC PROCEDURE [pH: ParseHandle, lex: Lexeme] =
    BEGIN OPEN pH;
    nest: CARDINAL _ 0;
    i: CharIndex;
    FOR i IN [lex.start..lex.start + lex.length) DO
      ch: CHARACTER _ ReadFromStore[pH, i];
      IF suppressWhiteSpace THEN
	BEGIN
	SELECT lex.type FROM
	  space, at =>
	    SELECT ch FROM
	      openComment => {nest _ nest + 1; GO TO Normal};
	      closeComment => nest _ nest - 1;
	      quoteNext => {write[ch]; ch _ ReadFromStore[pH, i _ i + 1]};
	      ENDCASE => IF nest = 0 THEN GO TO Normal;
	  ENDCASE => GO TO Normal;
	write[ch];
	EXITS
	  Normal =>
	    SELECT ch FROM
	      SP, TAB =>
		IF spaceState = black THEN spaceState _ white;
	      ENDCASE =>
		BEGIN
		IF spaceState = white THEN write[SP];
		spaceState _ black;
		write[ch];
		END;
	END
      ELSE write[ch];
      ENDLOOP;
    END;

  -- Lexical Storage --

  InitializeLexicalStorage: PUBLIC PROCEDURE [pH: ParseHandle] =
    -- initializes the lexical analyzer data structures.
    BEGIN OPEN pH;
    lexStart _ 0; curLexType _ null;
    IF lexHead = NIL THEN
      {lexHead _ MakeLexeme[pH, head]; lexHead.next _ lexHead.prev _ lexHead};
    IF bufferList = NIL THEN InitializeCharacterStorage[pH];
    END;

  FinalizeLexicalStorage: PUBLIC PROCEDURE [pH: ParseHandle] =
    -- cleans up the lexical analyzer data structures.
    BEGIN OPEN pH;
    IF lexHead ~= NIL THEN
      {FlushLexemeList[pH]; DeleteLexeme[pH, lexHead]; lexHead _ NIL};
    UNTIL freeLexHead = NIL DO
      tl: Lexeme = freeLexHead.next;
      Storage.Free[freeLexHead];
      freeLexHead _ tl;
      ENDLOOP;
    IF bufferList ~= NIL THEN FinalizeCharacterStorage[pH];
    END;

  -- Character Storage --

  InitializeCharacterStorage: PUBLIC PROCEDURE [pH: ParseHandle] =
    {pH.bufferList _ AddBuffer[pH, 0, NIL]};

  FinalizeCharacterStorage: PUBLIC PROCEDURE [pH: ParseHandle] =
    BEGIN OPEN pH;
    DeleteSuccessorBuffers[bufferList];
    Storage.FreePages[bufferList];
    bufferList _ NIL;
    END;

  AddBuffer: PUBLIC PROCEDURE [pH: ParseHandle, first: CharIndex, prev: CharBuffer]
    RETURNS [b: CharBuffer] =
    BEGIN
    b _ pH.cache _ Storage.Pages[1];
    b.header _ [next: NIL, prev: prev, first: first, count: 0];
    END;

  LoadCache: PUBLIC PROCEDURE [pH: ParseHandle, index: CharIndex] =
    BEGIN
    b: CharBuffer _ pH.cache;
    UNTIL index IN [b.header.first..b.header.first+b.header.count) DO
      b _ IF index < b.header.first THEN b.header.prev ELSE b.header.next;
      IF b = NIL THEN ERROR CharCacheError;
      ENDLOOP;
    pH.cache _ b;
    END;


  END.