-- 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.