paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 00:29:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Expression parsing tests, nested types

Browse Source 
git-svn-id: trunk@22144 -
This commit is contained in:
michael 2012-08-20 16:36:18 +00:00
parent 811b65da87
commit 649bbae1c3
10 changed files with 1112 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2328,6 +2328,7 @@ packages/fcl-passrc/src/pscanner.pp svneol=native#text/plain
packages/fcl-passrc/src/readme.txt svneol=native#text/plain
packages/fcl-passrc/tests/tcbaseparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcclasstype.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcexprparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain

15
packages/fcl-passrc/src/pastree.pp
View File

@ -192,6 +192,7 @@ type
{ TInheritedExpr }
TInheritedExpr = class(TPasExpr)
Public
constructor Create(AParent : TPasElement); overload;
function GetDeclaration(full : Boolean) : string; override;
end;
@ -492,7 +493,7 @@ type
Members: TFPList; // array of TPasVariable elements
VariantName: string;
VariantType: TPasType;
Variants: TFPList; // array of TPasVariant elements, may be nil!
Variants: TFPList; // array of TPasVariant elements, may be nil!
Function IsPacked: Boolean;
Function IsBitPacked : Boolean;
end;
@ -616,7 +617,7 @@ type
end;
{ TPasVariable }
TVariableModifier = (vmCVar, vmExternal, vmPublic, vmExport);
TVariableModifier = (vmCVar, vmExternal, vmPublic, vmExport, vmClass);
TVariableModifiers = set of TVariableModifier;
TPasVariable = class(TPasElement)
@ -692,7 +693,7 @@ type
TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
pmExported, pmOverload, pmMessage, pmReintroduce,
pmStatic,pmInline,pmAssembler,pmVarargs,
pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
pmCompilerProc,pmExternal,pmForward);
TProcedureModifiers = Set of TProcedureModifier;
TProcedureMessageType = (pmtInteger,pmtString);
@ -1023,11 +1024,12 @@ type
end;
{ TPasImplAssign }
TAssignKind = (akDefault,akAdd,akMinus,akMul,akDivision);
TPasImplAssign = class (TPasImplStatement)
public
left : TPasExpr;
right : TPasExpr;
Kind : TAssignKind;
Destructor Destroy; override;
end;
@ -1136,6 +1138,7 @@ const
cCallingConventions : array[TCallingConvention] of string =
( '', 'Register','Pascal','CDecl','StdCall','OldFPCCall','SafeCall');
implementation
uses SysUtils;
@ -1203,7 +1206,6 @@ begin
Result:=Result+' name '+ExportName.GetDeclaration(Full)
else if (ExportIndex<>Nil) then
Result:=Result+' index '+ExportIndex.GetDeclaration(Full);
end;
{ TPasUnresolvedUnitRef }
@ -3225,7 +3227,7 @@ end;
{ TInheritedExpr }
Function TInheritedExpr.GetDeclaration(Full :Boolean):AnsiString;
function TInheritedExpr.GetDeclaration(full: Boolean): string;
begin
Result:='Inherited';
end;
@ -3291,6 +3293,7 @@ begin
inherited Create(AParent,pekInherited, eopNone);
end;
{ TSelfExpr }
constructor TSelfExpr.Create(AParent : TPasElement);

136
packages/fcl-passrc/src/pparser.pp
View File

