Initial check in docu

This commit is contained in:
2026-01-03 18:31:15 +01:00
parent e2c3cbc520
commit ee130973e2
98 changed files with 9430 additions and 0 deletions
+10
View File
@@ -0,0 +1,10 @@
To build a project you must first compile the grammars.
After the compilation the project can be opened in delphi. Be sure that the dpg
runtime library is in the delphi library path. (In the project settings,
or in the environment settings).
Have fun...
ps.: I'm not sure that the grammar is correct, or not...
This is only for showing dpg features...
+359
View File
@@ -0,0 +1,359 @@
{
* A Child-Sibling Tree.
*
* A tree with PLUS at the root and with two children 3 and 4 is
* structured as:
*
* PLUS
* |
* 3 -- 4
*
* and can be specified easily in LISP notation as
*
* (PLUS 3 4)
*
* where every '(' starts a new subtree.
*
* These trees are particular useful for translators because of
* the flexibility of the children lists. They are also very easy
* to walk automatically, whereas trees with specific children
* reference fields can't easily be walked automatically.
*
* This class contains the basic support for an AST.
* Most people will create ASTs that are subclasses of
* BaseAST or of CommonAST.
*/
}
unit ast;
interface
uses
Classes,
Generics.Collections;
// dpgrtl.Token;
type
TAST = class;
TASTList = TList<TAST>;
TAST = class
protected
fDown : TAST;
fRight : TAST;
fAstText : AnsiString;
fAstType : integer;
fAstLine : integer;
fAstColumn : integer;
private
fVerbose : boolean; // verbose string conversion
fTokenNames : TStringList;
private
procedure DoFindAll( NodeToSearch : TAST;
// v : Vector;
Target : TAST;
PartialMatch : boolean);
protected
function GetNumberofChildren: integer;
function GetEquals( Node : TAST): boolean; virtual;
function GetEqualsList( Node : TAST): boolean; virtual;
function GetEqualsListPartial( Node : TAST): boolean; virtual;
function GetEqualsTree( Node : TAST): boolean; virtual;
function GetEqualsTreePartial( Node : TAST): boolean; virtual;
function GetTokenNames : TStringList;
procedure SetVerbose( Verbose : boolean;
Names : TStringList);
public
procedure Initialize( AstType : integer;
AstText : AnsiString); overload; virtual; abstract;
procedure Initialize( Node : TAST); overload; virtual; abstract;
// procedure Initialize( Token : TToken); overload; virtual; abstract;
procedure AddChild( node: TAST);
procedure RemoveChildren;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
public
property NumberOfChildren : integer read GetNumberofChildren;
property NextSibling : TAST read fRight write fRight;
property FirstChild : TAST read fDown write fDown;
property AstText : AnsiString read fAstText write fAstText;
property AstType : integer read fAstType write fAstType;
property AstLine : integer read fAstLine write fAstLine;
property AstColumn : integer read fAstColumn write fAstColumn;
property Equals [n: TAST]: boolean read GetEquals;
property EqualsList [n: TAST]: boolean read GetEqualsList;
property EqualsListPartial [n: TAST]: boolean read GetEqualsListPartial;
property EqualsTree [n: TAST]: boolean read GetEqualsTree;
property EqualsTreePartial [n: TAST]: boolean read GetEqualsTreepartial;
end;
TASTClass = class of TAST;
implementation
{ TastBase }
procedure TAST.AfterConstruction;
begin
inherited;
fTokenNames := TStringList.Create;
end;
procedure TAST.BeforeDestruction;
begin
fTokenNames.Free;
inherited;
end;
// ================================================================================================
// DoFindAll
// ================================================================================================
procedure TAST.DoFindAll(NodeToSearch, Target: TAST; PartialMatch: boolean);
var
sibling : TAST;
child : TAST;
begin
// start walking sibling lists, looking for matches
sibling := NodeToSearch;
while Assigned(sibling) do
begin
if ( PartialMatch and sibling.EqualsTreePartial[Target]) or
( not PartialMatch and sibling.EqualsTree[Target]) then
// v.appendelement(sibling)
;
if Assigned( sibling.FirstChild) then
DoFindAll( sibling.FirstChild, {v,} Target, PartialMatch);
sibling := sibling.NextSibling
end;
end;
// ================================================================================================
// Get Number of Children
// ================================================================================================
function TAST.GetNumberofChildren: integer;
var
t: TAST;
n: integer;
begin
t := fDown;
n := 0;
if Assigned(t) then
begin
INC(n);
while Assigned(t.fRight) do
begin
t := t.fRight;
INC(n)
end;
end;
result := n
end;
// ================================================================================================
// Get Equals
// ================================================================================================
function TAST.GetEquals(Node: TAST): boolean;
begin
if Assigned(Node)
then result := (Node.fAstText = fAstText) and (Node.fAstType = fAstType)
else result := false
end;
// ================================================================================================
// Get Equals List
// ================================================================================================
function TAST.GetEqualsList(Node: TAST): boolean;
var
sibling: TAST;
begin
result := false;
if Assigned(Node) then
begin
sibling := self;
while Assigned(sibling) and Assigned(Node) do
begin
// as a quick optimization, check roots firt
if not sibling.Equals[Node] then
break;
// if roots match, do full list match test on children
if Assigned( sibling.FirstChild) then
begin
if not sibling.FirstChild.EqualsList[Node.FirstChild] then
break
end
// sibling has no kids, make sure Node doesn't either
else if Assigned(Node.FirstChild) then
break;
sibling := sibling .NextSibling;
Node := Node .NextSibling;
end;
if not Assigned(sibling) and not Assigned(Node) then
result := true
end;
end;
// ================================================================================================
// Get Equals List Partial
//
// Is Node a subtree of this list ? The siblings of the root are NOT ignored.
// ================================================================================================
function TAST.GetEqualsListPartial(Node: TAST): boolean;
var
sibling: TAST;
begin
result := false;
if Assigned(Node) then
begin
sibling := self;
while Assigned(sibling) and Assigned(Node) do
begin
// as a quick optimization, check roots firt
if not sibling.Equals[Node] then
break;
// if roots match, do partial list match test on children
if Assigned( sibling.FirstChild) then
if not sibling.FirstChild.EqualsListPartial[Node.FirstChild] then
break
end;
if not Assigned(sibling) and Assigned(Node)
then result := false
else result := true
end;
end;
// ================================================================================================
// Get Equals Tree
//
// Is the tree rooted at *self* equals to *Node* ?
// The sibling of *self* are ignored.
// ================================================================================================
function TAST.GetEqualsTree(Node: TAST): boolean;
begin
result := false;
if Equals[Node] then
begin
// if roots match, do full list match test on children
if Assigned(FirstChild) then
begin
if not FirstChild.EqualsList[Node.FirstChild] then
exit;
end
// No kids, make sure *Node* hasn't either
else if Assigned(Node.FirstChild) then
exit;
end;
result := true
end;
// ================================================================================================
// Get Equals Tree Partial
// ================================================================================================
function TAST.GetEqualsTreePartial(Node: TAST): boolean;
begin
result := false;
if Equals[Node] then
if Assigned(FirstChild) then
if not FirstChild.EqualsListPartial[Node] then
exit;
result := true
end;
// ================================================================================================
// Get Token Names
// ================================================================================================
function TAST.GetTokenNames: TStringList;
begin
result := TStringList.Create;
result.AddStrings(fTokenNames);
end;
// ================================================================================================
// Set Verbose
// ================================================================================================
procedure TAST.SetVerbose(Verbose: boolean; Names: TStringList);
begin
fVerbose := Verbose;
fTokenNames.Clear;
ftokenNames.AddStrings(Names);
end;
// ================================================================================================
// AddChild
// ================================================================================================
procedure TAST.AddChild(node: TAST);
var
n: TAST;
begin
if Assigned(node) then
begin
n := fDown;
if Assigned(n) then
begin
while Assigned(n.fRight) do
n := n.fRight;
n.fRight := node
end
else
fDown := node
end;
end;
// ================================================================================================
// Remove Children
// ================================================================================================
procedure TAST.RemoveChildren;
begin
fDown := nil
end;
end.
@@ -0,0 +1,12 @@
unit astProgram;
interface
type
TastProgram = class
end;
implementation
end.
Binary file not shown.

