IMPLEMENTATION MODULE Parser;
FROM Memory IMPORT ALLOCATE, AddMarker;
FROM Lib IMPORT IncAddr;
IMPORT Str;
FROM FIO IMPORT File, Open, IOresult, Close;
FROM Buffers IMPORT ReadChar, ReadWord, Rewind, CharSet;
FROM Buffers IMPORT position, OpenInput, CloseInput, ReportError;
FROM Machine IMPORT EmptyClosure, tempDef, wPackage, link, HandlePackage, Reduce;
FROM Machine IMPORT Join, AddEnv, AddValuedEnv, Root, Copy, result;
FROM Machine IMPORT SaveDefinition, NewLayer, StartLayer, PopLayer;
FROM Machine IMPORT MakeDef, MakePrimitive, MakeString, MakePacked, ExtractPacked;
FROM Machine IMPORT MarkString, MarkClosure;
FROM Library IMPORT wChar, wString, wCharSet, wNumber, wError, errorCodes;
FROM Library IMPORT wType, wStruct, wFile, wUndefined, wDescription;
FROM Names IMPORT FindWord, DefEntry, AddPrimWord, DefineWord, wMeaning;
FROM Names IMPORT NewDictionary, OldDictionary;
FROM Grammars IMPORT wSequence, wLexSequence, wValSequence, wLexValSequence;
FROM Grammars IMPORT wEndSeq, wChoice, wOption;
FROM Grammars IMPORT wDummy, wFail, wDone, wRaise, wDiscard, wGrammar, wNext;
FROM Grammars IMPORT wSpaceChars, wSpaces, wComment, wFrameGrammar, wCustomGrammar;
FROM Grammars IMPORT wCharGrammar, wCharSetGrammar, wStrGrammar, wNumGrammar;
FROM Grammars IMPORT wIdentifier, wIdentGrammar, wFirst, wTail;
FROM Grammars IMPORT wStructGrammar;
FROM Grammars IMPORT Failure, Confirmation;
FROM ParseLow IMPORT ParsePrimitive, buildTree;
FROM ParseLow IMPORT ParseSequencePrimitive, ParseEndSequence, ParseChoice, ParseOption;
CONST
MaxStrLength=200;
all=CharSet{0C..377C};
TYPE
CharPtr=POINTER TO CHAR;
string=ARRAY [0..MaxStrLength] OF CHAR;
VAR
firstSet,tailSet:CharSet;
originalFirst,originalTail:closure;
strPtr:POINTER TO string;
PROCEDURE pSpaces;
VAR
prevPos:LONGCARD;
spaces:POINTER TO CharSet;
str:ARRAY [0..1] OF CHAR;
BEGIN
StartLayer;
SaveDefinition(wCharSet);
wCharSet^:=HandlePackage;
Reduce(wSpaceChars^);
PopLayer;
ExtractPacked(result,spaces);
IF Root(wComment^)=wFail THEN
ReadWord(str,spaces^,spaces^)
ELSE
REPEAT
ReadWord(str,spaces^,spaces^);
prevPos:=position;
StartLayer;
SaveDefinition(wGrammar);
wGrammar^:=wComment^;
ParsePrimitive;
PopLayer;
UNTIL Root(result)=wFail;
Rewind(prevPos)
END;
result:=Confirmation
END pSpaces;
PROCEDURE ParseLexValSequence;
BEGIN
ParseSequencePrimitive(TRUE)
END ParseLexValSequence;
PROCEDURE ParseLexSequence;
BEGIN
ParseSequencePrimitive(FALSE)
END ParseLexSequence;
PROCEDURE ParseValSequence;
BEGIN
Reduce(wSpaces^);
ParseSequencePrimitive(TRUE)
END ParseValSequence;
PROCEDURE ParseSequence;
BEGIN
Reduce(wSpaces^);
ParseSequencePrimitive(FALSE)
END ParseSequence;
PROCEDURE ParseTheLetter;
VAR
chExpect,chRead:CHAR;
BEGIN
ExtractPacked(wPackage^,chExpect);
ReadChar(chRead);
IF chRead=chExpect THEN
IF buildTree THEN
MakePacked(result,wChar,chRead)
ELSE
result:=Confirmation
END
ELSE
result:=Failure
END
END ParseTheLetter;
VAR
strRest:CharPtr;
PROCEDURE ParseTheString;
VAR
ch:CHAR;
strExpect:CharPtr;
BEGIN
ExtractPacked(wPackage^,strExpect);
strRest:=strExpect;
LOOP
IF strRest^=0C THEN
EXIT
END;
ReadChar(ch);
IF strRest^#ch THEN
EXIT
END;
IncAddr(strRest,1)
END;
IF strRest^=0C THEN
IF buildTree THEN
MakeString(result,wString,strExpect)
ELSE
result:=Confirmation
END
ELSE
result:=Failure
END
END ParseTheString;
PROCEDURE ParseTheCharSet;
VAR
ch:CHAR;
s:POINTER TO CharSet;
BEGIN
ExtractPacked(wPackage^,s);
ReadChar(ch);
IF ch IN s^ THEN
IF buildTree THEN
MakePacked(result,wChar,ch)
ELSE
result:=Confirmation
END
ELSE
result:=Failure
END
END ParseTheCharSet;
PROCEDURE ParseNumber;
VAR
ch:CHAR;
minus:BOOLEAN;
x:CARDINAL;
BEGIN
ReadChar(ch);
IF ch='-' THEN
minus:=TRUE;
ReadChar(ch)
ELSE
minus:=FALSE;
IF ch='+' THEN
ReadChar(ch)
END
END;
x:=0;
IF ch IN CharSet{'0'..'9'} THEN
REPEAT
IF x <= (MAX(INTEGER)-ORD(ch)+ORD('0')) DIV 10 THEN
x:=10*x+ORD(ch)-ORD('0')
END;
ReadChar(ch)
UNTIL NOT (ch IN CharSet{'0'..'9'});
Rewind(position-1);
IF minus THEN
MakePacked(result,wNumber,-INTEGER(x))
ELSE
MakePacked(result,wNumber,x)
END
ELSE
result:=Failure
END
END ParseNumber;
PROCEDURE ParseChar;
VAR
delimiter,chRead:CHAR;
BEGIN
ReadChar(delimiter);
IF delimiter="'" THEN
ReadChar(chRead);
ReadChar(delimiter);
IF delimiter="'" THEN
MakePacked(result,wChar,chRead)
ELSE
result:=Failure
END
ELSE
result:=Failure
END
END ParseChar;
PROCEDURE ParseCharSET;
VAR
ch,second,i:CHAR;
s:CharSet;
complement:BOOLEAN;
BEGIN
ReadChar(ch);
IF ch='{' THEN
s:=CharSet{};
ReadChar(ch);
IF ch='~' THEN
complement:=TRUE;
ELSE
complement:=FALSE;
Rewind(position-1)
END;
LOOP
pSpaces;
ReadChar(ch);
IF ch='}' THEN
EXIT
ELSIF ch='\' THEN
ReadChar(ch);
END;
pSpaces;
ReadChar(second);
IF second='-' THEN
pSpaces;
ReadChar(second);
IF second<ch THEN
ch:=0C;
EXIT
END;
FOR i:=ch TO second DO
INCL(s,i)
END;
ReadChar(second)
ELSE
INCL(s,ch)
END;
IF second#',' THEN
IF second#'}' THEN
ch:=0C
END;
EXIT
END
END;
IF ch#0C THEN
IF buildTree THEN
IF complement THEN
s:=all-s;
END;
MakePacked(result,wCharSet,s)
ELSE
result:=Confirmation
END;
RETURN
END
END;
result:=Failure
END ParseCharSET;
PROCEDURE ParseIdentifier;
VAR
first,tail:POINTER TO CharSet;
wd:link;
str:string;
BEGIN
IF (wFirst^=originalFirst) AND (wTail^=originalTail) THEN
ReadWord(str,firstSet,tailSet)
ELSE
SaveDefinition(wCharSet);
wCharSet^:=HandlePackage;
Reduce(wFirst^);
ExtractPacked(result,first);
Reduce(wTail^);
ExtractPacked(result,tail);
ReadWord(str,first^,tail^)
END;
IF str[0]=0C THEN
result:=Failure
ELSE
wd:=FindWord(str);
IF wd=NIL THEN
ALLOCATE(strPtr,Str.Length(str)+1);
Str.Copy(strPtr^,str);
MakeDef(result,wIdentifier);
DefineWord(wd,strPtr^,result);
AddEnv(wd^,wDescription,DefEntry(wd));
strPtr:=NIL
END;
NewLayer(DefEntry(wd));
result:=wMeaning^
END
END ParseIdentifier;
PROCEDURE ParseString;
VAR
ch,between:CHAR;
str:string;
length:CARDINAL;
BEGIN
ReadChar(between);
IF (between="'") OR (between='"') THEN
length:=0;
ReadChar(ch);
WHILE (ch#between) AND (ch#CHR(13)) AND (length<MaxStrLength) DO
str[length]:=ch;
INC(length);
ReadChar(ch)
END;
IF ch=between THEN
str[length]:=0C;
ALLOCATE(strPtr,length+1);
Str.Copy(strPtr^,str);
MakeString(result,wString,strPtr);
strPtr:=NIL;
RETURN
END
END;
result:=Failure
END ParseString;
PROCEDURE ParseCustom;
VAR
wprop:closure;
BEGIN
ParseIdentifier;
IF Root(result)#wFail THEN
wprop:=DefEntry(Root(result));
wFrameGrammar^:=wStructGrammar^;
NewLayer(wprop);
SaveDefinition(wType);
wType^:=result;
Reduce(wFrameGrammar^)
END
END ParseCustom;
PROCEDURE Parse;
VAR
saveFirstSet,saveTailSet:CharSet;
BEGIN
StartLayer;
SaveDefinition(wSpaces);
MakePrimitive(wSpaces^,pSpaces);
SaveDefinition(wSequence);
MakePrimitive(wSequence^,ParseSequence);
SaveDefinition(wLexSequence);
MakePrimitive(wLexSequence^,ParseLexSequence);
SaveDefinition(wValSequence);
MakePrimitive(wValSequence^,ParseValSequence);
SaveDefinition(wLexValSequence);
MakePrimitive(wLexValSequence^,ParseLexValSequence);
SaveDefinition(wEndSeq);
MakePrimitive(wEndSeq^,ParseEndSequence);
SaveDefinition(wChoice);
MakePrimitive(wChoice^,ParseChoice);
SaveDefinition(wOption);
MakePrimitive(wOption^,ParseOption);
SaveDefinition(wChar);
MakePrimitive(wChar^,ParseTheLetter);
SaveDefinition(wString);
MakePrimitive(wString^,ParseTheString);
originalFirst:=wFirst^;
originalTail:=wTail^;
Reduce(wFirst^);
saveFirstSet:=firstSet;
ExtractPacked(result,firstSet);
IF Root(result)#wCharSet THEN
originalFirst:=NIL
END;
Reduce(wTail^);
saveTailSet:=tailSet;
ExtractPacked(result,tailSet);
IF Root(result)#wCharSet THEN
originalTail:=NIL
END;
SaveDefinition(wCharSet);
MakePrimitive(wCharSet^,ParseTheCharSet);
SaveDefinition(wNumGrammar);
MakePrimitive(wNumGrammar^,ParseNumber);
SaveDefinition(wCharGrammar);
MakePrimitive(wCharGrammar^,ParseChar);
SaveDefinition(wStrGrammar);
MakePrimitive(wStrGrammar^,ParseString);
SaveDefinition(wCharSetGrammar);
MakePrimitive(wCharSetGrammar^,ParseCharSET);
SaveDefinition(wIdentGrammar);
MakePrimitive(wIdentGrammar^,ParseIdentifier);
SaveDefinition(wCustomGrammar);
MakePrimitive(wCustomGrammar^,ParseCustom);
SaveDefinition(wFrameGrammar);
wFrameGrammar^:=Failure;
pSpaces;
ParsePrimitive;
PopLayer;
originalFirst:=EmptyClosure;
originalTail:=EmptyClosure;
IF Root(result)=wFail THEN
ReportError;
MakePacked(result,wError,SyntaxError)
ELSE
SaveDefinition(wStruct);
wStruct^:=result;
Reduce(result)
END;
END Parse;
PROCEDURE pParse;
VAR
filename:POINTER TO string;
newFile:BOOLEAN;
BEGIN
Reduce(wFile^);
newFile:=(Root(result)=wString);
IF newFile THEN
ExtractPacked(result,filename);
IF NOT OpenInput(filename^) THEN
MakePacked(result,wError,IOError);
RETURN
END;
SaveDefinition(wFile);
MakeDef(wFile^,wUndefined)
END;
NewDictionary;
Parse;
OldDictionary;
IF newFile THEN
CloseInput
END
END pParse;
PROCEDURE MarkInternals;
BEGIN
MarkString(strPtr);
MarkClosure(originalFirst);
MarkClosure(originalTail)
END MarkInternals;
BEGIN
strPtr:=NIL;
originalFirst:=EmptyClosure;
originalTail:=EmptyClosure;
AddMarker(MarkInternals);
AddPrimWord(wParse,'Parse',pParse)
END Parser.