@ -135,6 +135,7 @@ type
function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string;
function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility);
procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean);
protected
function LogEvent(E : TPParserLogEvent) : Boolean; inline;
@ -144,7 +145,7 @@ type
procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken);
procedure ParseRecordVariantParts(ARec: TPasRecordType; AEndToken: TToken);
function GetProcedureClass(ProcType : TProcType): TPTreeElement;
procedure ParseClassFields(AType: TPasClassType; const AVisibility: TPasMemberVisibility);
procedure ParseClassFields(AType: TPasClassType; const AVisibility: TPasMemberVisibility; IsClassField : Boolean);
procedure ParseClassMembers(AType: TPasClassType);
procedure ProcessMethod(AType: TPasClassType; IsClass : Boolean; AVisibility : TPasMemberVisibility);
procedure ReadGenericArguments(List : TFPList;Parent : TPasElement);
@ -160,7 +161,7 @@ type
Function IsCurTokenHint(out AHint : TPasMemberHint) : Boolean; overload;
Function IsCurTokenHint: Boolean; overload;
Function TokenIsCallingConvention(S : String; out CC : TCallingConvention) : Boolean; virtual;
Function TokenIsProcedureModifier(S : String; Out Pm : TProcedureModifier) : Boolean; virtual;
Function TokenIsProcedureModifier(Parent : TPasElement; S : String; Out Pm : TProcedureModifier) : Boolean; virtual;
Function CheckHint(Element : TPasElement; ExpectSemiColon : Boolean) : TPasMemberHints;
function ParseParams(AParent : TPasElement;paramskind: TPasExprKind): TParamsExpr;
function ParseExpIdent(AParent : TPasElement): TPasExpr;
@ -308,7 +309,7 @@ Const
ModifierNames : Array[TProcedureModifier] of string
= ('virtual', 'dynamic','abstract', 'override',
'exported', 'overload', 'message', 'reintroduce',
'static','inline','assembler','varargs',
'static','inline','assembler','varargs', 'public',
'compilerproc','external','forward');
Var
@ -368,19 +369,16 @@ var
case s[2] of
'd': // -d define
Scanner.AddDefine(UpperCase(Copy(s, 3, Length(s))));
'S': // -d define
case S[3] of
'c' :Scanner.Options:=Scanner.Options+[c_assignments];
end;
'F': // -F
if (length(s)>2) and (s[3] = 'i') then // -Fi include path
FileResolver.AddIncludePath(Copy(s, 4, Length(s)));
'I': // -I include path
FileResolver.AddIncludePath(Copy(s, 3, Length(s)));
'S': // -S mode
if (length(s)>2) and (s[3]='d') then
begin // -Sd mode delphi
Parser.Options:=Parser.Options+[po_delphi];
if (length(s)>2) then
case S[3] of
'c' : Scanner.Options:=Scanner.Options+[po_cassignments];
'd' : Parser.Options:=Parser.Options+[po_delphi];
end;
end;
end else
@ -658,9 +656,15 @@ begin
Result:=IsCallingConvention(S,CC);
end;
function TPasParser.TokenIsProcedureModifier(S: String; out Pm: TProcedureModifier): Boolean;
function TPasParser.TokenIsProcedureModifier(Parent : TPasElement; S: String; out Pm: TProcedureModifier): Boolean;
begin
Result:=IsModifier(S,PM);
if result and (pm=pmPublic)then
begin
While (Parent<>Nil) and Not (Parent is TPasClassType) do
Parent:=Parent.Parent;
Result:=Not Assigned(Parent);
end;
end;
@ -1142,11 +1146,13 @@ begin
tkfalse, tktrue: x:=TBoolConstExpr.Create(Aparent,pekBoolConst, CurToken=tktrue);
tknil: x:=TNilExpr.Create(Aparent);
tkSquaredBraceOpen: x:=ParseParams(AParent,pekSet);
tkinherited: begin
tkinherited:
begin
//inherited; inherited function
x:=TInheritedExpr.Create(AParent);
NextToken;
if (length(CurTokenText)>0) and (CurTokenText[1] in ['A'..'_']) then begin
if (CurToken=tkIdentifier) then
begin
b:=TBinaryExpr.Create(AParent,x, DoParseExpression(AParent), eopNone);
if not Assigned(b.right) then
begin
@ -1155,9 +1161,10 @@ begin
end;
x:=b;
UngetToken;
end
else UngetToken;
end;
end
else
UngetToken;
end;
tkself: begin
//x:=TPrimitiveExpr.Create(AParent,pekString, CurTokenText); //function(self);
x:=TSelfExpr.Create(AParent);
@ -2231,7 +2238,7 @@ begin
if Result then
begin
NextToken;
Value := DoParseExpression(Parent);
Value := DoParseConstValueExpression(Parent);
// NextToken;
end;
if (CurToken=tkAbsolute) then
@ -2548,7 +2555,7 @@ Var
begin
if parent is TPasProcedure then
TPasProcedure(Parent).AddModifier(pm);
if pm=pmExternal then
if (pm=pmExternal) then
begin
NextToken;
if CurToken in [tkString,tkIdentifier] then
@ -2570,6 +2577,23 @@ begin
else
UngetToken;
end
else if (pm = pmPublic) then
begin
NextToken;
{ Should be token Name,
if not we're in a class and the public section starts }
If (Uppercase(CurTokenString)<>'NAME') then
begin
UngetToken;
UngetToken;
exit;
end
else
begin
NextToken; // Should be export name string.
ExpectToken(tkSemicolon);
end;
end
else if pm=pmForward then
begin
if (Parent.Parent is TInterfaceSection) then
@ -2643,7 +2667,6 @@ begin
TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent)
else
ParseType(nil);
Writeln('Function : ',TokenInfos[Curtoken],' ',CurtokenString);
end;
ptOperator:
begin
@ -2699,38 +2722,22 @@ begin
Element.CallingConvention:=Cc;
ExpectToken(tkSemicolon);
end
else if TokenIsProcedureModifier(CurTokenString,pm) then
else if TokenIsProcedureModifier(Parent,CurTokenString,pm) then
HandleProcedureModifier(Parent,Pm)
else if (CurToken = tkIdentifier) or (CurToken=tklibrary) then // library is a token and a directive.
else if (CurToken=tklibrary) then // library is a token and a directive.
begin
Tok:=UpperCase(CurTokenString);
if DoCheckHint then
begin
consumesemi;
end
else if (tok = 'PUBLIC') then
begin
NextToken;
{ Should be token Name,
if not we're in a class and the public section starts }
If (Uppercase(CurTokenString)<>'NAME') then
begin
UngetToken;
UngetToken;
Break;
end
else
begin
NextToken; // Should be export name string.
ExpectToken(tkSemicolon);
end;
end
NextToken;
If (tok<>'NAME') then
Element.Hints:=Element.Hints+[hLibrary]
else
begin
UnGetToken;
Break;
end
NextToken; // Should be export name string.
ExpectToken(tkSemicolon);
end;
end
else if DoCheckHint then
consumesemi
else if (CurToken = tkSquaredBraceOpen) then
begin
repeat
@ -2742,11 +2749,12 @@ begin
if Done then
begin
NextToken;
Done:=Not (IsCurtokenHint or IsModifier(CurtokenString,Pm) or TokenisCallingConvention(CurTokenString,cc));
Done:=Not ((Curtoken=tkSquaredBraceOpen) or TokenIsProcedureModifier(Parent,CurtokenString,Pm) or IscurtokenHint() or TokenisCallingConvention(CurTokenString,cc));
// DumpCurToken('Done '+IntToStr(Ord(Done)));
UngetToken;
end;
// Writeln('Done: ',TokenInfos[Curtoken],' ',CurtokenString);
Until Done;
// Writeln('End: ',TokenInfos[Curtoken],' ',CurtokenString);
if DoCheckHint then // deprecated,platform,experimental,library, unimplemented etc
ConsumeSemi;
if (ProcType = ptOperator) and (Parent is TPasProcedure) then
@ -3484,7 +3492,7 @@ end;
procedure TPasParser.DumpCurToken(Const Msg : String);
begin
Writeln(Msg,' : ',TokenInfos[CurToken],' "',CurTokenString,'"');
Writeln(Msg,' : ',TokenInfos[CurToken],' "',CurTokenString,'"',Scanner.CurFilename,'(',Scanner.CurRow,',',SCanner.CurColumn,') : ',Scanner.CurLine);
Flush(output)
end;
@ -3606,7 +3614,7 @@ begin
AType.Members.Add(Proc);
end;
procedure TPasParser.ParseClassFields(AType: TPasClassType; Const AVisibility : TPasMemberVisibility);
procedure TPasParser.ParseClassFields(AType: TPasClassType; Const AVisibility : TPasMemberVisibility; IsClassField : Boolean);
Var
VarList: TFPList;
@ -3621,6 +3629,8 @@ begin
begin
Element := TPasElement(VarList[i]);
Element.Visibility := AVisibility;
if IsClassField and (Element is TPasVariable) then
TPasVariable(Element).VarModifiers:=TPasVariable(Element).VarModifiers+[vmClass];
AType.Members.Add(Element);
end;
finally
@ -3628,6 +3638,25 @@ begin
end;
end;
procedure TPasParser.ParseClassLocalTypes(AType: TPasClassType; AVisibility : TPasMemberVisibility);
Var
T : TPasType;
Done : Boolean;
begin
// Writeln('Parsing local types');
Repeat
T:=ParseTypeDecl(AType);
T.Visibility:=AVisibility;
AType.Members.Add(t);
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
NextToken;
Done:=Curtoken<>tkIdentifier;
if Done then
UngetToken;
Until Done;
end;
procedure TPasParser.ParseClassMembers(AType: TPasClassType);
Var
@ -3638,13 +3667,18 @@ begin
while (CurToken<>tkEnd) do
begin
case CurToken of
tkType:
begin
ExpectToken(tkIdentifier);
ParseClassLocalTypes(AType,CurVisibility);
end;
tkVar,
tkIdentifier:
begin
if CurToken=tkVar then
ExpectToken(tkIdentifier);
if Not CheckVisibility(CurtokenString,CurVisibility) then
ParseClassFields(AType,CurVisibility);
ParseClassFields(AType,CurVisibility,false);
end;
tkProcedure,tkFunction,tkConstructor,tkDestructor:
ProcessMethod(AType,False,CurVisibility);
@ -3656,7 +3690,7 @@ begin
else if CurToken = tkVar then
begin
ExpectToken(tkIdentifier);
ParseClassFields(AType,CurVisibility);
ParseClassFields(AType,CurVisibility,true);
end
else if CurToken=tkProperty then
begin

8
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -60,6 +60,7 @@ Type
Function AssertExpression(Const Msg: String; AExpr : TPasExpr; aKind : TPasExprKind; AValue : String) : TPrimitiveExpr;
Procedure AssertExportSymbol(Const Msg: String; AIndex : Integer; AName,AExportName : String; AExportIndex : Integer = -1);
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TPasExprKind); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TexprOpcode); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TPasMemberHint); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TCallingConvention); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TArgumentAccess); overload;
@ -345,6 +346,13 @@ begin
GetEnumName(TypeInfo(TPasExprKind),Ord(AActual)));
end;
procedure TTestParser.AssertEquals(const Msg: String; AExpected,
AActual: TexprOpcode);
begin
AssertEquals(Msg,GetEnumName(TypeInfo(TexprOpcode),Ord(AExpected)),
GetEnumName(TypeInfo(TexprOpcode),Ord(AActual)));
end;
procedure TTestParser.AssertEquals(const Msg: String; AExpected,
AActual: TPasMemberHint);
begin