After

Width:  |  Height:  |  Size: 15 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 11 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 11 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 21 KiB

+38
View File
@@ -0,0 +1,38 @@
program wpTest;
{$APPTYPE CONSOLE}
uses
Classes,
SysUtils,
wpLex in '..\wpLex.pas',
wpPar in '..\wpPar.pas',
astProgram in '..\..\tools\ast\astProgram.pas',
ast in '..\..\tools\ast\ast.pas';
var
stm : TFileStream;
lex : TwpLex;
par : TwpPar;
begin
try
stm := TFileStream.Create('x.pas', fmOpenRead);
stm.Seek(0, soFromBeginning);
lex := TwpLex.Create(stm);
par := TwpPar.Create(lex);
par.prg;
stm.Free;
lex.Free;
par.Free;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
+107
View File
@@ -0,0 +1,107 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{E509B25A-366D-449B-B4C6-013162829AAF}</ProjectGuid>
<ProjectVersion>12.0</ProjectVersion>
<MainSource>wpTest.dpr</MainSource>
<Config Condition="'$(Config)'==''">Debug</Config>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_DependencyCheckOutputName>wpTest.exe</DCC_DependencyCheckOutputName>
<DCC_ImageBase>00400000</DCC_ImageBase>
<DCC_UnitAlias>WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)</DCC_UnitAlias>
<DCC_Platform>x86</DCC_Platform>
<DCC_E>false</DCC_E>
<DCC_N>false</DCC_N>
<DCC_S>false</DCC_S>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>false</DCC_DebugInformation>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="wpTest.dpr">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="..\wpLex.pas"/>
<DCCReference Include="..\wpPar.pas"/>
<DCCReference Include="..\..\tools\ast\astProgram.pas"/>
<DCCReference Include="..\..\tools\ast\ast.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Release">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<Source>
<Source Name="MainSource">wpTest.dpr</Source>
</Source>
<Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">False</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1031</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"/>
<VersionInfoKeys Name="FileDescription"/>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"/>
<VersionInfoKeys Name="LegalCopyright"/>
<VersionInfoKeys Name="LegalTrademarks"/>
<VersionInfoKeys Name="OriginalFilename"/>
<VersionInfoKeys Name="ProductName"/>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
</Delphi.Personality>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
</Project>
+13
View File
@@ -0,0 +1,13 @@
program prg1 (input,output);
label 1,4,5;
const
a = 3.14;
b = 'hello';
c = d;
asd = 12345;
begin
end.
Binary file not shown.

After

Width:  |  Height:  |  Size: 16 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 13 KiB

+607
View File
@@ -0,0 +1,607 @@
unit wpLex;
interface
uses
Classes,
SysUtils,
Generics.Collections;
type
TTokenType =
(
TT_EOF,
TT_SKIP,
TT_COMMENT,
TT_LPAREN, // (
TT_RPAREN, // )
TT_LBRACKET, // [
TT_RBRACKET, // ]
TT_STAR, // *
TT_SLASH, // /
TT_PLUS, // +
TT_MINUS, // -
TT_LT, // <
TT_LE, // <=
TT_GT, // >
TT_GE, // >=
TT_EQ, // =
TT_NE, // <>
TT_COLON, // :
TT_ASSIGN, // :=
TT_DOT, // .
TT_RANGE, // ..
TT_PTR, // ^
TT_COMMA, // ,
TT_SEMI, // ;
TT_DOLLAR, // $
TT_AT, // @
TT_SHARP, // #
TT_ID,
TT_UINT,
TT_UREAL,
TT_CHAR,
TT_STRING,
TT_HEX,
TT_BIN,
LT_DO,
LT_IF,
LT_IN,
LT_OF,
LT_OR,
LT_TO,
LT_AND,
LT_DIV,
LT_END,
LT_FOR,
LT_MOD,
LT_NIL,
LT_NOT,
LT_SET,
LT_VAR,
LT_XOR,
LT_CASE,
LT_ELSE,
LT_FILE,
LT_GOTO,
LT_THEN,
LT_TYPE,
LT_USES,
LT_WITH,
LT_ARRAY,
LT_BEGIN,
LT_CONST,
LT_LABEL,
LT_UNTIL,
LT_WHILE,
LT_DOWNTO,
LT_PACKED,
LT_RECORD,
LT_REPEAT,
LT_PROGRAM,
LT_FUNCTION,
LT_PROCEDURE
);
TTokenTypes = set of TTokenType;
TBlah = set of byte;
TToken = class
TokenType : TTokenType;
TokenText : AnsiString;
TokenLine : integer;
TokenColumn : integer;
end;
TTokenMap = TDictionary<AnsiString,TTokenType>;
TwpLex = class
private
fBuffer : PAnsiChar;
fStart : PAnsiChar;
fForward : PAnsiChar;
fLiterals : TTokenMap;
fTokenLine : integer;
fTokenColumn: integer;
private
procedure InitLiterals;
function CheckLiteral( TokenText : AnsiString;
TokenType : TTokenType): TTokenType;
function MakeToken( TokenText : AnsiString;
TokenType : TTokenType): TToken;
public
function NextToken : TToken;
public
constructor Create( Stream: TStream; Length: Int64=-1);
destructor Destroy; override;
end;
EwpLex = Exception;
implementation
uses
Windows;
{ TwpLex }
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Construction/destruction
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Constructor
// ================================================================================================
constructor TwpLex.Create(Stream: TStream; Length: Int64);
var
size : Int64;
token : TToken;
begin
inherited Create;
InitLiterals;
if Assigned(Stream) then
begin
if Length < 0
then size := Stream.Size - Stream.Position
else size := Length;
fBuffer := GetMemory(size+1);
Stream.Read( fBuffer^, size);
fStart := fBuffer;
fForward := fBuffer;
fBuffer[size] := #0;
end;
end;
// ================================================================================================
// Destructor
// ================================================================================================
destructor TwpLex.Destroy;
begin
FreeAndNil(fLiterals);
inherited;
end;
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Internals
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Make Token
// ================================================================================================
function TwpLex.MakeToken(TokenText: AnsiString; TokenType: TTokenType): TToken;
begin
result := TToken.Create;
result.TokenLine := 0;
result.TokenColumn := 0;
result.TokenType := TokenType;
result.TokenText := TokenText;
// if TokenType = TT_COMMENT
// then result.TokenText := TokenText
// else result.TokenText := UpperCase(TokenText);
end;
// ================================================================================================
// Init Literals
// ================================================================================================
procedure TwpLex.InitLiterals;
begin
fLiterals := TTokenMap.Create;
fLiterals.Add('do', LT_DO);
fLiterals.Add('if', LT_IF);
fLiterals.Add('in', LT_IN);
fLiterals.Add('of', LT_OF);
fLiterals.Add('or', LT_OR);
fLiterals.Add('to', LT_TO);
fLiterals.Add('and', LT_AND);
fLiterals.Add('div', LT_DIV);
fLiterals.Add('end', LT_END);
fLiterals.Add('for', LT_FOR);
fLiterals.Add('mod', LT_MOD);
fLiterals.Add('nil', LT_NIL);
fLiterals.Add('not', LT_NOT);
fLiterals.Add('set', LT_SET);
fLiterals.Add('var', LT_VAR);
fLiterals.Add('xor', LT_XOR);
fLiterals.Add('case', LT_CASE);
fLiterals.Add('else', LT_ELSE);
fLiterals.Add('file', LT_FILE);
fLiterals.Add('goto', LT_GOTO);
fLiterals.Add('then', LT_THEN);
fLiterals.Add('type', LT_TYPE);
fLiterals.Add('uses', LT_USES);
fLiterals.Add('with', LT_WITH);
fLiterals.Add('array', LT_ARRAY);
fLiterals.Add('begin', LT_BEGIN);
fLiterals.Add('const', LT_CONST);
fLiterals.Add('label', LT_LABEL);
fLiterals.Add('until', LT_UNTIL);
fLiterals.Add('while', LT_WHILE);
fLiterals.Add('downto', LT_DOWNTO);
fLiterals.Add('packed', LT_PACKED);
fLiterals.Add('record', LT_RECORD);
fLiterals.Add('repeat', LT_REPEAT);
fLiterals.Add('program', LT_PROGRAM);
fLiterals.Add('function', LT_FUNCTION);
fLiterals.Add('procedure', LT_PROCEDURE);
end;
// ================================================================================================
// Check Literal
// ================================================================================================
function TwpLex.CheckLiteral(TokenText: AnsiString; TokenType: TTokenType): TTokenType;
var
ttype : TTokenType;
begin
if fLiterals.TryGetValue(TokenText, ttype)
then result := ttype
else result := TokenType
end;
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Interface
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Next Token
// ================================================================================================
function TwpLex.NextToken: TToken;
function GetTokenText: AnsiString;
begin
SetLength(result, fForward-fStart);
MoveMemory( @result[1], fStart, fForward-fStart);
end;
var
ttext : AnsiString;
ttype : TTokenType;
begin
result := nil;
while true do
begin
result := nil;
fForward := fStart;
case fForward^ of
// id
'a'..'z','A'..'Z','_':
begin
INC(fForward);
ttype := TT_ID;
while fForward^ in ['a'..'z','A'..'Z','0'..'9','_'] do
INC(fForward);
ttype := CheckLiteral( GetTokenText, ttype);
end;
// uint or ureal
'0'..'9':
begin
INC(fForward);
ttype := TT_UINT;
while fForward^ in ['0'..'9'] do
INC(fForward);
// fractional part
if fForward^ = '.' then
begin
INC(fForward);
if fForward^ in ['0'..'9'] then
begin
INC(fForward);
ttype := TT_UREAL;
while fForward^ in ['0'..'9'] do
INC(fForward);
end
else if fForward^ = '.' then
ttype := TT_RANGE
else
raise EwpLex.Create('Expected 0..9 in fractional part');
end;
// exponential part
if ttype in [TT_UINT, TT_UREAL] then
begin
if fForward^ in ['e','E'] then
begin
INC(fForward);
ttype := TT_UREAL;
if fForward^ in ['+','-'] then
INC(fForward);
if fForward^ in ['0'..'9'] then
begin
INC(fForward);
while fForward^ in ['0'..'9'] do
INC(fForward);
end
else
raise EwpLex.Create('Expected +,-,0..9 in exponential part');
end;
end;
end;
// <,<=,<>
'<':
begin
INC(fForward);
ttype := TT_LT;
if fForward^ in ['=','>'] then
begin
case fForward^ of
'=': ttype := TT_LE;
'>': ttype := TT_NE;
end;
INC(fForward);
end;
end;
// >,>=
'>':
begin
INC(fForward);
ttype := TT_GT;
if fForward^ = '=' then
begin
INC(fForward);
ttype := TT_GE;
end;
end;
// :,:=
':':
begin
INC(fForward);
ttype := TT_COLON;
if fForward^ = '=' then
begin
INC(fForward);
ttype := TT_ASSIGN
end
end;
// .,..
'.':
begin
INC(fForward);
ttype := TT_DOT;
if fForward^ = '.' then
begin
INC(fForward);
ttype := TT_RANGE;
end
end;
// string
'''':
begin
INC(fForward);
ttype := TT_CHAR;
while true do
begin
if fForward^ in [#10,#13,#0] then
raise EwpLex.Create('Newline/EOF found in string');
if fForward^ = '''' then
begin
INC(fForward);
if fForward^ = ''''
then INC(fForward)
else break
end
else
INC(fForward)
end;
end;
// /,//
'/':
begin
INC(fForward);
ttype := TT_SLASH;
if fForward^ = '/' then
begin
INC(fForward);
ttype := TT_COMMENT;
while not (fForward^ in [#13,#10,#0]) do
INC(fForward);
end
end;
// comment
'{':
begin
INC(fForward);
ttype := TT_COMMENT;
while not (fForward^ in ['}',#0]) do
INC(fForward);
if fForward^ = #0
then raise EwpLex.Create('EOF reached in comment')
else INC( fForward);
end;
'(':
begin
INC(fForward);
ttype := TT_LPAREN;
if fForward^ = '*' then
begin
INC(fForward);
ttype := TT_COMMENT;
while true do
begin
if fForward^ = #0 then
raise EwpLex.Create('EOF reached in comment');
if fForward^ = '*' then
begin
INC(fForward);
if fForward^ = ')' then
begin
INC(fForward);
break;
end;
end
end
end
end;
// hex number
'$':
begin
INC(fForward);
if fForward^ in ['0'..'9','a'..'f','A'..'F'] then
begin
INC(fForward);
ttype := TT_HEX;
while fForward^ in ['0'..'9','a'..'f','A'..'F'] do
INC(fForward);
end
else
raise EwpLex.Create('Expected hexadecimal digit');
end;
'%':
begin
INC(fForward);
if fForward^ in ['0'..'1'] then
begin
INC(fForward);
ttype := TT_BIN;
while fForward^ in ['0'..'1'] do
INC(fForward);
end
else
raise EwpLex.Create('Expected binary digit');
end;
else
case fForward^ of
')': begin ttype := TT_RPAREN; INC(fForward) end;
'[': begin ttype := TT_LBRACKET; INC(fForward) end;
']': begin ttype := TT_RBRACKET; INC(fForward) end;
'*': begin ttype := TT_STAR; INC(fForward) end;
'+': begin ttype := TT_PLUS; INC(fForward) end;
'-': begin ttype := TT_MINUS; INC(fForward) end;
'=': begin ttype := TT_EQ; INC(fForward) end;
'^': begin ttype := TT_PTR; INC(fForward) end;
';': begin ttype := TT_SEMI; INC(fForward) end;
',': begin ttype := TT_COMMA; INC(fForward) end;
'$': begin ttype := TT_DOLLAR; INC(fForward) end;
'@': begin ttype := TT_AT; INC(fForward) end;
'#': begin ttype := TT_SHARP; INC(fForward) end;
#9 : begin ttype := TT_SKIP; INC(fForward) end;
#10: begin ttype := TT_SKIP; INC(fForward) end;
#13: begin ttype := TT_SKIP; INC(fForward) end;
#32: begin ttype := TT_SKIP; INC(fForward) end;
// EOF
#0 : ttype := TT_EOF;
else
raise EwpLex.Create('Invalid character '+fForward^);
end
end;
if ttype <> TT_SKIP then
begin
ttext := GetTokenText;
result := MakeToken( ttext, ttype);
fStart := fForward;
break;
end;
fStart := fForward;
end;
end;
end.
+418
View File
@@ -0,0 +1,418 @@
unit wpPar;
interface
uses
SysUtils,
Generics.Collections,
wpLex;
type
TStringMap = TDictionary<AnsiString,AnsiString>;
TwpPar = class
private
fLex : TwpLex;
fConstants : TStringMap;
fTypes : TStringMap;
protected
function Match( ttype : TTokenType; dispose: boolean=true):TToken; overload;
function Match( ttypes : TTokenTypes; dispose: boolean=true):TToken; overload;
protected
procedure block;
procedure constant;
procedure uconstant;
procedure typedef;
public
procedure prg;
public
constructor Create( Lexer: TwpLex);
destructor Destroy; override;
end;
EwpPar = Exception;
implementation
{ TwpPar }
// @@@: Construction / destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Construction / destruction
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Constructor
// ================================================================================================
constructor TwpPar.Create(Lexer: TwpLex);
begin
inherited Create;
fLex := Lexer;
fConstants := TStringMap.Create;
fTypes := TStringMap.Create;
end;
// ================================================================================================
// Destructor
// ================================================================================================
destructor TwpPar.Destroy;
begin
fConstants .Free;
fTypes .Free;
inherited
end;
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Internals
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
//
// ================================================================================================
function TwpPar.Match(ttype: TTokenType; dispose: boolean): TToken;
var
t: TToken;
begin
result := nil;
t := fLex.NextToken;
if t.TokenType = ttype then
if dispose
then t.Free
else result := t
else
raise EwpPar.Create('Unexpected token')
end;
// ================================================================================================
//
// ================================================================================================
function TwpPar.Match(ttypes: TTokenTypes; dispose: boolean): TToken;
var
t: TToken;
begin
result := nil;
t := fLex.NextToken;
if t.TokenType in ttypes then
if dispose
then t.Free
else result := t
else
raise EwpPar.Create('Unexpected token')
end;
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// Interface
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// Program
// ================================================================================================
procedure TwpPar.prg;
var
t : TToken;
begin
if Assigned( fLex) then
begin
Match(LT_PROGRAM);
Match(TT_ID);
Match(TT_LPAREN);
t := fLex.NextToken;
// id [, id]*
if t.TokenType = TT_ID then
begin
t.Free;
t := fLex.NextToken;
while t.TokenType = TT_COMMA do
begin
t.Free;
Match(TT_ID);
t := fLex.NextToken;
end;
end;
if t.TokenType <> TT_RPAREN then
raise EwpPar.Create('")" expected');
Match(TT_SEMI);
block;
Match(TT_DOT)
end;
end;
// ================================================================================================
// block
// ================================================================================================
procedure TwpPar.block;
var
token : TToken;
ttype : TTokenType;
start : TTokenTypes;
start2: TTokenTypes;
begin
start := [LT_LABEL,LT_CONST,LT_TYPE,LT_VAR,LT_PROCEDURE,LT_FUNCTION,LT_BEGIN];
start2:= [LT_LABEL,LT_CONST,LT_TYPE,LT_VAR,LT_PROCEDURE,LT_FUNCTION];
token := fLex.NextToken;
if token.TokenType in start then
begin
while token.TokenType in start2 do
begin
case token.TokenType of
// ------------------------------------------------------
// Label
// ------------------------------------------------------
LT_LABEL:
while true do
begin
Match( TT_UINT);
token := fLex.NextToken;
ttype := token.TokenType;
token.Free;
case ttype of
TT_COMMA : ;
TT_SEMI : begin token := fLex.NextToken; break end;
else raise EwpPar.Create('Expected: ,;');
end;
end;
// ------------------------------------------------------
// Const
// ------------------------------------------------------
LT_CONST:
begin
token := fLex.NextToken;
ttype := token.TokenType;
while ttype = TT_ID do
begin
token.Free;
Match(TT_EQ);
constant;
Match(TT_SEMI);
token := flex.NextToken;
ttype := token.TokenType;
end;
end;
// ------------------------------------------------------
// Type
// ------------------------------------------------------
LT_TYPE:
begin
token := fLex.NextToken;
ttype := token.TokenType;
while ttype = TT_ID do
begin
token.Free;
Match(TT_EQ);
typedef;
Match(TT_SEMI);
token := flex.NextToken;
ttype := token.TokenType;
end;
end;
LT_VAR:
begin
end;
LT_PROCEDURE:
begin
end;
LT_FUNCTION:
begin
end;
end;
// token := fLex.NextToken
end;
if token.TokenType = LT_BEGIN then
begin
Match(LT_END)
end
else
raise EwpPar.Create('Expected: Begin');
end
else
raise EwpPar.Create('Expected: label, const, type, var, procedure, function, begin');
end;
// ================================================================================================
// Constant
// ================================================================================================
procedure TwpPar.constant;
var
token: TToken;
ttype: TTokenType;
begin
token := fLex.NextToken;
ttype := token.TokenType;
if ttype in [TT_PLUS,TT_MINUS,TT_ID,TT_UINT,TT_UREAL] then
begin
if ttype in [TT_PLUS,TT_MINUS] then
begin
token.Free;
token := fLex.NextToken;
ttype := token.TokenType;
end;
token.Free;
case ttype of
TT_ID : ;
TT_UINT : ;
TT_UREAL : ;
else raise EwpPar.Create('Expected: id,int,real')
end
end
else if ttype in [TT_CHAR, TT_STRING] then
begin
token.Free;
end
else
raise EwpPar.Create('Expected: +,-,id,int,real,string');
end;
// ================================================================================================
// Unsigned constant
// ================================================================================================
procedure TwpPar.uconstant;
var
token: TToken;
ttype: TTokenType;
begin
token := fLex.NextToken;
ttype := token.TokenType;
token.Free;
case token.TokenType of
TT_ID : ;
TT_UINT : ;
TT_UREAL : ;
LT_NIL : ;
TT_STRING: ;
else raise EwpPar.Create('Expected: id,int,real,nil,string')
end;
end;
// ================================================================================================
// Type
// ================================================================================================
procedure TwpPar.typedef;
var
token: TToken;
ttype: TTokenType;
ttext: AnsiString;
f_const : TTokenTypes;
begin
token := fLex.NextToken;
ttype := token.TokenType;
ttext := token.TokenText;
token.Free;
// ---------------------------------------------------------------
// TT_ID
//
// Identifier can be an existing type identifier, or an existing
// constant identifier. If it is contant identifier, then it must
// be a range specification.
// ---------------------------------------------------------------
if ttype = TT_ID then
begin
// --------------------------------------------------
// constant .. constant
// --------------------------------------------------
if fConstants.ContainsKey(ttext) then
begin
Match(TT_RANGE);
token := fLex.NextToken;
ttype := token.TokenType;
ttext := token.TokenText;
token.Free;
end
// --------------------------------------------------
// type identifier
// --------------------------------------------------
else if fTypes.ContainsKey(ttext) then
begin
end
// --------------------------------------------------
// Not an constant or type identifier
// --------------------------------------------------
else
EwpPar.Create('Expected a type or constant identifier' );
end;
end;
end.
+42
View File
@@ -0,0 +1,42 @@
program wp;
{$APPTYPE CONSOLE}
uses
Classes,
SysUtils,
dpgRTL,
wpParser in 'wpParser.pas',
wpLexer in 'wpLexer.pas';
var
stm: TFileStream;
lex: TwpLexer;
par: TwpParser;
begin
if ParamCount <> 1 then
begin
writeln('usage: wp <filename>');
exit;
end;
stm := nil;
par := nil;
try
stm := TFileStream.Create( ParamStr(1), fmOpenRead);
lex := TwpLexer.Create( stm);
par := TwpParser.Create(lex);
par.prog;
except
on e: EdpgMismatchedChar do writeln('SyntaxError: ' + IntToStr(e.Line));
on e: EdpgMismatchedToken do writeln('SyntaxError: ' + IntToStr(e.FoundToken.TokenLine));
else writeln('Syntax error');
end;
if stm <> nil then stm.free;
if par <> nil then par.free;
end.
+237
View File
@@ -0,0 +1,237 @@
unit wpLexer;
lexer TwpLexer;
options
{
exportVocab=wpLexer;
caseSensitive=false;
testLiterals=false;
k=2;
}
tokens
{
"do";
"if";
"in";
"of";
"or";
"to";
"and";
"div";
"end";
"for";
"mod";
"nil";
"not";
"set";
"var";
"xor";
"case";
"else";
"file";
"goto";
"then";
"type";
"uses";
"with";
"array";
"begin";
"const";
"label";
"until";
"while";
"downto";
"packed";
"record";
"repeat";
"program";
"function";
"procedure";
STRING;
CHAR;
}
// ============================================================================
// Simple tokens
// ============================================================================
LPAREN : '(';
RPAREN : ')';
LBRACKET : '[';
RBRACKET : ']';
COMMA : ',';
COLON : ':';
SEMI : ';';
DOT : '.';
RANGE : "..";
ASSIGN : ":=";
EQ : '=';
GT : '>';
LT : '<';
GE : ">=";
LE : "<=";
NE : "<>";
PLUS : '+';
MINUS : '-';
STAR : '*';
SLASH : '/';
PTR : '^';
// ============================================================================
// Identifier
// ============================================================================
ID
options
{
testLiterals=true;
}
: LETTER (LETTER | DIGIT)* ;
// ============================================================================
// Int or real
// ============================================================================
UINT_OR_REAL
: (UINT RANGE) => UINT { _ttype := TT_UINT; }
| (UINT DOT) => UREAL { _ttype := TT_UREAL; }
| (UINT ('E'|'e')) => UREAL { _ttype := TT_UREAL; }
| UINT { _ttype := TT_UINT; }
;
// ============================================================================
// Protected rules
// ============================================================================
protected
LETTER : 'a'..'z' | 'A'..'Z' | '_';
// ============================================================================
// Int
// ============================================================================
protected
UINT
: (DIGIT)+
;
// ============================================================================
// Real
// ============================================================================
protected
UREAL
: UINT ('.' UINT)? ( ('e' | 'E') ('+'|'-')? UINT)?
;
// ============================================================================
// Digit
// ============================================================================
protected
DIGIT
: '0'..'9'
;
// ============================================================================
// String or char
// ============================================================================
STRING_OR_CHAR
: '\'' (~'\'' | '\'' '\'')* '\''
{
if TokenText = '''''' then _ttype := TT_STRING
else if TokenText = '''''''''' then _ttype := TT_CHAR
else if Length( TokenText) > 3 then _ttype := TT_STRING
else _ttype := TT_CHAR;
}
;
// ============================================================================
// Single line comment
// ============================================================================
SLCOMMENT
:
"//"
( ~( '\r' | '\n') )*
(
'\r' '\n' { newLine; }
| '\r' { newLine; }
| '\n' { newLine; }
)
{
_ttype := TT_SKIP;
}
;
// ============================================================================
// Multi line comment version 1
// Nested comments aren't allowed!
// ============================================================================
MLCOMMENT1
:
"(*"
(
options
{
greedy = false;
generateAmbigWarnings = false;
}
: '\r' '\n' { newLine; }
| '\r' { newLine; }
| '\n' { newLine; }
| .
)*
"*)"
{
_ttype := TT_SKIP;
}
;
// ============================================================================
// Multi line comment version 2
// Nested comments aren't allowed!
// ============================================================================
MLCOMMENT2
:
"{"
(
options
{
greedy = false;
generateAmbigWarnings = false;
}
: '\r' '\n' { newLine; }
| '\r' { newLine; }
| '\n' { newLine; }
| .
)*
"}"
{
_ttype := TT_SKIP;
}
;
// ============================================================================
// White space
// ============================================================================
WS
:
(
'\r' '\n' { newLine; }
| '\r' { newLine; }
| '\n' { newLine; }
| '\t' { tab; }
| ' '
)
{
_ttype := TT_SKIP;
}
;
+368
View File
@@ -0,0 +1,368 @@
unit wpParser;
parser TwpParser;
options
{
importVocab = wpLexer;
k = 2;
}
// ============================================================================
// prog
// ============================================================================
prog
: "program" id (LPAREN id (COLON id)* RPAREN)? SEMI block DOT
;
// ============================================================================
// block
// ============================================================================
block
: declarations compoundStmt
;
// ============================================================================
// declarations
// ============================================================================
declarations
:
( "label" UINT (COMMA UINT)* SEMI )?
( "const" (id EQ constant SEMI)+ )?
( "type" (id EQ typeSpec SEMI)+ )?
( "var" (id (COMMA id)* COLON typeSpec SEMI)+ )?
(
"procedure" id parameterList SEMI block SEMI
| "function" id parameterList COLON id SEMI block SEMI
)*
;
// ============================================================================
// statement
// ============================================================================
statement
: (UINT COLON)?
(
(variable ASSIGN) => assignmentStmt
| procedureCall
| compoundStmt
| ifStmt
| caseStmt
| whileStmt
| repeatStmt
| forStmt
| withStmt
| gotoStmt
)?
;
// ============================================================================
// assignmentStmt
// ============================================================================
assignmentStmt
: variable ASSIGN expression
;
// ============================================================================
// procedureCall
// ============================================================================
procedureCall
: id (LPAREN expression (widthSpec)? (COMMA expression (widthSpec)? )* RPAREN)?
;
// ============================================================================
// widthSpec
// ============================================================================
widthSpec
: (COLON UINT) (COLON UINT)?
;
// ============================================================================
// compoundStmt
// ============================================================================
compoundStmt
: "begin" (statement (SEMI statement)*)? "end"
;
// ============================================================================
// ifStmt
// ============================================================================
ifStmt
: "if" expression "then" statement
(
("else") => "else" statement
|
)
;
// ============================================================================
// caseStmt
// ============================================================================
caseStmt
: "case" expression "of"
( caseStmtItem (SEMI caseStmtItem)* )?
"end"
;
// ============================================================================
// caseStmtItem
// ============================================================================
caseStmtItem
: constant (COMMA constant)* COLON statement
;
// ============================================================================
// whileStmt
// ============================================================================
whileStmt
: "while" expression "do" statement
;
// ============================================================================
// repeatStmt
// ============================================================================
repeatStmt
: "repeat" (statement (SEMI statement)*)? "until" expression
;
// ============================================================================
// forStmt
// ============================================================================
forStmt
: "for" id ASSIGN expression ("to" | "downto") expression "do" statement
;
// ============================================================================
// withStmt
// ============================================================================
withStmt
: "with" variable (COMMA variable)* "do" statement
;
// ============================================================================
// gotoStmt
// ============================================================================
gotoStmt
: "goto" UINT
;
// ============================================================================
// parameterList
// ============================================================================
parameterList
: (
LPAREN
parameter (SEMI parameter)*
RPAREN
)?
;
// ============================================================================
// parameter
// ============================================================================
parameter
: ("var" | "function")? id (COMMA id)* COLON typeId
| "procedure" id (COMMA id)*
;
// ============================================================================
// expression
// ============================================================================
expression
: simpleExpression (relOp simpleExpression)*
;
// ============================================================================
// simpleExpression
// ============================================================================
simpleExpression
: (PLUS|MINUS)? term (addOp term)*
;
// ============================================================================
// term
// ============================================================================
term
: factor (mulOp factor)*
;
// ============================================================================
// factor
// ============================================================================
factor
: uNumber
| "nil"
| CHAR
| STRING
| (id LPAREN) => procedureCall
| variable
| LPAREN expression RPAREN
| "not" factor
| LBRACKET (expression (RANGE expression)? (COMMA expression (RANGE expression)? )* )? RBRACKET
;
// ============================================================================
// variable
// ============================================================================
variable
: variableId
(
LBRACKET expression (COMMA expression)* RBRACKET
| DOT fieldId
| PTR
)*
;
// ============================================================================
// fieldList
// ============================================================================
fieldList
: simpleFieldList (simpleFieldList)* (variantFieldList)?
|
;
// ============================================================================
// simpleFieldList
// ============================================================================
simpleFieldList
: id (COMMA id)* COLON typeSpec
;
// ============================================================================
// caseFieldList
// ============================================================================
variantFieldList
: "case" (id COLON)? typeId "of"
constant (COMMA constant)* COLON LPAREN fieldList RPAREN
(SEMI constant (COMMA constant)* COLON LPAREN fieldList RPAREN)*
;
// ============================================================================
// typeSpecification
// ============================================================================
typeSpec
: simpleType
| PTR typeId
| ("packed")?
(
"array" LBRACKET simpleType (COMMA simpleType)* RBRACKET "of" typeSpec
| "file" "of" typeSpec
| "set" "of" simpleType
| "record" fieldList "end"
)
;
// ============================================================================
// simpleType
// ============================================================================
simpleType
: (constant RANGE) => constant RANGE constant
| typeId
| LPAREN id (COMMA id)* RPAREN
;
// ============================================================================
// constant
// ============================================================================
constant
: (PLUS | MINUS)? (constantId | uNumber)
| CHAR
;
// ============================================================================
// unsignedConstant
// ============================================================================
uConstant
: constantId
| uNumber
| "nil"
| CHAR
;
// ============================================================================
// unumber
// ============================================================================
uNumber
: UINT
| UREAL
;
// ============================================================================
// uint
// ============================================================================
uInt
: UINT;
// ============================================================================
// fieldId
// ============================================================================
fieldId
: id
;
// ============================================================================
// variableId
// ============================================================================
variableId
: id
;
// ============================================================================
// typeId
// ============================================================================
typeId
: id
;
// ============================================================================
// constantId
// ============================================================================
constantId
: id
;
// ============================================================================
// id
// ============================================================================
id
: ID
;
// ============================================================================
// relOp
// ============================================================================
relOp
: GT
| LT
| GE
| LE
| NE
| EQ
| "in"
;
// ============================================================================
// addOp
// ============================================================================
addOp
: PLUS
| MINUS
| "or"
| "xor"
;
// ============================================================================
// mulOp
// ============================================================================
mulOp
: STAR
| SLASH
| "div"
| "mod"
| "and"
;