105
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -21,10 +21,11 @@ type
FStarted: Boolean;
function GetF1: TPasVariable;
function GetM(AIndex : Integer): TPasElement;
function GetM1: TPasProcedure;
function GetMM(AIndex : Integer): TPasProcedure;
function GetMF1: TPasFunction;
function GetP1: TPasProperty;
function GetP2: TPasProperty;
function GetT(AIndex : Integer) : TPasType;
protected
Procedure StartClass (AParent : String = 'TObject'; InterfaceList : String = '');
Procedure StartVisibility(A : TPasMemberVisibility);
@ -42,10 +43,14 @@ type
Property Members[AIndex : Integer] : TPasElement Read GetM;
Property Member1 : TPasElement Read FMember1;
Property Field1 : TPasVariable Read GetF1;
Property Method1 : TPasProcedure Read GetM1;
Property Method1 : TPasProcedure Index 0 Read GetMM;
Property Method2 : TPasProcedure Index 1 Read GetMM;
Property Method3 : TPasProcedure index 2 Read GetMM;
Property FunctionMethod1 : TPasFunction Read GetMF1;
Property Property1 : TPasProperty Read GetP1;
Property Property2 : TPasProperty Read GetP2;
Property Type1 : TPasType Index 0 Read GetT;
Property Type2 : TPasType Index 1 Read GetT;
published
procedure TestEmpty;
procedure TestEmptyDeprecated;
@ -54,10 +59,13 @@ type
Procedure TestOneInterface;
Procedure TestTwoInterfaces;
Procedure TestOneField;
Procedure TestOneVarField;
Procedure TestOneClassField;
Procedure TestOneFieldVisibility;
Procedure TestOneFieldDeprecated;
Procedure TestTwoFields;
Procedure TestTwoFieldsB;
Procedure TestTwoVarFieldsB;
Procedure TestTwoFieldsVisibility;
procedure TestHintFieldDeprecated;
procedure TestHintFieldPlatform;
@ -100,6 +108,8 @@ type
Procedure TestPropertyImplementsFullyQualifiedName;
Procedure TestPropertyReadFromRecordField;
procedure TestPropertyReadWriteFromRecordField;
Procedure TestLocalSimpleType;
Procedure TestLocalSimpleTypes;
end;
implementation
@ -117,11 +127,11 @@ begin
Result:=TPasElement(TheClass.Members[AIndex])
end;
function TTestClassType.GetM1: TPasProcedure;
function TTestClassType.GetMM(AIndex : integer): TPasProcedure;
begin
AssertNotNull('Have 1 member',Member1);
AssertEquals('Member 1 is method',TPasProcedure,Member1.ClassType);
Result:=TPasProcedure(Member1);
AssertNotNull('Have member '+IntToStr(AIndex),Members[AIndex]);
AssertEquals('Member is method '+IntToStr(AIndex),TPasProcedure,Members[Aindex].ClassType);
Result:=TPasProcedure(Members[Aindex]);
end;
function TTestClassType.GetMF1: TPasFunction;
@ -145,6 +155,14 @@ begin
Result:=TPasProperty(Members[1]);
end;
function TTestClassType.GetT(Aindex :integer): TPasType;
begin
AssertNotNull('Have member '+IntToStr(AIndex),Members[AIndex]);
if not (Members[AIndex] is TPasType) then
Fail('Member '+IntToStr(AIndex)+' is not a type');
Result:=TPasType(Members[AIndex]);
end;
function TTestClassType.GetF1: TPasVariable;
begin
AssertNotNull('Have 1 member',Member1);
@ -325,6 +343,30 @@ begin
AssertVisibility;
end;
procedure TTestClassType.TestOneVarField;
begin
StartVisibility(visPublished);
FDecl.Add('var');
AddMember('a : integer');
ParseClass;
AssertNotNull('Have 1 field',Field1);
AssertMemberName('a');
AssertVisibility(visPublished);
end;
procedure TTestClassType.TestOneClassField;
begin
StartVisibility(visPublished);
FDecl.Add('class var');
AddMember('a : integer');
ParseClass;
AssertNotNull('Have 1 field',Field1);
AssertMemberName('a');
AssertVisibility(visPublished);
if not (vmClass in Field1.VarModifiers) then
Fail('Field is not a class field');
end;
procedure TTestClassType.TestOneFieldVisibility;
begin
StartVisibility(visPublished);
@ -374,6 +416,22 @@ begin
AssertVisibility(visDefault,Members[1]);
end;
procedure TTestClassType.TestTwoVarFieldsB;
begin
StartVisibility(visPublic);
FDecl.Add('var');
AddMember('a,b : integer');
ParseClass;
AssertEquals('2 members',2,TheClass.members.Count);
AssertNotNull('Have field',Field1);
AssertMemberName('a');
AssertVisibility(vispublic);
AssertNotNull('Have field',Members[1]);
AssertMemberName('b',Members[1]);
AssertMemberType(TPasVariable,Members[1]);
AssertVisibility(visPublic,Members[1]);
end;
procedure TTestClassType.TestTwoFieldsVisibility;
begin
StartVisibility(visPublic);
@ -985,6 +1043,41 @@ begin
Assertequals('Default value','',Property1.DefaultValue);
end;
procedure TTestClassType.TestLocalSimpleType;
begin
StartVisibility(visPublic);
FDecl.add('Type');
AddMember('TDirection = (left,right)');
AddMember('Procedure Something');
ParseClass;
AssertEquals('Local Enumeration type',TPasEnumType, Type1.ClassType);
AssertEquals('Visibility is correct',VisPublic, Type1.Visibility);
AssertEquals('Type name','TDirection', Type1.Name);
AssertSame('Type parent is class',TheClass, Type1.Parent);
AssertNotNull('Member 2 is procedure',Method2);
AssertEquals('method name','Something', Method2.Name);
end;
procedure TTestClassType.TestLocalSimpleTypes;
begin
StartVisibility(visPublic);
FDecl.add('Type');
AddMember('TDirection = (left,right)');
AddMember('TVerticalDirection = (up,down)');
AddMember('Procedure Something');
ParseClass;
AssertEquals('Local Enumeration type',TPasEnumType, Type1.ClassType);
AssertEquals('Visibility is correct',VisPublic, Type1.Visibility);
AssertEquals('Type name','TDirection', Type1.Name);
AssertSame('Type parent is class',TheClass, Type1.Parent);
AssertEquals('Local Enumeration type',TPasEnumType, Type2.ClassType);
AssertEquals('Visibility is correct',VisPublic, Type2.Visibility);
AssertEquals('Type name','TVerticalDirection', Type2.Name);
AssertSame('Type parent is class',TheClass, Type2.Parent);
AssertNotNull('Member 2 is procedure',Method3);
AssertEquals('method name','Something', Method3.Name);
end;
initialization
RegisterTest(TTestClassType);

901
packages/fcl-passrc/tests/tcexprparser.pas Normal file
View File

@ -0,0 +1,901 @@
unit tcexprparser;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry, tcbaseparser, pastree;
type
{ TTestExpressions }
TTestExpressions= class(TTestParser)
private
FLeft: TPAsExpr;
FRight: TPAsExpr;
FTheExpr: TPasExpr;
FVariables : TStringList;
procedure AssertLeftPrecedence(AInnerLeft: Integer; AInnerOp: TExprOpCode;
AInnerRight: Integer; AOuterOp: TexprOpCode; AOuterRight: Integer);
procedure AssertRightPrecedence(AOuterLeft: Integer; AOuterOp: TExprOpCode;
AInnerLeft: Integer; AInnerOp: TexprOpCode; AInnerRight: Integer);
procedure DeclareVar(const AVarType: String; const AVarName: String = 'a');
protected
procedure SetUp; override;
procedure TearDown; override;
Procedure SetExpression(Const AExpression : String);
Procedure ParseExpression;
Procedure ParseExpression(Const AExpression : String);
Function AssertBinaryExpr(Const Msg : String; Op : TExprOpCode; Out ALeft,ARight : TPasExpr) : TBinaryExpr;
Function AssertBinaryExpr(Const Msg : String; AExpr : TPasExpr; Op : TExprOpCode; Out ALeft,ARight : TPasExpr) : TBinaryExpr;
Function AssertUnaryExpr(Const Msg : String; Op : TExprOpCode; Out AOperand : TPasExpr) : TUnaryExpr;
Function AssertUnaryExpr(Const Msg : String; AExpr: TPasExpr; Op : TExprOpCode; Out AOperand : TPasExpr) : TUnaryExpr;
Property TheExpr : TPasExpr read FTheExpr;
Property Theleft : TPAsExpr Read FLeft;
Property TheRight : TPAsExpr Read FRight;
published
{
TPasExprKind = (pekRange,
pekListOfExp, );
}
procedure TestPrimitiveInteger;
procedure TestPrimitiveIntegerHex;
procedure TestPrimitiveIntegerOctal;
procedure TestPrimitiveIntegerBinary;
procedure TestPrimitiveDouble;
procedure TestPrimitiveString;
procedure TestPrimitiveIdent;
procedure TestPrimitiveBooleanFalse;
procedure TestPrimitiveBooleanTrue;
procedure TestPrimitiveNil;
procedure TestPrimitiveSet;
procedure TestPrimitiveChar;
procedure TestPrimitiveControlChar;
procedure TestPrimitiveSetEmpty;
procedure TestPrimitiveSelf;
Procedure TestInherited;
Procedure TestInheritedFunction;
Procedure TestUnaryMinus;
Procedure TestUnaryMinusWhiteSpace;
Procedure TestUnaryAddress;
Procedure TestUnaryNot;
Procedure TestUnaryDeref;
Procedure TestBinaryAdd;
Procedure TestBinarySubtract;
Procedure TestBinaryMultiply;
Procedure TestBinaryDivision;
Procedure TestBinaryPower;
Procedure TestBinaryMod;
Procedure TestBinaryDiv;
procedure TestBinaryShl;
procedure TestBinaryShr;
Procedure TestBinarySymmetricalDifference;
Procedure TestBinaryAnd;
Procedure TestBinaryOr;
Procedure TestBinaryXOr;
Procedure TestBinaryIn;
Procedure TestBinaryIs;
Procedure TestBinaryAs;
Procedure TestBinaryEquals;
Procedure TestBinaryDiffers;
Procedure TestBinaryLessThan;
Procedure TestBinaryLessThanEqual;
Procedure TestBinaryLargerThan;
Procedure TestBinaryLargerThanEqual;
procedure TestBinaryFullIdent;
Procedure TestArrayElement;
Procedure TestArrayElement2Dims;
Procedure TestFunctionCall;
Procedure TestFunctionCall2args;
Procedure TestFunctionCallNoArgs;
Procedure TestRange;
Procedure TestBracketsTotal;
Procedure TestBracketsLeft;
Procedure TestBracketsRight;
Procedure TestPrecedenceLeftToRight;
Procedure TestPrecedenceLeftToRightMinus;
Procedure TestPrecedenceLeftToRightMultiply;
Procedure TestPrecedenceLeftToRightDivision;
Procedure TestPrecedenceLeftToRightPlusMinus;
Procedure TestPrecedenceLeftToRightMinusPlus;
Procedure TestPrecedenceLeftToRightMultiplyDivision;
Procedure TestPrecedenceLeftToRightDivisionMultiply;
Procedure TestPrecedencePlusMultiply;
Procedure TestPrecedencePlusDivide;
Procedure TestPrecedenceMinusMultiply;
Procedure TestPrecedenceMinusDivide;
Procedure TestPrecedencePlusOr;
Procedure TestPrecedenceAndOr;
Procedure TestPrecedenceAndNot;
Procedure TestPrecedencePlusAnd;
Procedure TestPrecedenceMinusOr;
Procedure TestPrecedenceMinusAnd;
Procedure TestPrecedenceMultiplyOr;
Procedure TestPrecedenceMultiplyAnd;
Procedure TestPrecedencePlusDiv;
Procedure TestPrecedencePlusMod;
Procedure TestPrecedenceMultiplyDiv;
Procedure TestPrecedenceDivMultiply;
end;
implementation
procedure TTestExpressions.DeclareVar(const AVarType: String;
const AVarName: String = 'a');
begin
FVariables.Add(AVarName+' : '+AVarType+';');
end;
procedure TTestExpressions.TestPrimitiveInteger;
begin
ParseExpression('1');
AssertExpression('Simple integer',theExpr,pekNumber,'1');
end;
procedure TTestExpressions.TestPrimitiveIntegerHex;
begin
ParseExpression('$FF');
AssertExpression('Simple integer',theExpr,pekNumber,'$FF');
end;
procedure TTestExpressions.TestPrimitiveIntegerOctal;
begin
ParseExpression('&777');
AssertExpression('Simple integer',theExpr,pekNumber,'&777');
end;
procedure TTestExpressions.TestPrimitiveIntegerBinary;
begin
ParseExpression('%10101010');
AssertExpression('Simple integer',theExpr,pekNumber,'%10101010');
end;
procedure TTestExpressions.TestPrimitiveDouble;
begin
ParseExpression('1.2');
AssertExpression('Simple double',theExpr,pekNumber,'1.2');
end;
procedure TTestExpressions.TestPrimitiveString;
begin
DeclareVar('string');
ParseExpression('''123''');
AssertExpression('Simple string',theExpr,pekString,'''123''');
end;
procedure TTestExpressions.TestPrimitiveIdent;
begin
DeclareVar('integer','a');
DeclareVar('integer','b');
ParseExpression('b');
AssertExpression('Simple identifier',theExpr,pekIdent,'b');
end;
procedure TTestExpressions.TestBinaryFullIdent;
begin
DeclareVar('integer','a');
DeclareVar('record x,y : integer; end','b');
ParseExpression('b.x');
AssertBinaryExpr('sub identifier',eopSubIdent,Fleft,FRight);
AssertExpression('Simple identifier',Theleft,pekIdent,'b');
AssertExpression('Simple identifier',Theright,pekIdent,'x');
end;
procedure TTestExpressions.TestArrayElement;
Var
P : TParamsExpr;
begin
DeclareVar('integer','a');
DeclareVar('array[1..2] of integer','b');
ParseExpression('b[1]');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekArrayParams,TParamsExpr));
AssertExpression('Name of array',P.Value,pekIdent,'b');
AssertEquals('One dimension',1,Length(p.params));
AssertExpression('Simple identifier',p.params[0],pekNumber,'1');
end;
procedure TTestExpressions.TestArrayElement2Dims;
Var
P : TParamsExpr;
begin
DeclareVar('integer','a');
DeclareVar('array[1..2,1..2] of integer','b');
ParseExpression('b[1,2]');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekArrayParams,TParamsExpr));
AssertExpression('Name of array',P.Value,pekIdent,'b');
AssertEquals('Two dimensions',2,Length(p.params));
AssertExpression('Simple identifier',p.params[0],pekNumber,'1');
AssertExpression('Simple identifier',p.params[1],pekNumber,'2');
end;
procedure TTestExpressions.TestFunctionCall;
Var
P : TParamsExpr;
begin
DeclareVar('integer','a');
ParseExpression('Random(10)');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekFuncParams,TParamsExpr));
AssertExpression('Name of function',P.Value,pekIdent,'Random');
AssertEquals('1 argument',1,Length(p.params));
AssertExpression('Simple identifier',p.params[0],pekNumber,'10');
end;
procedure TTestExpressions.TestFunctionCall2args;
Var
P : TParamsExpr;
begin
DeclareVar('integer','a');
ParseExpression('Random(10,12)');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekFuncParams,TParamsExpr));
AssertExpression('Name of function',P.Value,pekIdent,'Random');
AssertEquals('2 argument',2,Length(p.params));
AssertExpression('Simple identifier 1',p.params[0],pekNumber,'10');
AssertExpression('Simple identifier 2',p.params[1],pekNumber,'12');
end;
procedure TTestExpressions.TestFunctionCallNoArgs;
Var
P : TParamsExpr;
begin
DeclareVar('integer','a');
ParseExpression('Random()');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekFuncParams,TParamsExpr));
AssertExpression('Name of function',P.Value,pekIdent,'Random');
AssertEquals('0 arguments',0,Length(p.params));
end;
procedure TTestExpressions.TestRange;
Var
B : TBinaryExpr;
begin
DeclareVar('boolean','a');
DeclareVar('byte','b');
ParseExpression('b in 0..10');
AssertBinaryExpr('Simple binary In',eopIn,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekIdent,'b');
B:=TBinaryExpr(AssertExpression('Right is range',TheRight,pekRange,TBinaryExpr));
AssertExpression('Left is 0',B.Left,pekNumber,'0');
AssertExpression('Right is 10',B.Right,pekNumber,'10');
end;
procedure TTestExpressions.TestBracketsTotal;
begin
DeclareVar('integer','a');
ParseExpression('(3+4)');
AssertBinaryExpr('simple binary add',eopAdd,FLeft,FRight);
AssertExpression('Inner Left is 3',TheLeft,pekNumber,'3');
AssertExpression('Inner Right is 4',TheRight,pekNumber,'4');
end;
procedure TTestExpressions.TestBracketsLeft;
begin
DeclareVar('integer','a');
ParseExpression('2*(3+4)');
AssertRightPrecedence(2,eopMultiply,3,eopAdd,4);
end;
procedure TTestExpressions.TestBracketsRight;
begin
DeclareVar('integer','a');
ParseExpression('(2*3)+4');
AssertLeftPrecedence(2,eopMultiply,3,eopAdd,4);
end;
procedure TTestExpressions.TestPrecedenceLeftToRight;
begin
ParseExpression('1+2+3');
AssertLeftPrecedence(1,eopAdd,2,eopAdd,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightMinus;
begin
ParseExpression('1-2-3');
AssertLeftPrecedence(1,eopSubtract,2,eopSubtract,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightMultiply;
begin
ParseExpression('1*2*3');
AssertLeftPrecedence(1,eopMultiply,2,eopMultiply,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightDivision;
begin
ParseExpression('1/2/3');
AssertLeftPrecedence(1,eopDivide,2,eopDivide,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightPlusMinus;
begin
ParseExpression('1+2-3');
AssertLeftPrecedence(1,eopAdd,2,eopSubtract,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightMinusPlus;
begin
ParseExpression('1-2+3');
AssertLeftPrecedence(1,eopSubtract,2,eopAdd,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightMultiplyDivision;
begin
ParseExpression('1*2/3');
AssertLeftPrecedence(1,eopMultiply,2,eopDivide,3);
end;
procedure TTestExpressions.TestPrecedenceLeftToRightDivisionMultiply;
begin
ParseExpression('1/2*3');
AssertLeftPrecedence(1,eopDivide,2,eopMultiply,3);
end;
procedure TTestExpressions.TestPrecedencePlusMultiply;
begin
ParseExpression('1+2*3');
AssertRightPrecedence(1,eopAdd,2,eopMultiply,3);
end;
procedure TTestExpressions.TestPrecedencePlusDivide;
begin
ParseExpression('1+2/3');
AssertRightPrecedence(1,eopAdd,2,eopDivide,3);
end;
procedure TTestExpressions.TestPrecedenceMinusMultiply;
begin
ParseExpression('1-2*3');
AssertRightPrecedence(1,eopsubtract,2,eopMultiply,3);
end;
procedure TTestExpressions.TestPrecedenceMinusDivide;
begin
ParseExpression('1-2/3');
AssertRightPrecedence(1,eopsubtract,2,eopDivide,3);
end;
procedure TTestExpressions.TestPrecedencePlusOr;
begin
ParseExpression('1 or 2 + 3');
AssertLeftPrecedence(1,eopor,2,eopAdd,3);
end;
procedure TTestExpressions.TestPrecedenceAndOr;
begin
ParseExpression('1 or 2 and 3');
AssertRightPrecedence(1,eopor,2,eopAnd,3);
end;
procedure TTestExpressions.TestPrecedenceAndNot;
begin
ParseExpression('Not 1 and 3');
AssertBinaryExpr('Simple binary and',eopAnd,FLeft,FRight);
AssertExpression('Outer right is 3',TheRight,pekNumber,'3');
AssertUnaryExpr('Left is Unary not ',TheLeft,eopNot,FRight);
AssertExpression('Inner Right is 1',TheRight,pekNumber,'1');
end;
procedure TTestExpressions.TestPrecedencePlusAnd;
begin
ParseExpression('1 + 2 and 3');
AssertRightPrecedence(1,eopAdd,2,eopAnd,3);
end;
procedure TTestExpressions.TestPrecedenceMinusOr;
begin
ParseExpression('1 or 2 - 3');
AssertLeftPrecedence(1,eopOr,2,eopSubtract,3);
end;
procedure TTestExpressions.TestPrecedenceMinusAnd;
begin
ParseExpression('1 - 2 and 3');
AssertRightPrecedence(1,eopSubtract,2,eopand,3);
end;
procedure TTestExpressions.TestPrecedenceMultiplyOr;
begin
ParseExpression('1 or 2 * 3');
AssertRightPrecedence(1,eopOr,2,eopMultiply,3);
end;
procedure TTestExpressions.TestPrecedenceMultiplyAnd;
begin
ParseExpression('1 * 2 and 3');
AssertLeftPrecedence(1,eopMultiply,2,eopAnd,3);
end;
procedure TTestExpressions.TestPrecedencePlusDiv;
begin
ParseExpression('1+2 div 3');
AssertRightPrecedence(1,eopAdd,2,eopDiv,3);
end;
procedure TTestExpressions.TestPrecedencePlusMod;
begin
ParseExpression('1+2 mod 3');
AssertRightPrecedence(1,eopAdd,2,eopMod,3);
end;
procedure TTestExpressions.AssertLeftPrecedence(AInnerLeft : Integer; AInnerOp : TExprOpCode; AInnerRight : Integer; AOuterOp : TexprOpCode; AOuterRight: Integer);
begin
AssertBinaryExpr('Outer expression',AOuterOp,FLeft,FRight);
AssertExpression('Outer right constant',TheRight,pekNumber,intToStr(AOuterRight));
AssertBinaryExpr('Inner (left) expression',TheLeft,AInnerOp,FLeft,FRight);
AssertExpression('Inner Left constant',TheLeft,pekNumber,IntToStr(AInnerLeft));
AssertExpression('Inner Right constant',TheRight,pekNumber,IntToStr(AInnerRight));
end;
procedure TTestExpressions.AssertRightPrecedence(AOuterLeft : Integer; AOuterOp : TExprOpCode; AInnerLeft : Integer; AInnerOp : TexprOpCode; AInnerRight: Integer);
begin
AssertBinaryExpr('Outer expression',AOuterOp,FLeft,FRight);
AssertExpression('Outer left constant',TheLeft,pekNumber,intToStr(AOuterLeft));
AssertBinaryExpr('Inner (right) expression',TheRight,AInnerOp,FLeft,FRight);
AssertExpression('Inner Left constant',TheLeft,pekNumber,IntToStr(AInnerLeft));
AssertExpression('Inner Right constant',TheRight,pekNumber,IntToStr(AInnerRight));
end;
procedure TTestExpressions.TestPrecedenceMultiplyDiv;
begin
ParseExpression('1 * 2 div 3');
AssertLeftPrecedence(1,eopMultiply,2,eopDiv,3);
end;
procedure TTestExpressions.TestPrecedenceDivMultiply;
begin
ParseExpression('1 div 2 * 3');
AssertLeftPrecedence(1,eopDiv,2,eopMultiply,3);
end;
procedure TTestExpressions.TestUnaryMinus;
begin
DeclareVar('integer','a');
DeclareVar('integer','b');
ParseExpression('-b');
AssertUnaryExpr('Simple minus unary',eopSubtract,FLeft);
AssertExpression('Simple identifier',theLeft,pekIdent,'b');
end;
procedure TTestExpressions.TestUnaryMinusWhiteSpace;
begin
DeclareVar('integer','a');
DeclareVar('integer','b');
ParseExpression('- b');
AssertUnaryExpr('Simple minus unary',eopSubtract,FLeft);
AssertExpression('Simple identifier',theLeft,pekIdent,'b');
end;
procedure TTestExpressions.TestUnaryAddress;
begin
DeclareVar('integer','a');
DeclareVar('integer','b');
ParseExpression('@b');
AssertUnaryExpr('Simple address unary',eopAddress,FLeft);
AssertExpression('Simple identifier',theLeft,pekIdent,'b');
end;
procedure TTestExpressions.TestUnaryNot;
begin
DeclareVar('boolean','a');
DeclareVar('boolean','b');
ParseExpression('not b');
AssertUnaryExpr('Simple address unary',eopNot,FLeft);
AssertExpression('Simple identifier',theLeft,pekIdent,'b');
end;
procedure TTestExpressions.TestUnaryDeref;
begin
DeclareVar('integer','a');
DeclareVar('pinteger','b');
ParseExpression('b^');
AssertUnaryExpr('Simple address unary',eopDeref,FLeft);
AssertExpression('Simple identifier',theLeft,pekIdent,'b');
end;
procedure TTestExpressions.TestBinaryAdd;
begin
ParseExpression('1+2');
AssertBinaryExpr('Simple binary add',eopAdd,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinarySubtract;
begin
ParseExpression('1-2');
AssertBinaryExpr('Simple binary subtract',eopSubtract,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryMultiply;
begin
ParseExpression('1*2');
AssertBinaryExpr('Simple binary multiply',eopMultiply,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryDivision;
begin
DeclareVar('double');
ParseExpression('1/2');
AssertBinaryExpr('Simple binary division',eopDivide,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryPower;
begin
DeclareVar('double');
ParseExpression('1**2');
AssertBinaryExpr('Simple binary power',eopPower,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryMod;
begin
ParseExpression('1 mod 2');
AssertBinaryExpr('Simple binary mod',eopMod,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryDiv;
begin
ParseExpression('1 div 2');
AssertBinaryExpr('Simple binary div',eopDiv,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryShl;
begin
ParseExpression('1 shl 2');
AssertBinaryExpr('Simple binary shl',eopShl,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinaryShr;
begin
ParseExpression('1 shr 2');
AssertBinaryExpr('Simple binary shr',eopShr,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is 2',TheRight,pekNumber,'2');
end;
procedure TTestExpressions.TestBinarySymmetricalDifference;
begin
DeclareVar('Set of Byte','a');
DeclareVar('Set of Byte','b');
DeclareVar('Set of Byte','c');
ParseExpression('b >< c');
AssertBinaryExpr('Simple binary smmetrical difference',eopSymmetricalDifference,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryAnd;
begin
DeclareVar('boolean','a');
DeclareVar('boolean','b');
DeclareVar('boolean','b');
ParseExpression('b and c');
AssertBinaryExpr('Simple binary and',eopAnd,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekIdent,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryOr;
begin
DeclareVar('boolean','a');
DeclareVar('boolean','b');
DeclareVar('boolean','b');
ParseExpression('b or c');
AssertBinaryExpr('Simple binary or',eopOr,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekIdent,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryXOr;
begin
DeclareVar('boolean','a');
DeclareVar('boolean','b');
DeclareVar('boolean','b');
ParseExpression('b xor c');
AssertBinaryExpr('Simple binary xor',eopxOr,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekIdent,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryIn;
begin
DeclareVar('boolean','a');
ParseExpression('1 in [1,2,3]');
AssertBinaryExpr('Simple binary In',eopIn,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekNumber,'1');
AssertExpression('Right is array set',TheRight,pekSet,TParamsExpr);
end;
procedure TTestExpressions.TestBinaryIs;
begin
DeclareVar('boolean','a');
DeclareVar('TObject','b');
ParseExpression('b is TObject');
AssertBinaryExpr('Simple binary Is',eopIs,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekident,'b');
AssertExpression('Right is TObject',TheRight,pekIdent,'TObject');
end;
procedure TTestExpressions.TestBinaryAs;
begin
DeclareVar('TObject','a');
DeclareVar('TObject','b');
ParseExpression('b as TObject');
AssertBinaryExpr('Simple binary As',eopAs,FLeft,FRight);
AssertExpression('Left is 1',TheLeft,pekident,'b');
AssertExpression('Right is TObject',TheRight,pekIdent,'TObject');
end;
procedure TTestExpressions.TestBinaryEquals;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b=c');
AssertBinaryExpr('Simple binary equals',eopEqual,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryDiffers;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b<>c');
AssertBinaryExpr('Simple binary differs',eopNotEqual,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryLessThan;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b<c');
AssertBinaryExpr('Simple binary less than',eopLessThan,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryLessThanEqual;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b<=c');
AssertBinaryExpr('Simple binary less than or equal',eopLessThanEqual,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryLargerThan;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b>c');
AssertBinaryExpr('Simple binary larger than ',eopGreaterThan,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestBinaryLargerThanEqual;
begin
DeclareVar('boolean','a');
DeclareVar('integer','b');
DeclareVar('integer','c');
ParseExpression('b>=c');
AssertBinaryExpr('Simple binary larger than or equal',eopGreaterThanEqual,FLeft,FRight);
AssertExpression('Left is b',TheLeft,pekident,'b');
AssertExpression('Right is c',TheRight,pekIdent,'c');
end;
procedure TTestExpressions.TestPrimitiveBooleanFalse;
begin
DeclareVar('boolean','a');
ParseExpression('False');
AssertExpression('Simple boolean',theExpr,pekBoolConst,TBoolConstExpr);
AssertEquals('Boolean false',False,TBoolConstExpr(TheExpr).Value);
end;
procedure TTestExpressions.TestPrimitiveBooleanTrue;
begin
DeclareVar('boolean','a');
ParseExpression('True');
AssertExpression('Simple boolean',theExpr,pekBoolConst,TBoolConstExpr);
AssertEquals('Boolean true',True,TBoolConstExpr(TheExpr).Value);
end;
procedure TTestExpressions.TestPrimitiveNil;
begin
DeclareVar('pointer','a');
ParseExpression('Nil');
AssertExpression('Nil expr',theExpr,pekNil,TNilExpr);
end;
procedure TTestExpressions.TestPrimitiveSet;
Var
P : TParamsExpr;
begin
DeclareVar('set of byte','a');
ParseExpression('[1,2,3]');
P:=TParamsExpr(AssertExpression('Set expr',theExpr,pekSet,TParamsExpr));
AssertEquals('Element count',3,Length(P.Params));
AssertExpression('Element 1 in set',P.Params[0],pekNumber,'1');
AssertExpression('Element 2 in set',P.Params[1],pekNumber,'2');
AssertExpression('Element 3 in set',P.Params[2],pekNumber,'3');
end;
procedure TTestExpressions.TestPrimitiveChar;
begin
DeclareVar('char');
ParseExpression('#32');
AssertExpression('Simple string',theExpr,pekString,'#32');
end;
procedure TTestExpressions.TestPrimitiveControlChar;
begin
DeclareVar('char');
ParseExpression('^M');
AssertExpression('Simple string',theExpr,pekString,'^M');
end;
procedure TTestExpressions.TestPrimitiveSetEmpty;
Var
P : TParamsExpr;
begin
DeclareVar('set of byte','a');
ParseExpression('[]');
P:=TParamsExpr(AssertExpression('Set expr',theExpr,pekSet,TParamsExpr));
AssertEquals('Element count',0,Length(P.Params));
end;
procedure TTestExpressions.TestPrimitiveSelf;
Var
S : TSelfExpr;
begin
DeclareVar('pointer','a');
ParseExpression('Self');
S:=TSelfExpr(AssertExpression('Inherited expr',theExpr,pekSelf,TSelfExpr));
end;
procedure TTestExpressions.TestInherited;
Var
I: TInheritedExpr;
begin
DeclareVar('pointer','a');
ParseExpression('inherited');
I:=TInheritedExpr(AssertExpression('Inherited expr',theExpr,pekInherited,TInheritedExpr));
end;
procedure TTestExpressions.TestInheritedFunction;
Var
I: TInheritedExpr;
begin
DeclareVar('pointer','a');
ParseExpression('inherited myfunction');
AssertBinaryExpr('Inherited expr',eopNone,Fleft,FRight);
AssertExpression('Inherited expr',theleft,pekInherited,TInheritedExpr);
AssertExpression('Inherited expr',theright,pekIdent,'myfunction');
end;
procedure TTestExpressions.SetUp;
begin
Inherited;
FVariables:=TStringList.Create;
end;
procedure TTestExpressions.TearDown;
begin
FreeAndNil(FVariables);
Inherited;
end;
procedure TTestExpressions.SetExpression(const AExpression: String);
Var
I : Integer;
begin
StartProgram('afile');
if FVariables.Count=0 then
DeclareVar('integer');
Add('Var');
For I:=0 to FVariables.Count-1 do
Add(' '+Fvariables[I]);
Add('begin');
Add(' a:='+AExpression+';');
end;
procedure TTestExpressions.ParseExpression;
begin
ParseModule;
AssertEquals('Have program',TPasProgram,Module.ClassType);
AssertNotNull('Have program section',PasProgram.ProgramSection);
AssertNotNull('Have initialization section',PasProgram.InitializationSection);
AssertEquals('Have initialization statement',1,PasProgram.InitializationSection.Elements.Count);
AssertNotNull('Have initialization statement',PasProgram.InitializationSection.Elements[0]);
AssertEquals('Assignment statement',TPasImplAssign,TObject(PasProgram.InitializationSection.Elements[0]).ClassType);
FTheExpr:=TPasImplAssign(PasProgram.InitializationSection.Elements[0]).right;
AssertNotNull('Have assignment expression',FTheExpr);
end;
procedure TTestExpressions.ParseExpression(const AExpression: String);
begin
SetExpression(AExpression);
ParseExpression;
end;
function TTestExpressions.AssertBinaryExpr(const Msg: String; Op: TExprOpCode;
out ALeft, ARight: TPasExpr): TBinaryExpr;
begin
Result:=AssertBinaryExpr(Msg,TheExpr,Op,ALeft,ARight);
end;
function TTestExpressions.AssertBinaryExpr(const Msg: String; AExpr: TPasExpr;
Op: TExprOpCode; out ALeft, ARight: TPasExpr): TBinaryExpr;
begin
AssertExpression(Msg+' is binary',AExpr,pekBinary,TBinaryExpr);
Result:=AExpr as TBinaryExpr;
AssertEquals(Msg+' opcode OK',Op,Result.OpCode);
ALeft:=Result.Left;
ARight:=Result.Right;
AssertNotNull('Have left',ALeft);
AssertNotNull('Have right',ARight);
end;
function TTestExpressions.AssertUnaryExpr(const Msg: String; Op: TExprOpCode;
out AOperand : TPasExpr): TUnaryExpr;
begin
Result:=AssertUnaryExpr(Msg,TheExpr,OP,AOperand);
end;
function TTestExpressions.AssertUnaryExpr(const Msg: String; AExpr: TPasExpr;
Op: TExprOpCode; out AOperand: TPasExpr): TUnaryExpr;
begin
AssertExpression(Msg+' is unary',AExpr,pekUnary,TUnaryExpr);
Result:=AExpr as TUnaryExpr;
AssertEquals(Msg+' opcode OK',Op,Result.OpCode);
AOperand:=Result.Operand;
AssertNotNull('Have left',AOperand);
end;
initialization
RegisterTest(TTestExpressions);
end.

2
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -663,7 +663,7 @@ end;
procedure TTestScanner.TestAssignDivision;
begin
TestTokens([tkDivision,tkEqual],'*=');
TestTokens([tkDivision,tkEqual],'/=');
FScanner.Options:=[po_cassignments];
TestToken(tkAssignDivision,'/=');
end;

2
packages/fcl-passrc/tests/tcstatements.pas
View File

@ -144,7 +144,7 @@ begin
ParseModule;
AssertEquals('Have program',TPasProgram,Module.ClassType);
AssertNotNull('Have program section',PasProgram.ProgramSection);
AssertNotNull('Have program section',PasProgram.InitializationSection);
AssertNotNull('Have initialization section',PasProgram.InitializationSection);
if (PasProgram.InitializationSection.Elements.Count>0) then
if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
FStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);

7
packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -37,7 +37,7 @@
<PackageName Value="FCL"/>
</Item2>
</RequiredPackages>
<Units Count="9">
<Units Count="10">
<Unit0>
<Filename Value="testpassrc.lpr"/>
<IsPartOfProject Value="True"/>
@ -83,6 +83,11 @@
<IsPartOfProject Value="True"/>
<UnitName Value="tcclasstype"/>
</Unit8>
<Unit9>
<Filename Value="tcexprparser.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="tcexprparser"/>
</Unit9>
</Units>
</ProjectOptions>
<CompilerOptions>

2
packages/fcl-passrc/tests/testpassrc.lpr
View File

@ -5,7 +5,7 @@ program testpassrc;
uses
Classes, consoletestrunner, tcscanner,
tctypeparser, tcstatements, tcbaseparser,
tcmoduleparser, tconstparser, tcvarparser, tcclasstype;
tcmoduleparser, tconstparser, tcvarparser, tcclasstype, tcexprparser;
type