/packages/fcl-passrc/tests/tctypeparser.pas
Pascal | 2839 lines | 2411 code | 413 blank | 15 comment | 16 complexity | a1f7e5d4fb1b8933d72bf741719ace76 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
- unit tctypeparser;
- {$mode objfpc}{$H+}
- interface
- uses
- Classes, SysUtils, fpcunit, pastree, pscanner, pparser,
- tcbaseparser, testregistry;
- type
- { TBaseTestTypeParser }
- TBaseTestTypeParser= Class(TTestParser)
- private
- FType : TPasType;
- FHint : string;
- FErrorSource : String;
- Protected
- Function ParseType(ASource : String; ATypeClass : TClass;Const AHint : String = '') : TPasType; virtual; overload;
- Procedure AssertParseTypeError(ASource : String);
- Property TheType : TPasType Read FType;
- Property Hint : string Read FHint Write FHint;
- procedure SetUp; override;
- Procedure TearDown; override;
- end;
- { TTestTypeParser }
- TTestTypeParser = Class(TBaseTestTypeParser)
- private
- Protected
- Procedure DoTestAliasType(Const AnAliasType : String; Const AHint : String);
- procedure DoTestStringType(const AnAliasType: String; const AHint: String);
- procedure DoTypeError(Const AMsg,ASource : string);
- Procedure DoParseError;
- Procedure DoParsePointer(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
- Procedure DoParseArray(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
- Procedure DoParseEnumerated(Const ASource : String; Const AHint : String; ACount : integer);
- Procedure DoTestFileType(Const AType : String; Const AHint : String; ADestType : TClass = Nil);
- Procedure DoTestRangeType(Const AStart,AStop,AHint : String);
- Procedure DoParseSimpleSet(Const ASource : String; Const AHint : String);
- Procedure DoParseComplexSet(Const ASource : String; Const AHint : String);
- procedure DoParseRangeSet(const ASource: String; const AHint: String);
- Procedure DoTestComplexSet;
- Procedure DoTestClassOf(Const AHint : string);
- Published
- Procedure TestAliasType;
- Procedure TestCrossUnitAliasType;
- Procedure TestAliasTypeDeprecated;
- Procedure TestAliasTypePlatform;
- Procedure TestSimpleTypeByte;
- Procedure TestSimpleTypeByteDeprecated;
- Procedure TestSimpleTypeBytePlatform;
- Procedure TestSimpleTypeBoolean;
- Procedure TestSimpleTypeBooleanDeprecated;
- Procedure TestSimpleTypeBooleanPlatform;
- Procedure TestSimpleTypeChar;
- Procedure TestSimpleTypeCharDeprecated;
- Procedure TestSimpleTypeCharPlatform;
- Procedure TestSimpleTypeInteger;
- Procedure TestSimpleTypeIntegerDeprecated;
- Procedure TestSimpleTypeIntegerPlatform;
- Procedure TestSimpleTypeInt64;
- Procedure TestSimpleTypeInt64Deprecated;
- Procedure TestSimpleTypeInt64Platform;
- Procedure TestSimpleTypeLongInt;
- Procedure TestSimpleTypeLongIntDeprecated;
- Procedure TestSimpleTypeLongIntPlatform;
- Procedure TestSimpleTypeLongWord;
- Procedure TestSimpleTypeLongWordDeprecated;
- Procedure TestSimpleTypeLongWordPlatform;
- Procedure TestSimpleTypeDouble;
- Procedure TestSimpleTypeDoubleDeprecated;
- Procedure TestSimpleTypeDoublePlatform;
- Procedure TestSimpleTypeShortInt;
- Procedure TestSimpleTypeShortIntDeprecated;
- Procedure TestSimpleTypeShortIntPlatform;
- Procedure TestSimpleTypeSmallInt;
- Procedure TestSimpleTypeSmallIntDeprecated;
- Procedure TestSimpleTypeSmallIntPlatform;
- Procedure TestSimpleTypeString;
- Procedure TestSimpleTypeStringDeprecated;
- Procedure TestSimpleTypeStringPlatform;
- Procedure TestSimpleTypeStringSize;
- Procedure TestSimpleTypeStringSizeIncomplete;
- Procedure TestSimpleTypeStringSizeWrong;
- Procedure TestSimpleTypeStringSizeDeprecated;
- Procedure TestSimpleTypeStringSizePlatform;
- Procedure TestSimpleTypeWord;
- Procedure TestSimpleTypeWordDeprecated;
- Procedure TestSimpleTypeWordPlatform;
- Procedure TestSimpleTypeQWord;
- Procedure TestSimpleTypeQWordDeprecated;
- Procedure TestSimpleTypeQWordPlatform;
- Procedure TestSimpleTypeCardinal;
- Procedure TestSimpleTypeCardinalDeprecated;
- Procedure TestSimpleTypeCardinalPlatform;
- Procedure TestSimpleTypeWideChar;
- Procedure TestSimpleTypeWideCharDeprecated;
- Procedure TestSimpleTypeWideCharPlatform;
- Procedure TestPointerSimple;
- procedure TestPointerSimpleDeprecated;
- procedure TestPointerSimplePlatform;
- Procedure TestStaticArray;
- procedure TestStaticArrayDeprecated;
- procedure TestStaticArrayPlatform;
- Procedure TestStaticArrayPacked;
- Procedure TestStaticArrayTypedIndex;
- Procedure TestDynamicArray;
- Procedure TestSimpleEnumerated;
- Procedure TestSimpleEnumeratedDeprecated;
- Procedure TestSimpleEnumeratedPlatform;
- Procedure TestAssignedEnumerated;
- Procedure TestAssignedEnumeratedDeprecated;
- Procedure TestAssignedEnumeratedPlatform;
- Procedure TestFileType;
- Procedure TestFileTypeDeprecated;
- Procedure TestFileTypePlatform;
- Procedure TestRangeType;
- Procedure TestRangeTypeDeprecated;
- Procedure TestRangeTypePlatform;
- Procedure TestIdentifierRangeType;
- Procedure TestIdentifierRangeTypeDeprecated;
- Procedure TestIdentifierRangeTypePlatform;
- Procedure TestNegativeIdentifierRangeType;
- Procedure TestSimpleSet;
- Procedure TestSimpleSetDeprecated;
- Procedure TestSimpleSetPlatform;
- Procedure TestComplexSet;
- Procedure TestComplexSetDeprecated;
- Procedure TestComplexSetPlatform;
- Procedure TestRangeSet;
- Procedure TestRangeSetDeprecated;
- Procedure TestRangeSetPlatform;
- Procedure TestClassOf;
- Procedure TestClassOfDeprecated;
- Procedure TestClassOfPlatform;
- Procedure TestReferenceAlias;
- Procedure TestReferenceSet;
- Procedure TestReferenceClassOf;
- Procedure TestReferenceFile;
- Procedure TestReferenceArray;
- Procedure TestReferencePointer;
- end;
- { TTestRecordTypeParser }
- TTestRecordTypeParser= Class(TBaseTestTypeParser)
- private
- Function GetField(AIndex : Integer; R : TPasRecordType) : TPasVariable;
- Function GetField(AIndex : Integer; R : TPasVariant) : TPasVariable;
- function GetF(AIndex: Integer): TPasVariable;
- function GetR: TPasRecordType;
- Function GetVariant(AIndex : Integer; R : TPasRecordType) : TPasVariant;
- function GetV(AIndex: Integer): TPasVariant;
- Protected
- Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
- procedure AssertVariantSelector(AName, AType: string);
- procedure AssertField1(Hints: TPasMemberHints);
- procedure AssertField2(Hints: TPasMemberHints);
- procedure AssertVariant1(Hints: TPasMemberHints);
- procedure AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
- procedure AssertVariant2(Hints: TPasMemberHints);
- procedure AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
- procedure AssertOneIntegerField(Hints: TPasMemberHints);
- procedure AssertTwoIntegerFields(Hints1, Hints2: TPasMemberHints);
- procedure AssertRecordField(AIndex: Integer;Hints: TPasMemberHints);
- procedure AssertRecordVariant(AIndex: Integer;Hints: TPasMemberHints; VariantLabels : Array of string);
- Procedure AssertRecordVariantVariant(AIndex: Integer;Const AFieldName,ATypeName: string;Hints: TPasMemberHints; VariantLabels : Array of string);
- Procedure DoTestEmpty(Const AHint : String);
- procedure DoTestDeprecatedVariantNoStorage(Const AHint : string);
- procedure DoTestDeprecatedVariantStorage(Const AHint : string);
- procedure DoTestVariantNoStorage(Const AHint : string);
- procedure DoTestVariantStorage(Const AHint : string);
- procedure DoTestTwoVariantsNoStorage(Const AHint : string);
- procedure DoTestTwoVariantsStorage(Const AHint : string);
- procedure DoTestTwoVariantsFirstDeprecatedStorage(Const AHint : string);
- procedure DoTestTwoVariantsSecondDeprecatedStorage(Const AHint : string);
- Procedure DoTestVariantTwoLabels(Const AHint : string);
- Procedure DoTestTwoVariantsTwoLabels(Const AHint : string);
- procedure DoTestVariantNestedRecord(Const AHint : string);
- procedure DoTestVariantNestedVariant(Const AHint : string);
- procedure DoTestVariantNestedVariantFirstDeprecated(Const AHint : string);
- procedure DoTestVariantNestedVariantSecondDeprecated(const AHint: string);
- procedure DoTestVariantNestedVariantBothDeprecated(const AHint: string);
- Property TheRecord : TPasRecordType Read GetR;
- Property Field1 : TPasVariable Index 0 Read GetF;
- Property Field2 : TPasVariable Index 1 Read GetF;
- Property Variant1 : TPasVariant Index 0 Read GetV;
- Property Variant2 : TPasVariant Index 1 Read GetV;
- Published
- Procedure TestEmpty;
- Procedure TestEmptyDeprecated;
- Procedure TestEmptyPlatform;
- Procedure TestOneField;
- Procedure TestOneFieldDeprecated;
- Procedure TestOneFieldPlatform;
- Procedure TestOneFieldSemicolon;
- Procedure TestOneFieldSemicolonDeprecated;
- Procedure TestOneFieldSemicolonPlatform;
- Procedure TestOneDeprecatedField;
- Procedure TestOneDeprecatedFieldDeprecated;
- Procedure TestOneDeprecatedFieldPlatform;
- Procedure TestOnePlatformField;
- Procedure TestOnePlatformFieldDeprecated;
- Procedure TestOnePlatformFieldPlatform;
- Procedure TestTwoFields;
- Procedure TestTwoFieldDeprecated;
- Procedure TestTwoFieldPlatform;
- Procedure TestTwoFieldsFirstDeprecated;
- Procedure TestTwoFieldsFirstDeprecatedDeprecated;
- Procedure TestTwoFieldsFirstDeprecatedPlatform;
- Procedure TestTwoFieldsSecondDeprecated;
- Procedure TestTwoFieldsSecondDeprecatedDeprecated;
- Procedure TestTwoFieldsSecondDeprecatedPlatform;
- Procedure TestTwoFieldsBothDeprecated;
- Procedure TestTwoFieldsBothDeprecatedDeprecated;
- Procedure TestTwoFieldsBothDeprecatedPlatform;
- Procedure TestTwoFieldsCombined;
- Procedure TestTwoFieldsCombinedDeprecated;
- Procedure TestTwoFieldsCombinedPlatform;
- Procedure TestTwoDeprecatedFieldsCombined;
- Procedure TestTwoDeprecatedFieldsCombinedDeprecated;
- Procedure TestTwoDeprecatedFieldsCombinedPlatform;
- Procedure TestNested;
- Procedure TestNestedDeprecated;
- Procedure TestNestedPlatform;
- procedure TestNestedSemicolon;
- procedure TestNestedSemicolonDeprecated;
- procedure TestNestedSemicolonPlatform;
- procedure TestNestedFirst;
- procedure TestNestedFirstDeprecated;
- procedure TestNestedFirstPlatform;
- Procedure TestDeprecatedNested;
- Procedure TestDeprecatedNestedDeprecated;
- Procedure TestDeprecatedNestedPlatform;
- procedure TestDeprecatedNestedFirst;
- procedure TestDeprecatedNestedFirstDeprecated;
- procedure TestDeprecatedNestedFirstPlatform;
- Procedure TestVariantNoStorage;
- procedure TestVariantNoStorageDeprecated;
- procedure TestVariantNoStoragePlatform;
- Procedure TestVariantStorage;
- procedure TestVariantStorageDeprecated;
- procedure TestVariantStoragePlatform;
- Procedure TestDeprecatedVariantNoStorage;
- procedure TestDeprecatedVariantNoStorageDeprecated;
- procedure TestDeprecatedVariantNoStoragePlatform;
- Procedure TestDeprecatedVariantStorage;
- procedure TestDeprecatedVariantStorageDeprecated;
- procedure TestDeprecatedVariantStoragePlatform;
- Procedure TestTwoVariantsNoStorage;
- procedure TestTwoVariantsNoStorageDeprecated;
- procedure TestTwoVariantsNoStoragePlatform;
- Procedure TestTwoVariantsStorage;
- procedure TestTwoVariantsStorageDeprecated;
- procedure TestTwoVariantsStoragePlatform;
- Procedure TestTwoVariantsFirstDeprecatedStorage;
- procedure TestTwoVariantsFirstDeprecatedStorageDeprecated;
- procedure TestTwoVariantsFirstDeprecatedStoragePlatform;
- Procedure TestTwoVariantsSecondDeprecatedStorage;
- procedure TestTwoVariantsSecondDeprecatedStorageDeprecated;
- procedure TestTwoVariantsSecondDeprecatedStoragePlatform;
- Procedure TestVariantTwoLabels;
- Procedure TestVariantTwoLabelsDeprecated;
- Procedure TestVariantTwoLabelsPlatform;
- Procedure TestTwoVariantsTwoLabels;
- Procedure TestTwoVariantsTwoLabelsDeprecated;
- Procedure TestTwoVariantsTwoLabelsPlatform;
- Procedure TestVariantNestedRecord;
- Procedure TestVariantNestedRecordDeprecated;
- Procedure TestVariantNestedRecordPlatform;
- Procedure TestVariantNestedVariant;
- Procedure TestVariantNestedVariantDeprecated;
- Procedure TestVariantNestedVariantPlatForm;
- Procedure TestVariantNestedVariantFirstDeprecated;
- Procedure TestVariantNestedVariantFirstDeprecatedDeprecated;
- Procedure TestVariantNestedVariantFirstDeprecatedPlatform;
- Procedure TestVariantNestedVariantSecondDeprecated;
- Procedure TestVariantNestedVariantSecondDeprecatedDeprecated;
- Procedure TestVariantNestedVariantSecondDeprecatedPlatform;
- Procedure TestVariantNestedVariantBothDeprecated;
- Procedure TestVariantNestedVariantBothDeprecatedDeprecated;
- Procedure TestVariantNestedVariantBothDeprecatedPlatform;
- end;
- { TTestProcedureTypeParser }
- TCallingConventionTest = Procedure (CC : TCallingConvention;Const AHint : String) of object;
- TTestProcedureTypeParser = Class(TBaseTestTypeParser)
- Private
- FProc : TPasProcedureType;
- procedure CheckArrayOfConstArgument(Aindex: Integer; Ac: TArgumentAccess);
- Protected
- procedure DoTestFunction(CC: TCallingConvention; const AHint: String);
- procedure DoTestFunctionOfObject(CC: TCallingConvention; const AHint: String);
- procedure DoTestFunctionOneArg(CC: TCallingConvention; const AHint: String);
- procedure DoTestFunctionOneArgOfObject(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOfObject(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOfObjectOneArg(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureIsNested(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureIsNestedOneArg(CC: TCallingConvention; const AHint: String);
- procedure CheckOpenArrayArgument(Ac: TArgumentAccess);
- procedure DoTestProcedureArrayOfConst(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOpenArray(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureConstOpenArray(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureVarOpenArray(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOutOpenArray(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOneArgDefault(CC: TCallingConvention;const AHint: String);
- procedure DoTestProcedureOneArgDefaultExpr(CC: TCallingConvention;const AHint: String);
- procedure DoTestProcedureOneArgDefaultSet(CC: TCallingConvention;const AHint: String);
- procedure DoTestProcedureOneConstArgDefault(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOneVarArgDefault(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureOneOutArgDefault(CC: TCallingConvention; const AHint: String);
- function CheckArgument(AIndex : Integer; Const AName,ATypeName : String; AAccess : TArgumentAccess) : TPasArgument;
- Function ParseType(ASource : String; CC : TCallingConvention; ATypeClass : TClass;Const AHint : String = '') : TPasProcedureType; virtual; overload;
- Procedure DoTestProcedureDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureOneArgDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureOneVarArgDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureOneConstArgDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureOneOutArgDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoVarArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoConstArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoOutArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoCombinedArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoCombinedVarArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoCombinedConstArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureTwoCombinedOutArgsDecl(CC : TCallingConvention; Const AHint : String);
- Procedure DoTestProcedureDefaultConstArgsDecl(CC : TCallingConvention; Const AHint : String);
- procedure DoTestProcedureUntypedArgDecl(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureUntypedConstArgDecl(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureUntypedOutArgDecl(CC: TCallingConvention; const AHint: String);
- procedure DoTestProcedureUntypedDefArg;
- Procedure TestCallingConventions(Proc : TCallingConventionTest; Const AHint : String);
- Procedure TestCallingConventions(Proc : TCallingConventionTest);
- Function FuncProc : TPasFunctionType;
- Property Proc : TPasProcedureType Read FProc;
- Published
- Procedure TestProcedure;
- Procedure TestProcedureOneArg;
- Procedure TestProcedureOneVarArg;
- Procedure TestProcedureOneConstArg;
- Procedure TestProcedureOneOutArg;
- Procedure TestProcedureTwoArgs;
- Procedure TestProcedureTwoVarArgs;
- Procedure TestProcedureTwoConstArgs;
- Procedure TestProcedureTwoOutArgs;
- Procedure TestProcedureTwoCombinedArgs;
- Procedure TestProcedureTwoCombinedVarArgs;
- Procedure TestProcedureTwoCombinedConstArgs;
- Procedure TestProcedureTwoCombinedOutArgs;
- Procedure TestProcedureDefaultConstArgs;
- Procedure TestProcedureUntypedArg;
- Procedure TestProcedureUntypedConstArg;
- Procedure TestProcedureUntypedOutArg;
- Procedure TestProcedureUntypedDefArg;
- Procedure TestProcedureOneArgDefault;
- Procedure TestProcedureOneArgDefaultExpr;
- Procedure TestProcedureOneArgDefaultSet;
- Procedure TestProcedureOneVarArgDefault;
- Procedure TestProcedureOneConstArgDefault;
- Procedure TestProcedureOneOutArgDefault;
- Procedure TestProcedureNoMultiArgDefaults;
- Procedure TestProcedureOpenArray;
- Procedure TestProcedureConstOpenArray;
- Procedure TestProcedureOutOpenArray;
- Procedure TestProcedureVarOpenArray;
- Procedure TestProcedureArrayOfConst;
- Procedure TestProcedureOfObject;
- Procedure TestProcedureOfObjectOneArg;
- Procedure TestProcedureIsNested;
- Procedure TestProcedureIsNesteOneArg;
- Procedure TestFunction;
- Procedure TestFunctionOneArg;
- Procedure TestFunctionOfObject;
- Procedure TestFunctionOneArgOfObject;
- end;
- implementation
- uses typinfo;
- { TTestProcedureTypeParser }
- procedure TTestProcedureTypeParser.DoTestProcedureUntypedArgDecl(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(var A)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','',argVar);
- AssertNull('No argument type', A.ArgType)
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureUntypedConstArgDecl(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(const A)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','',argConst);
- AssertNull('No argument type', A.ArgType)
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureUntypedOutArgDecl(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(out A)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','',argOut);
- AssertNull('No argument type', A.ArgType)
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureUntypedDefArg;
- begin
- ParseType('procedure(A)',ccdefault,TPasProcedureType,'');
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDefault(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(var A : Integer = 1)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','Integer',argVar);
- AssertNotNull('have default argument type', A.Value);
- AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
- AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDefault(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(out A : Integer = 1)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','Integer',argOut);
- AssertNotNull('have default argument type', A.Value);
- AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
- AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDefault(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(const A : Integer = 1)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','Integer',argConst);
- AssertNotNull('have default argument type', A.Value);
- AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
- AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureArrayOfConst(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A : Array of const)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArrayOfConstArgument(0,argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOfObject(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure of Object',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',0,Proc.Args.Count);
- AssertEquals('Is OF Object',True,Proc.IsOfObject);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOfObjectOneArg(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure (A : integer)of Object',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- AssertEquals('Is OF Object',True,Proc.IsOfObject);
- CheckArgument(0,'A','Integer',argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureIsNested(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure is nested',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',0,Proc.Args.Count);
- AssertEquals('Is nested',True,Proc.IsNested);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureIsNestedOneArg(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure (A : integer) is nested',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- AssertEquals('Is nested',True,Proc.IsNested);
- CheckArgument(0,'A','Integer',argDefault);
- end;
- procedure TTestProcedureTypeParser.CheckArrayOfConstArgument(Aindex : Integer; Ac : TArgumentAccess);
- Var
- A : TPasArgument;
- T : TPasArrayType;
- begin
- A:=CheckArgument(Aindex,'A','',ac);
- AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
- T:=A.ArgType as TPasArrayType;
- AssertNull('Have Element type',T.ElType);
- end;
- procedure TTestProcedureTypeParser.DoTestFunction(CC: TCallingConvention;
- const AHint: String);
- begin
- ParseType('function : integer',CC,TPasFunctionType,AHint);
- AssertEquals('Argument count',0,Proc.Args.Count);
- AssertEquals('Is OF Object',False,Proc.IsOfObject);
- AssertNotNull('Have result',FuncProc.ResultEl);
- AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
- AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
- AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
- AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
- end;
- procedure TTestProcedureTypeParser.DoTestFunctionOfObject(CC: TCallingConvention;
- const AHint: String);
- begin
- ParseType('function : integer of object',CC,TPasFunctionType,AHint);
- AssertEquals('Argument count',0,Proc.Args.Count);
- AssertEquals('Is OF Object',True,Proc.IsOfObject);
- AssertNotNull('Have result',FuncProc.ResultEl);
- AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
- AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
- AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
- AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
- end;
- procedure TTestProcedureTypeParser.DoTestFunctionOneArg(CC: TCallingConvention;
- const AHint: String);
- begin
- ParseType('function (A : Integer) : Integer',CC,TPasFunctionType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argDefault);
- AssertNotNull('Have result',FuncProc.ResultEl);
- AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
- AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
- AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
- AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
- end;
- procedure TTestProcedureTypeParser.DoTestFunctionOneArgOfObject(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('function (A : Integer) : Integer of object',CC,TPasFunctionType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- AssertEquals('Is OF Object',True,Proc.IsOfObject);
- CheckArgument(0,'A','Integer',argDefault);
- AssertNotNull('Have result',FuncProc.ResultEl);
- AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
- AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
- AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
- AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
- end;
- procedure TTestProcedureTypeParser.CheckOpenArrayArgument(Ac : TArgumentAccess);
- Var
- A : TPasArgument;
- T : TPasArrayType;
- begin
- A:=CheckArgument(0,'A','',ac);
- AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
- T:=A.ArgType as TPasArrayType;
- AssertNotNull('Have Element type',T.ElType);
- AssertEquals('Element type',TPasUnresolvedTypeRef,T.ElType.ClassType);
- AssertEquals('Element type name','Integer',TPasUnresolvedTypeRef(T.ElType).Name);
- AssertEquals('No boundaries','',T.IndexRange);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOpenArray(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A : Array of integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckOpenArrayArgument(argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureConstOpenArray(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(const A : Array of integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckOpenArrayArgument(argConst);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureVarOpenArray(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(var A : Array of integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckOpenArrayArgument(argVar);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOutOpenArray(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(out A : Array of integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckOpenArrayArgument(argOut);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefault(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- begin
- ParseType('procedure(A : Integer = 1)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','Integer',argDefault);
- AssertNotNull('have default argument type', A.ValueExpr);
- AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
- AssertEquals('argument expr value', '1', TPrimitiveExpr(A.ValueExpr).Value);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultExpr(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- B : TBinaryExpr;
- begin
- ParseType('procedure(A : Integer = 1+2)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','Integer',argDefault);
- AssertNotNull('have default argument type', A.ValueExpr);
- AssertEquals('argument expr type', TBinaryExpr, A.ValueExpr.ClassType);
- B:=TBinaryExpr(A.ValueExpr);
- AssertNotNull('have left expr', B.Left);
- AssertEquals('argument left expr type', TPrimitiveExpr, B.left.ClassType);
- AssertEquals('argument left expr value', '1', TPrimitiveExpr(B.Left).Value);
- AssertNotNull('have right expr', B.Right);
- AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType);
- AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet(
- CC: TCallingConvention; const AHint: String);
- Var
- A : TPasArgument;
- B : TParamsExpr;
- begin
- ParseType('procedure(A : TB = [])',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- A:=CheckArgument(0,'A','TB',argDefault);
- AssertNotNull('have default argument type', A.ValueExpr);
- AssertEquals('argument expr type', TParamsExpr, A.ValueExpr.ClassType);
- B:=TParamsExpr(A.ValueExpr);
- AssertEquals('No params',0,Length(B.Params));
- end;
- Function TTestProcedureTypeParser.CheckArgument(AIndex: Integer; const AName,
- ATypeName: String; AAccess: TArgumentAccess) : TPAsArgument;
- Var
- A : TPasArgument;
- C : String;
- begin
- C:='Argument '+IntToStr(AIndex)+' : ';
- AssertNotNull(C+'assigned',Proc.Args[AIndex]);
- AssertEquals(C+'class',TPasArgument,TObject(Proc.Args[AIndex]).ClassType);
- A:=TPasArgument(Proc.Args[AIndex]);
- AssertEquals(C+'Access',AAccess,A.Access);
- AssertEquals(C+'name',AName,A.Name);
- if (ATypeName<>'') then
- begin
- AssertNotNull(C+'type assigned',A.ArgType);
- if (ATypeName[1]='[') then
- AssertEquals(C+'type classname',LowerCase(Copy(ATypeName,2,Length(ATypeName)-2)),LowerCase(A.ArgType.ClassName))
- else
- AssertEquals(C+'type name',ATypeName,A.ArgType.Name);
- end;
- Result:=A;
- end;
- function TTestProcedureTypeParser.ParseType(ASource: String;
- CC: TCallingConvention; ATypeClass: TClass; const AHint: String): TPasProcedureType;
- begin
- if CC=ccdefault then
- Result:=TPasProcedureType(ParseType(ASource,ATypeClass,AHint))
- else
- begin
- if (AHint<>'') then
- Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC]+';',ATypeClass,AHint))
- else
- Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC],ATypeClass,AHint));
- end;
- FProc:=Result;
- AssertEquals('Correct calling convention for procedural type',cc,Result.CallingConvention);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureDecl(CC: TCallingConvention; Const AHint : String);
- begin
- ParseType('procedure',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',0,Proc.Args.Count);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneArgDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(var A : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argVar);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(const A : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argConst);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(out A : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',1,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argOut);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A : Integer;B : String)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argDefault);
- CheckArgument(1,'B','[TPasAliasType]',argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoVarArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(Var A : Integer;Var B : String)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argVar);
- CheckArgument(1,'B','[TPasAliasType]',argVar);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoConstArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(const A : Integer;Const B : String)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argConst);
- CheckArgument(1,'B','[TPasAliasType]',argConst);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoOutArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(out A : Integer;Out B : String)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argOut);
- CheckArgument(1,'B','[TPasAliasType]',argOut);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A,B : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argDefault);
- CheckArgument(1,'B','Integer',argDefault);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedVarArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(Var A,B : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argVar);
- CheckArgument(1,'B','Integer',argVar);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedConstArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(Const A,B : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argConst);
- CheckArgument(1,'B','Integer',argConst);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedOutArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(Out A,B : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argOut);
- CheckArgument(1,'B','Integer',argOut);
- end;
- procedure TTestProcedureTypeParser.DoTestProcedureDefaultConstArgsDecl(
- CC: TCallingConvention; const AHint: String);
- begin
- ParseType('procedure(A : Integer; Const B : Integer)',CC,TPasProcedureType,AHint);
- AssertEquals('Argument count',2,Proc.Args.Count);
- CheckArgument(0,'A','Integer',argDefault);
- CheckArgument(1,'B','Integer',argConst);
- end;
- procedure TTestProcedureTypeParser.TestCallingConventions(
- Proc: TCallingConventionTest; Const AHint : String);
- Var
- CC : TCallingConvention;
- begin
- For cc:=ccDefault to High(TCallingConvention) do
- begin
- if CC<>ccDefault then
- Setup;
- try
- Proc(cc,AHint);
- finally
- tearDown;
- end;
- end;
- end;
- procedure TTestProcedureTypeParser.TestCallingConventions(
- Proc: TCallingConventionTest);
- begin
- TestCallingConventions(Proc,'');
- Setup;
- TestCallingConventions(Proc,'deprecated');
- Setup;
- TestCallingConventions(Proc,'platform');
- end;
- function TTestProcedureTypeParser.FuncProc: TPasFunctionType;
- begin
- Result:=Proc as TPasFunctionType;
- end;
- procedure TTestProcedureTypeParser.TestProcedure;
- begin
- TestCallingConventions(@DoTestProcedureDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneArg;
- begin
- TestCallingConventions(@DoTestProcedureOneArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneVarArg;
- begin
- TestCallingConventions(@DoTestProcedureOneVarArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneConstArg;
- begin
- TestCallingConventions(@DoTestProcedureOneConstArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneOutArg;
- begin
- TestCallingConventions(@DoTestProcedureOneOutArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoVarArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoVarArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoConstArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoConstArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoOutArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoOutArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoCombinedArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoCombinedArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoCombinedVarArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoCombinedVarArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoCombinedConstArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoCombinedConstArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureTwoCombinedOutArgs;
- begin
- TestCallingConventions(@DoTestProcedureTwoCombinedOutArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureDefaultConstArgs;
- begin
- TestCallingConventions(@DoTestProcedureDefaultConstArgsDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureUntypedArg;
- begin
- TestCallingConventions(@DoTestProcedureUntypedArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureUntypedConstArg;
- begin
- TestCallingConventions(@DoTestProcedureUntypedConstArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureUntypedOutArg;
- begin
- TestCallingConventions(@DoTestProcedureUntypedOutArgDecl);
- end;
- procedure TTestProcedureTypeParser.TestProcedureUntypedDefArg;
- begin
- AssertException('No untyped arg by value',EParserError,@DoTestProcedureUntypedDefArg)
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneArgDefault;
- begin
- TestCallingConventions(@DoTestProcedureOneArgDefault);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultExpr;
- begin
- TestCallingConventions(@DoTestProcedureOneArgDefaultExpr);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultSet;
- begin
- TestCallingConventions(@DoTestProcedureOneArgDefaultSet);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneVarArgDefault;
- begin
- TestCallingConventions(@DoTestProcedureOneVarArgDefault);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneConstArgDefault;
- begin
- TestCallingConventions(@DoTestProcedureOneConstArgDefault);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOneOutArgDefault;
- begin
- TestCallingConventions(@DoTestProcedureOneOutArgDefault);
- end;
- procedure TTestProcedureTypeParser.TestProcedureNoMultiArgDefaults;
- begin
- AssertParseTypeError('procedure (A,B : Integer = 1)');
- end;
- procedure TTestProcedureTypeParser.TestProcedureOpenArray;
- begin
- TestCallingConventions(@DoTestProcedureOpenArray);
- end;
- procedure TTestProcedureTypeParser.TestProcedureConstOpenArray;
- begin
- TestCallingConventions(@DoTestProcedureConstOpenArray);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOutOpenArray;
- begin
- TestCallingConventions(@DoTestProcedureVarOpenArray);
- end;
- procedure TTestProcedureTypeParser.TestProcedureVarOpenArray;
- begin
- TestCallingConventions(@DoTestProcedureOutOpenArray);
- end;
- procedure TTestProcedureTypeParser.TestProcedureArrayOfConst;
- begin
- TestCallingConventions(@DoTestProcedureArrayOfConst);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOfObject;
- begin
- TestCallingConventions(@DoTestProcedureOfObject);
- end;
- procedure TTestProcedureTypeParser.TestProcedureOfObjectOneArg;
- begin
- TestCallingConventions(@DoTestProcedureOfObjectOneArg);
- end;
- procedure TTestProcedureTypeParser.TestProcedureIsNested;
- begin
- TestCallingConventions(@DoTestProcedureIsNested);
- end;
- procedure TTestProcedureTypeParser.TestProcedureIsNesteOneArg;
- begin
- TestCallingConventions(@DoTestProcedureIsNestedOneArg);
- end;
- procedure TTestProcedureTypeParser.TestFunction;
- begin
- TestCallingConventions(@DoTestFunction);
- end;
- procedure TTestProcedureTypeParser.TestFunctionOneArg;
- begin
- TestCallingConventions(@DoTestFunctionOneArg);
- end;
- procedure TTestProcedureTypeParser.TestFunctionOfObject;
- begin
- TestCallingConventions(@DoTestFunctionOfObject);
- end;
- procedure TTestProcedureTypeParser.TestFunctionOneArgOfObject;
- begin
- TestCallingConventions(@DoTestFunctionOneArgOfObject);
- end;
- { TTestRecordTypeParser }
- function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasRecordType
- ): TPasVariable;
- begin
- AssertNotNull(R);
- AssertNotNull(R.Members);
- AssertTrue('Have AIndex elements',R.Members.Count>AIndex);
- AssertEquals('Correct class in member',TPasVariable,TObject(R.Members[AIndex]).ClassType);
- Result:=TPasVariable(R.Members[AIndex]);
- end;
- function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasVariant
- ): TPasVariable;
- begin
- AssertNotNull(R);
- AssertNotNull('Have variant members', R.Members);
- AssertNotNull('Have variant members member list',R.Members.Members);
- AssertTrue('Have AIndex elements',R.Members.Members.Count>AIndex);
- AssertEquals('Correct class in member',TPasVariable,TObject(R.Members.members[AIndex]).ClassType);
- Result:=TPasVariable(R.Members.Members[AIndex]);
- end;
- function TTestRecordTypeParser.GetF(AIndex: Integer): TPasVariable;
- begin
- Result:=GetField(AIndex,GetR);
- end;
- function TTestRecordTypeParser.GetR: TPasRecordType;
- begin
- Result:=TheType as TPasRecordType;
- end;
- function TTestRecordTypeParser.GetVariant(AIndex: Integer; R: TPasRecordType
- ): TPasVariant;
- begin
- AssertNotNull(R);
- AssertNotNull(R.Variants);
- AssertTrue('Have AIndex variant elements',R.Variants.Count>AIndex);
- AssertEquals('Correct class in variant',TPasVariant,TObject(R.Variants[AIndex]).ClassType);
- Result:=TPasVariant(R.Variants[AIndex]);
- end;
- function TTestRecordTypeParser.GetV(AIndex: Integer): TPasVariant;
- begin
- Result:=GetVariant(AIndex,GetR);
- end;
- procedure TTestRecordTypeParser.TestFields(const Fields: array of string;
- AHint: String; HaveVariant: Boolean);
- Var
- S : String;
- I : integer;
- begin
- S:='';
- For I:=Low(Fields) to High(Fields) do
- begin
- if (S<>'') then
- S:=S+sLineBreak;
- S:=S+' '+Fields[i];
- end;
- if (S<>'') then
- S:=S+sLineBreak;
- S:='record'+sLineBreak+s+' end';
- ParseType(S,TPasRecordType,AHint);
- if HaveVariant then
- begin
- AssertNotNull('Have variants',TheRecord.Variants);
- AssertNotNull('Have variant type',TheRecord.VariantType);
- end
- else
- begin
- AssertNull('No variants',TheRecord.Variants);
- AssertNull('No variant type',TheRecord.VariantType);
- AssertEquals('No variant name','',TheRecord.VariantName);
- end;
- end;
- procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);
- begin
- if (AType='') then
- AType:='Integer';
- AssertEquals('Have variant selector storage name',AName,TheRecord.VariantName);
- AssertNotNull('Have variant selector type',TheRecord.VariantType);
- AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantType.ClassType);
- AssertEquals('Have variant selector type name',AType,TheRecord.VariantType.Name);
- end;
- procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
- begin
- TestFields([],AHint);
- AssertNotNull('Have members array',TheRecord.Members);
- AssertEquals('Zero members in array',0,TheRecord.Members.Count);
- end;
- procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints);
- begin
- AssertVariant1(Hints,['0']);
- end;
- procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
- Var
- I : Integer;
- begin
- AssertNotNull('Have variant 1',Variant1);
- AssertNotNull('Variant 1 has Values ',Variant1.Values);
- if Length(VariantLabels)=0 then
- begin
- AssertEquals('Have 1 value',1,Variant1.Values.Count);
- AssertNotNull('Assigned value',Variant1.Values[0]);
- AssertEquals('Expression',TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
- AssertExpression('First value is 0',TPasExpr(Variant1.Values[0]),pekNumber,'0');
- end
- else
- begin
- AssertEquals('Have correct number of values',Length(VariantLabels),Variant1.Values.Count);
- For I:=0 to Length(VariantLabels)-1 do
- begin
- AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
- AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
- end;
- end;
- AssertNotNull('Have members',Variant1.Members);
- AssertNotNull('Have member members',Variant1.Members.Members);
- AssertNotNull('member 0 not null',Variant1.Members.Members[0]);
- AssertEquals('Member 0 has correct name',TPasVariable,TObject(Variant1.Members.Members[0]).ClassType);
- AssertEquals('Member 0 has correct name','y',TPasVariable(Variant1.Members.Members[0]).Name);
- AssertNotNull('member 0 has not null type',TPasVariable(Variant1.Members.Members[0]).VarType);
- AssertEquals('member 0 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant1.Members.Members[0]).VarType.ClassType);
- AssertEquals('member 0 has correct type name','Integer',TPasVariable(Variant1.Members.Members[0]).VarType.Name);
- AssertTrue('Field 1 hints match',TPasVariable(Variant1.Members.Members[0]).Hints=Hints)
- end;
- procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints);
- begin
- AssertVariant2(Hints,['1']);
- end;
- procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
- Var
- I : Integer;
- begin
- AssertNotNull('Have variant 2',Variant2);
- AssertNotNull('Variant 2 has Values ',Variant2.Values);
- if Length(VariantLabels)=0 then
- begin
- AssertEquals('Variant 2 has 1 value',2,Variant2.Values.Count);
- AssertEquals('Expression',TPrimitiveExpr,TObject(Variant2.Values[0]).CLassType);
- AssertExpression('First value is 1',TPasExpr(Variant2.Values[0]),pekNumber,'1');
- end
- else
- begin
- AssertEquals('Variant 2 Has correct number of values',Length(VariantLabels),Variant2.Values.Count);
- For I:=0 to Length(VariantLabels)-1 do
- begin
- AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant2.Values[I]).CLassType);
- AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant2.Values[I]),pekNumber,VariantLabels[i]);
- // AssertEquals(Format('Variant 2, Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant2.Values[I]);
- end;
- end;
- AssertNotNull('Have members',Variant2.Members);
- AssertNotNull('Have member members',Variant2.Members.Members);
- AssertNotNull('member 1 not null',Variant2.Members.Members[0]);
- AssertEquals('Member 1 has correct name',TPasVariable,TObject(Variant2.Members.Members[0]).ClassType);
- AssertEquals('Member 1 has correct name','z',TPasVariable(Variant2.Members.Members[0]).Name);
- AssertNotNull('member 1 has not null type',TPasVariable(Variant2.Members.Members[0]).VarType);
- AssertEquals('member 1 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant2.Members.Members[0]).VarType.ClassType);
- AssertEquals('member 1 has correct type name','Integer',TPasVariable(Variant2.Members.Members[0]).VarType.Name);
- AssertTrue('Field 1 hints match',TPasVariable(Variant2.Members.Members[0]).Hints=Hints)
- end;
- procedure TTestRecordTypeParser.DoTestVariantNoStorage(const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : (y : integer;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertVariant1([]);
- end;
- procedure TTestRecordTypeParser.DoTestDeprecatedVariantNoStorage(
- const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : (y : integer deprecated;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertVariant1([hDeprecated]);
- end;
- procedure TTestRecordTypeParser.DoTestDeprecatedVariantStorage(
- const AHint: string);
- begin
- TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('s','');
- AssertVariant1([hDeprecated]);
- end;
- procedure TTestRecordTypeParser.DoTestVariantStorage(const AHint: string);
- begin
- TestFields(['x : integer;','case s : integer of','0 : (y : integer;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('s','');
- AssertVariant1([]);
- end;
- procedure TTestRecordTypeParser.DoTestTwoVariantsNoStorage(const AHint: string
- );
- begin
- TestFields(['x : integer;','case integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertVariant1([]);
- AssertVariant2([]);
- end;
- procedure TTestRecordTypeParser.DoTestTwoVariantsStorage(const AHint: string);
- begin
- TestFields(['x : integer;','case s : integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('s','');
- AssertVariant1([]);
- AssertVariant2([]);
- end;
- procedure TTestRecordTypeParser.DoTestTwoVariantsFirstDeprecatedStorage(
- const AHint: string);
- begin
- TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;);','1 : (z : integer;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('s','');
- AssertVariant1([hdeprecated]);
- AssertVariant2([]);
- end;
- procedure TTestRecordTypeParser.DoTestTwoVariantsSecondDeprecatedStorage(
- const AHint: string);
- begin
- TestFields(['x : integer;','case s : integer of','0 : (y : integer ;);','1 : (z : integer deprecated;)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('s','');
- AssertVariant1([]);
- AssertVariant2([hdeprecated]);
- end;
- procedure TTestRecordTypeParser.DoTestVariantTwoLabels(const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0,1 : (y : integer)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertVariant1([],['0','1']);
- end;
- procedure TTestRecordTypeParser.DoTestTwoVariantsTwoLabels(const AHint: string
- );
- begin
- TestFields(['x : integer;','case integer of','0,1 : (y : integer);','2,3 : (z : integer);'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertVariant1([],['0','1']);
- AssertVariant2([],['2','3']);
- end;
- procedure TTestRecordTypeParser.DoTestVariantNestedRecord(const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;','end)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertRecordVariant(0,[],['0']);
- end;
- procedure TTestRecordTypeParser.DoTestVariantNestedVariant(const AHint: string
- );
- begin
- TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer);',' 2 : ( j : byte)', 'end)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertRecordVariant(0,[],['0']);
- AssertRecordVariantVariant(0,'i','Integer',[],['1']);
- AssertRecordVariantVariant(1,'j','Byte',[],['2'])
- end;
- procedure TTestRecordTypeParser.DoTestVariantNestedVariantFirstDeprecated(
- const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated);',' 2 : ( j : byte)', 'end)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertRecordVariant(0,[],['0']);
- AssertRecordVariantVariant(0,'i','Integer',[hDeprecated],['1']);
- AssertRecordVariantVariant(1,'j','Byte',[],['2'])
- end;
- procedure TTestRecordTypeParser.DoTestVariantNestedVariantSecondDeprecated(
- const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertRecordVariant(0,[],['0']);
- AssertRecordVariantVariant(0,'i','Integer',[],['1']);
- AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])
- end;
- procedure TTestRecordTypeParser.DoTestVariantNestedVariantBothDeprecated(const AHint: string);
- begin
- TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
- AssertField1([]);
- AssertVariantSelector('','');
- AssertRecordVariant(0,[],['0']);
- AssertRecordVariantVariant(0,'i','Integer',[hdeprecated],['1']);
- AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])
- end;
- procedure TTestRecordTypeParser.TestEmpty;
- begin
- DoTestEmpty('')
- end;
- procedure TTestRecordTypeParser.TestEmptyDeprecated;
- begin
- DoTestEmpty('Deprecated')
- end;
- procedure TTestRecordTypeParser.TestEmptyPlatform;
- begin
- DoTestEmpty('Platform')
- end;
- procedure TTestRecordTypeParser.AssertField1(Hints : TPasMemberHints);
- begin
- AssertEquals('Member 1 field type',TPasVariable,TObject(TheRecord.Members[0]).ClassType);
- AssertEquals('Field 1 name','x',Field1.Name);
- AssertNotNull('Have 1 Field type',Field1.VarType);
- AssertEquals('Field 1 type',TPasUnresolvedTypeRef,Field1.VarType.ClassType);
- AssertEquals('Field 1 type name','Integer',Field1.VarType.Name);
- AssertTrue('Field 1 hints match',Field1.Hints=Hints)
- end;
- procedure TTestRecordTypeParser.AssertField2(Hints : TPasMemberHints);
- begin
- AssertEquals('Member 2 field type',TPasVariable,TObject(TheRecord.Members[1]).ClassType);
- AssertEquals('Field 2 name','y',Field2.Name);
- AssertNotNull('Have 2 Field type',Field2.VarType);
- AssertEquals('Field 2 type',TPasUnresolvedTypeRef,Field2.VarType.ClassType);
- AssertEquals('Field 2 type name','Integer',Field2.VarType.Name);
- AssertTrue('Field 2 hints match',Field2.Hints=Hints)
- end;
- procedure TTestRecordTypeParser.AssertOneIntegerField(Hints : TPasMemberHints);
- begin
- AssertEquals('One field',1,TheRecord.Members.Count);
- AssertField1(Hints);
- end;
- procedure TTestRecordTypeParser.AssertTwoIntegerFields(Hints1,Hints2: TPasMemberHints);
- begin
- AssertEquals('Two field',2,TheRecord.Members.Count);
- AssertField1(Hints1);
- AssertField2(Hints2);
- end;
- procedure TTestRecordTypeParser.AssertRecordField(AIndex: Integer;
- Hints: TPasMemberHints);
- Var
- F : TPasVariable;
- R : TPasRecordtype;
- begin
- AssertEquals('Member 2 field type',TPasVariable,TObject(TheRecord.Members[AIndex]).ClassType);
- F:=GetF(AIndex);
- if AIndex=1 then
- AssertEquals('Field 2 name','y',F.Name)
- else
- AssertEquals('Field 1 name','x',F.Name);
- AssertNotNull('Have 2 Field type',F.VarType);
- AssertEquals('Field 2 type',TPasRecordType,F.VarType.ClassType);
- R:=F.VarType as TPasRecordType;
- AssertNotNull('Record field has members',R.Members);
- AssertEquals('Record field has 1 member',1,R.Members.Count);
- AssertTrue('Record field hints match',F.Hints=Hints)
- end;
- procedure TTestRecordTypeParser.AssertRecordVariant(AIndex: Integer;
- Hints: TPasMemberHints; VariantLabels : Array of string);
- Var
- F : TPasVariant;
- V : TPasVariable;
- R : TPasRecordtype;
- I : Integer;
- MN : String;
- begin
- F:=GetV(AIndex);
- MN:='Variant '+IntToStr(AIndex)+' ';
- AssertNotNull('Have variant 1',F);
- AssertEquals('Have correct number of values',Length(VariantLabels),F.Values.Count);
- For I:=0 to Length(VariantLabels)-1 do
- begin
- AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[i]).CLassType);
- AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
- end;
- V:=GetField(0,F);
- AssertEquals(MN+'has correct name','y',V.Name);
- AssertNotNull(MN+'has not null type',V.VarType);
- AssertEquals(MN+'has correct type',TPasRecordType,V.VarType.ClassType);
- AssertTrue(MN+'hints match',V.Hints=Hints);
- R:=TPasVariable(F.Members.Members[0]).VarType as TPasRecordType;
- V:=GetField(0,R);
- AssertEquals('Field 1 has correct name','z',V.Name);
- AssertNotNull('Record field has members',R.Members);
- AssertEquals('Record field has 1 member',1,R.Members.Count);
- end;
- procedure TTestRecordTypeParser.AssertRecordVariantVariant(AIndex: Integer; Const AFieldName,ATypeName: string;
- Hints: TPasMemberHints; VariantLabels: array of string);
- Var
- F : TPasVariant;
- V : TPasVariable;
- R : TPasRecordtype;
- I : Integer;
- MN : String;
- begin
- F:=GetV(0);
- MN:='Nested Variant '+IntToStr(AIndex)+' ';
- AssertNotNull('Have variant 1',F);
- AssertEquals('Have correct number of values',1,F.Values.Count);
- AssertEquals('Expression',TPrimitiveExpr,TObject(F.Values[0]).CLassType);
- AssertExpression('First value is 0',TPasExpr(F.Values[0]),pekNumber,'0');
- // First variant, Y, record
- V:=GetField(0,F);
- AssertEquals(MN+'has correct name','y',V.Name);
- AssertNotNull(MN+'has not null type',V.VarType);
- AssertEquals(MN+'has correct type',TPasRecordType,V.VarType.ClassType);
- R:=TPasVariable(F.Members.Members[0]).VarType as TPasRecordType;
- AssertNotNull('Record field has members',R.Members);
- AssertEquals('Record field has 2 members',1,R.Members.Count);
- // First variant
- F:=GetVariant(Aindex,R);
- // First field of first variant, i
- AssertEquals('Have correct number of values',Length(VariantLabels),F.Values.Count);
- For I:=0 to Length(VariantLabels)-1 do
- begin
- AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(F.Values[i]).CLassType);
- AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(F.Values[I]),pekNumber,VariantLabels[i]);
- end;
- V:=GetField(0,F);
- AssertEquals('Nested Variant 0 has correct name',AFieldName,V.Name);
- AssertEquals('Nested variant 0 has correct type',TPasUnresolvedTypeRef,V.VarType.ClassType);
- AssertEquals('Nested variant 0 has correct type name',ATypeName,V.VarType.Name);
- AssertTrue(MN+'hints match',V.Hints=Hints);
- end;
- procedure TTestRecordTypeParser.TestOneField;
- begin
- TestFields(['x : integer'],'',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneFieldDeprecated;
- begin
- TestFields(['x : integer'],'deprecated',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneFieldPlatform;
- begin
- TestFields(['x : integer'],'platform',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneFieldSemicolon;
- begin
- TestFields(['x : integer;'],'',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneFieldSemicolonDeprecated;
- begin
- TestFields(['x : integer;'],'deprecated',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneFieldSemicolonPlatform;
- begin
- TestFields(['x : integer;'],'platform',False);
- AssertOneIntegerField([]);
- end;
- procedure TTestRecordTypeParser.TestOneDeprecatedField;
- begin
- TestFields(['x : integer deprecated;'],'',False);
- AssertOneIntegerField([hDeprecated]);
- end;
- procedure TTestRecordTypeParser.TestOneDeprecatedFieldDeprecated;
- begin
- TestFields(['x : integer deprecated;'],'deprecated',False);
- AssertOneIntegerField([hDeprecated]);
- end;
- procedure TTestRecordTypeParser.TestOneDeprecatedFieldPlatform;
- begin
- TestFields(['x : integer deprecated;'],'platform',False);
- AssertOneIntegerField([hDeprecated]);
- end;
- procedure TTestRecordTypeParser.TestOnePlatformField;
- begin
- TestFields(['x : integer platform;'],'',False);
- AssertOneIntegerField([hplatform]);
- end;
- procedure TTestRecordTypeParser.TestOnePlatformFieldDeprecated;
- begin
- TestFields(['x : integer platform;'],'Deprecated',False);
- AssertOneIntegerField([hplatform]);
- end;
- procedure TTestRecordTypeParser.TestOnePlatformFieldPlatform;
- begin
- TestFields(['x : integer platform;'],'Platform',False);
- AssertOneIntegerField([hplatform]);
- end;
- procedure TTestRecordTypeParser.TestTwoFields;
- begin
- TestFields(['x : integer;','y : integer'],'',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldDeprecated;
- begin
- TestFields(['x : integer;','y : integer'],'deprecated',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldPlatform;
- begin
- TestFields(['x : integer;','y : integer'],'platform',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecated;
- begin
- TestFields(['x : integer deprecated;','y : integer'],'',False);
- AssertTwoIntegerFields([hdeprecated],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecatedDeprecated;
- begin
- TestFields(['x : integer deprecated;','y : integer'],'deprecated',False);
- AssertTwoIntegerFields([hdeprecated],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecatedPlatform;
- begin
- TestFields(['x : integer deprecated;','y : integer'],'platform',False);
- AssertTwoIntegerFields([hdeprecated],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecated;
- begin
- TestFields(['x : integer;','y : integer deprecated;'],'',False);
- AssertTwoIntegerFields([],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecatedDeprecated;
- begin
- TestFields(['x : integer;','y : integer deprecated;'],'deprecated',False);
- AssertTwoIntegerFields([],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecatedPlatform;
- begin
- TestFields(['x : integer;','y : integer deprecated;'],'platform',False);
- AssertTwoIntegerFields([],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecated;
- begin
- TestFields(['x : integer deprecated;','y : integer deprecated;'],'',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecatedDeprecated;
- begin
- TestFields(['x : integer deprecated;','y : integer deprecated;'],'deprecated',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecatedPlatform;
- begin
- TestFields(['x : integer deprecated;','y : integer deprecated;'],'platform',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsCombined;
- begin
- TestFields(['x,y : integer;'],'',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsCombinedDeprecated;
- begin
- TestFields(['x,y : integer;'],'deprecated',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoFieldsCombinedPlatform;
- begin
- TestFields(['x,y : integer;'],'platform',False);
- AssertTwoIntegerFields([],[]);
- end;
- procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombined;
- begin
- TestFields(['x,y : integer deprecated;'],'',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombinedDeprecated;
- begin
- TestFields(['x,y : integer deprecated;'],'deprecated',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombinedPlatform;
- begin
- TestFields(['x,y : integer deprecated;'],'platform',False);
- AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
- end;
- procedure TTestRecordTypeParser.TestNested;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end'],'',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedSemicolon;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end;'],'',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedSemicolonDeprecated;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end;'],'deprecated',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedSemicolonPlatform;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end;'],'platform',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedDeprecated;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end'],'deprecated',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedPlatform;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end'],'platform',False);
- AssertField1([]);
- AssertRecordField(1,[])
- end;
- procedure TTestRecordTypeParser.TestNestedFirst;
- begin
- TestFields(['x : record',' z : integer;','end;','y : integer;'],'',False);
- AssertField2([]);
- AssertRecordField(0,[])
- end;
- procedure TTestRecordTypeParser.TestNestedFirstDeprecated;
- begin
- TestFields(['x : record',' z : integer;','end;','y : integer;'],'deprecated',False);
- AssertField2([]);
- AssertRecordField(0,[])
- end;
- procedure TTestRecordTypeParser.TestNestedFirstPlatform;
- begin
- TestFields(['x : record',' z : integer;','end;','y : integer;'],'platform',False);
- AssertField2([]);
- AssertRecordField(0,[])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNested;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'',False);
- AssertField1([]);
- AssertRecordField(1,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNestedDeprecated;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'deprecated',False);
- AssertField1([]);
- AssertRecordField(1,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNestedPlatform;
- begin
- TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'platform',False);
- AssertField1([]);
- AssertRecordField(1,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNestedFirst;
- begin
- TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'',False);
- AssertField2([]);
- AssertRecordField(0,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNestedFirstDeprecated;
- begin
- TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'deprecated',False);
- AssertField2([]);
- AssertRecordField(0,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestDeprecatedNestedFirstPlatform;
- begin
- TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'platform',False);
- AssertField2([]);
- AssertRecordField(0,[hdeprecated])
- end;
- procedure TTestRecordTypeParser.TestVariantNoStorage;
- begin
- DoTestVariantNoStorage('');
- end;
- procedure TTestRecordTypeParser.TestVariantNoStorageDeprecated;
- begin
- DoTestVariantNoStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNoStoragePlatform;
- begin
- DoTestVariantNoStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestVariantStorage;
- begin
- DoTestVariantStorage('');
- end;
- procedure TTestRecordTypeParser.TestVariantStorageDeprecated;
- begin
- DoTestVariantStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantStoragePlatform;
- begin
- DoTestVariantStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantNoStorage;
- begin
- DoTestDeprecatedVariantNoStorage('');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantNoStorageDeprecated;
- begin
- DoTestDeprecatedVariantNoStorage('Deprecated');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantNoStoragePlatform;
- begin
- DoTestDeprecatedVariantNoStorage('Platform');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantStorage;
- begin
- DoTestDeprecatedVariantStorage('');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantStorageDeprecated;
- begin
- DoTestDeprecatedVariantStorage('Deprecated');
- end;
- procedure TTestRecordTypeParser.TestDeprecatedVariantStoragePlatform;
- begin
- DoTestDeprecatedVariantStorage('Platform');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsNoStorage;
- begin
- DoTestTwoVariantsNoStorage('');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsNoStorageDeprecated;
- begin
- DoTestTwoVariantsNoStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsNoStoragePlatform;
- begin
- DoTestTwoVariantsNoStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsStorage;
- begin
- DoTestTwoVariantsStorage('');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsStorageDeprecated;
- begin
- DoTestTwoVariantsStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsStoragePlatform;
- begin
- DoTestTwoVariantsStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStorage;
- begin
- DoTestTwoVariantsFirstDeprecatedStorage('');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStorageDeprecated;
- begin
- DoTestTwoVariantsFirstDeprecatedStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStoragePlatform;
- begin
- DoTestTwoVariantsFirstDeprecatedStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStorage;
- begin
- DoTestTwoVariantsSecondDeprecatedStorage('');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStorageDeprecated;
- begin
- DoTestTwoVariantsSecondDeprecatedStorage('deprecated');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStoragePlatform;
- begin
- DoTestTwoVariantsSecondDeprecatedStorage('platform');
- end;
- procedure TTestRecordTypeParser.TestVariantTwoLabels;
- begin
- DoTestVariantTwoLabels('');
- end;
- procedure TTestRecordTypeParser.TestVariantTwoLabelsDeprecated;
- begin
- DoTestVariantTwoLabels('Deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantTwoLabelsPlatform;
- begin
- DoTestVariantTwoLabels('Platform');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsTwoLabels;
- begin
- DoTestTwoVariantsTwoLabels('');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsTwoLabelsDeprecated;
- begin
- DoTestTwoVariantsTwoLabels('Deprecated');
- end;
- procedure TTestRecordTypeParser.TestTwoVariantsTwoLabelsPlatform;
- begin
- DoTestTwoVariantsTwoLabels('Platform');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedRecord;
- begin
- DoTestVariantNestedRecord('');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedRecordDeprecated;
- begin
- DoTestVariantNestedRecord('Deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedRecordPlatform;
- begin
- DoTestVariantNestedRecord('Platform');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariant;
- begin
- DoTestVariantNestedVariant('');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantDeprecated;
- begin
- DoTestVariantNestedVariant('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantPlatForm;
- begin
- DoTestVariantNestedVariant('Platform');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecated;
- begin
- DoTestVariantNestedVariantFirstDeprecated('');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecatedDeprecated;
- begin
- DoTestVariantNestedVariantFirstDeprecated('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecatedPlatform;
- begin
- DoTestVariantNestedVariantFirstDeprecated('platform');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecated;
- begin
- DoTestVariantNestedVariantSecondDeprecated('');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecatedDeprecated;
- begin
- DoTestVariantNestedVariantSecondDeprecated('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecatedPlatform;
- begin
- DoTestVariantNestedVariantSecondDeprecated('platform');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecated;
- begin
- DoTestVariantNestedVariantBothDeprecated('');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecatedDeprecated;
- begin
- DoTestVariantNestedVariantBothDeprecated('deprecated');
- end;
- procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecatedPlatform;
- begin
- DoTestVariantNestedVariantBothDeprecated('platform');
- end;
- { TBaseTestTypeParser }
- function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;Const AHint : String = ''): TPasType;
- Var
- D : String;
- begin
- Hint:=AHint;
- Add('Type');
- D:='A = '+ASource;
- If Hint<>'' then
- D:=D+' '+Hint;
- Add(' '+D+';');
- // Writeln(source.text);
- ParseDeclarations;
- AssertEquals('One type definition',1,Declarations.Types.Count);
- If (AtypeClass<>Nil) then
- AssertEquals('First declaration is type definition.',ATypeClass,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('First declaration has correct name.','A',TPasType(Declarations.Types[0]).Name);
- Result:=TPasType(Declarations.Types[0]);
- FType:=Result;
- Definition:=Result;
- if (Hint<>'') then
- CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'h'+Hint)));
- end;
- procedure TBaseTestTypeParser.AssertParseTypeError(ASource: String);
- begin
- try
- ParseType(ASource,Nil,'');
- Fail('Expected parser error');
- except
- // all OK.
- end;
- end;
- procedure TBaseTestTypeParser.SetUp;
- begin
- Inherited;
- FErrorSource:='';
- FHint:='';
- FType:=Nil;
- end;
- procedure TBaseTestTypeParser.TearDown;
- begin
- inherited TearDown;
- FType:=Nil;
- end;
- { TTestTypeParser }
- procedure TTestTypeParser.DoTestAliasType(const AnAliasType: String;
- const AHint: String);
- begin
- ParseType(AnAliasType,TPasAliasType,AHint);
- AssertEquals('Unresolved type',TPasUnresolvedTypeRef,TPasAliasType(TheType).DestType.ClassType);
- end;
- procedure TTestTypeParser.DoTestStringType(const AnAliasType: String;
- const AHint: String);
- begin
- ParseType(AnAliasType,TPasAliasType,AHint);
- AssertEquals('String type',TPasStringType,TPasAliasType(TheType).DestType.ClassType);
- end;
- procedure TTestTypeParser.DoTypeError(Const AMsg,ASource : string);
- begin
- FErrorSource:=ASource;
- AssertException(AMsg,EParserError,@DoParseError);
- end;
- procedure TTestTypeParser.DoParseError;
- begin
- ParseType(FErrorSource,Nil);
- end;
- procedure TTestTypeParser.DoParsePointer(const ASource: String;
- const AHint: String; ADestType: TClass);
- begin
- ParseType('^'+ASource,TPasPointerType,AHint);
- if ADestType = Nil then
- ADestType:=TPasUnresolvedTypeRef;
- AssertEquals('Destination type '+ADestType.ClassName,ADestType,TPasPointerType(TheType).DestType.ClassType);
- end;
- procedure TTestTypeParser.DoParseArray(const ASource: String;
- const AHint: String; ADestType: TClass);
- begin
- ParseType(ASource,TPasArrayType,AHint);
- if ADestType = Nil then
- ADestType:=TPasUnresolvedTypeRef;
- AssertEquals('Destination type '+ADestType.ClassName,ADestType,TPasArrayType(TheType).ElType.ClassType);
- end;
- procedure TTestTypeParser.DoParseEnumerated(const ASource: String;
- const AHint: String; ACount: integer);
- Var
- I : Integer;
- begin
- ParseType(ASource,TPasEnumType,AHint);
- AssertNotNull('Have values',TPasEnumType(TheType).Values);
- AssertEquals('Value count',ACount,TPasEnumType(TheType).Values.Count);
- For I:=0 to TPasEnumType(TheType).Values.Count-1 do
- AssertEquals('Enum value typed element '+IntToStr(I),TPasEnumValue,TObject(TPasEnumType(TheType).Values[i]).ClassType);
- end;
- procedure TTestTypeParser.DoTestFileType(const AType: String;
- const AHint: String; ADestType: TClass);
- begin
- ParseType('File of '+AType,TPasFileType,AHint);
- AssertNotNull('Have element type',TPasFileType(TheType).ElType);
- if ADestType = Nil then
- ADestType:=TPasUnresolvedTypeRef;
- AssertEquals('Element type '+ADestType.ClassName,ADestType,TPasFileType(TheType).ElType.ClassType);
- end;
- procedure TTestTypeParser.DoTestRangeType(const AStart, AStop, AHint: String);
- begin
- ParseType(AStart+'..'+AStop,TPasRangeType,AHint);
- AssertEquals('Range start',AStart,TPasRangeType(TheType).RangeStart);
- AssertEquals('Range start',AStop,TPasRangeType(TheType).RangeEnd);
- end;
- procedure TTestTypeParser.DoParseSimpleSet(const ASource: String;
- const AHint: String);
- begin
- ParseType('Set of '+ASource,TPasSetType,AHint);
- AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
- AssertEquals('Element type ',TPasUnresolvedTypeRef,TPasSetType(TheType).EnumType.ClassType);
- end;
- procedure TTestTypeParser.DoParseComplexSet(const ASource: String;
- const AHint: String);
- begin
- ParseType('Set of '+ASource,TPasSetType,AHint);
- AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
- AssertEquals('Element type ',TPasEnumType,TPasSetType(TheType).EnumType.ClassType);
- end;
- procedure TTestTypeParser.DoParseRangeSet(const ASource: String;
- const AHint: String);
- begin
- ParseType('Set of '+ASource,TPasSetType,AHint);
- AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
- AssertEquals('Element type ',TPasRangeType,TPasSetType(TheType).EnumType.ClassType);
- end;
- procedure TTestTypeParser.DoTestComplexSet;
- Var
- I : integer;
- begin
- AssertNotNull('Have values',TPasEnumType(TPasSetType(TheType).EnumType).Values);
- AssertEquals('Have 3 values',3, TPasEnumType(TPasSetType(TheType).EnumType).Values.Count);
- For I:=0 to TPasEnumType(TPasSetType(TheType).EnumType).Values.Count-1 do
- AssertEquals('Enum value typed element '+IntToStr(I),TPasEnumValue,TObject(TPasEnumType(TPasSetType(TheType).EnumType).Values[i]).ClassType);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[0]).Name);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[1]).Name);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[0]).AssignedValue);
- AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[1]).AssignedValue);
- AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.DoTestClassOf(const AHint: string);
- begin
- ParseType('Class of TSomeClass',TPasClassOfType,AHint);
- AssertNotNull('Have class type',TPasClassOfType(TheType).DestType);
- AssertEquals('Element type ',TPasUnresolvedTypeRef,TPasClassOfType(TheType).DestType.ClassType);
- end;
- procedure TTestTypeParser.TestAliasType;
- begin
- DoTestAliasType('othertype','');
- AssertEquals('Unresolved type name ','othertype',TPasUnresolvedTypeRef(TPasAliasType(TheType).DestType).name);
- end;
- procedure TTestTypeParser.TestCrossUnitAliasType;
- begin
- DoTestAliasType('otherunit.othertype','');
- end;
- procedure TTestTypeParser.TestAliasTypeDeprecated;
- begin
- DoTestALiasType('othertype','deprecated');
- end;
- procedure TTestTypeParser.TestAliasTypePlatform;
- begin
- DoTestALiasType('othertype','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeByte;
- begin
- DoTestAliasType('BYTE','');
- end;
- procedure TTestTypeParser.TestSimpleTypeByteDeprecated;
- begin
- DoTestAliasType('BYTE','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeBytePlatform;
- begin
- DoTestAliasType('BYTE','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeBoolean;
- begin
- DoTestAliasType('BOOLEAN','');
- end;
- procedure TTestTypeParser.TestSimpleTypeBooleanDeprecated;
- begin
- DoTestAliasType('BOOLEAN','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeBooleanPlatform;
- begin
- DoTestAliasType('BOOLEAN','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeChar;
- begin
- DoTestAliasType('CHAR','');
- end;
- procedure TTestTypeParser.TestSimpleTypeCharDeprecated;
- begin
- DoTestAliasType('CHAR','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeCharPlatform;
- begin
- DoTestAliasType('CHAR','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeInteger;
- begin
- DoTestAliasType('INTEGER','');
- end;
- procedure TTestTypeParser.TestSimpleTypeIntegerDeprecated;
- begin
- DoTestAliasType('INTEGER','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeIntegerPlatform;
- begin
- DoTestAliasType('INTEGER','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeInt64;
- begin
- DoTestAliasType('INT64','');
- end;
- procedure TTestTypeParser.TestSimpleTypeInt64Deprecated;
- begin
- DoTestAliasType('INT64','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeInt64Platform;
- begin
- DoTestAliasType('INT64','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongInt;
- begin
- DoTestAliasType('LONGINT','');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongIntDeprecated;
- begin
- DoTestAliasType('LONGINT','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongIntPlatform;
- begin
- DoTestAliasType('LONGINT','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongWord;
- begin
- DoTestAliasType('LONGWORD','');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongWordDeprecated;
- begin
- DoTestAliasType('LONGWORD','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeLongWordPlatform;
- begin
- DoTestAliasType('LONGWORD','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeDouble;
- begin
- DoTestAliasType('Double','');
- end;
- procedure TTestTypeParser.TestSimpleTypeDoubleDeprecated;
- begin
- DoTestAliasType('Double','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeDoublePlatform;
- begin
- DoTestAliasType('Double','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeShortInt;
- begin
- DoTestAliasType('SHORTINT','');
- end;
- procedure TTestTypeParser.TestSimpleTypeShortIntDeprecated;
- begin
- DoTestAliasType('SHORTINT','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeShortIntPlatform;
- begin
- DoTestAliasType('SHORTINT','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeSmallInt;
- begin
- DoTestAliasType('SMALLINT','');
- end;
- procedure TTestTypeParser.TestSimpleTypeSmallIntDeprecated;
- begin
- DoTestAliasType('SMALLINT','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeSmallIntPlatform;
- begin
- DoTestAliasType('SMALLINT','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeString;
- begin
- DoTestAliasType('STRING','');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringDeprecated;
- begin
- DoTestAliasType('STRING','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringPlatform;
- begin
- DoTestAliasType('STRING','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringSize;
- begin
- DoTestStringType('String[10]','');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringSizeIncomplete;
- begin
- DoTypeError('Incomplete string: missing ]','string[10');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringSizeWrong;
- begin
- DoTypeError('Incomplete string, ) instead of ]','string[10)');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringSizeDeprecated;
- begin
- DoTestStringType('String[10]','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeStringSizePlatform;
- begin
- DoTestStringType('String[10]','Platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeWord;
- BEGIN
- DoTestAliasType('WORD','');
- end;
- procedure TTestTypeParser.TestSimpleTypeWordDeprecated;
- begin
- DoTestAliasType('WORD','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeWordPlatform;
- begin
- DoTestAliasType('WORD','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeQWord;
- BEGIN
- DoTestAliasType('QWORD','');
- end;
- procedure TTestTypeParser.TestSimpleTypeQWordDeprecated;
- begin
- DoTestAliasType('QWORD','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeQWordPlatform;
- begin
- DoTestAliasType('QWORD','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeCardinal;
- begin
- DoTestAliasType('CARDINAL','');
- end;
- procedure TTestTypeParser.TestSimpleTypeCardinalDeprecated;
- begin
- DoTestAliasType('CARDINAL','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeCardinalPlatform;
- begin
- DoTestAliasType('CARDINAL','platform');
- end;
- procedure TTestTypeParser.TestSimpleTypeWideChar;
- begin
- DoTestAliasType('WIDECHAR','');
- end;
- procedure TTestTypeParser.TestSimpleTypeWideCharDeprecated;
- begin
- DoTestAliasType('WIDECHAR','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleTypeWideCharPlatform;
- begin
- DoTestAliasType('WIDECHAR','platform');
- end;
- procedure TTestTypeParser.TestPointerSimple;
- begin
- DoParsePointer('integer','');
- end;
- procedure TTestTypeParser.TestPointerSimpleDeprecated;
- begin
- DoParsePointer('integer','deprecated');
- end;
- procedure TTestTypeParser.TestPointerSimplePlatform;
- begin
- DoParsePointer('integer','platform');
- end;
- procedure TTestTypeParser.TestStaticArray;
- begin
- DoParseArray('array [0..2] of integer','',Nil);
- AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
- end;
- procedure TTestTypeParser.TestStaticArrayDeprecated;
- begin
- DoParseArray('array [0..2] of integer','deprecated',Nil);
- AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
- end;
- procedure TTestTypeParser.TestStaticArrayPlatform;
- begin
- DoParseArray('array [0..2] of integer','platform',Nil);
- AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
- end;
- procedure TTestTypeParser.TestStaticArrayPacked;
- begin
- DoParseArray('packed array [0..2] of integer','',Nil);
- AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
- AssertEquals('Packed',True,TPasArrayType(TheType).IsPacked);
- end;
- procedure TTestTypeParser.TestStaticArrayTypedIndex;
- begin
- DoParseArray('array [Boolean] of integer','',Nil);
- AssertEquals('Array type','Boolean',TPasArrayType(TheType).IndexRange);
- end;
- procedure TTestTypeParser.TestDynamicArray;
- begin
- DoParseArray('array of integer','',Nil);
- AssertEquals('Array type','',TPasArrayType(TheType).IndexRange);
- end;
- procedure TTestTypeParser.TestSimpleEnumerated;
- begin
- DoParseEnumerated('(one,two,three)','',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestSimpleEnumeratedDeprecated;
- begin
- DoParseEnumerated('(one,two,three)','deprecated',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestSimpleEnumeratedPlatform;
- begin
- DoParseEnumerated('(one,two,three)','platform',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestAssignedEnumerated;
- begin
- DoParseEnumerated('(one,two:=2,three)','',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestAssignedEnumeratedDeprecated;
- begin
- DoParseEnumerated('(one,two:=2,three)','',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestAssignedEnumeratedPlatform;
- begin
- DoParseEnumerated('(one,two:=2,three)','',3);
- AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
- AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
- AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
- AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
- AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
- end;
- procedure TTestTypeParser.TestFileType;
- begin
- DoTestFileType('integer','');
- end;
- procedure TTestTypeParser.TestFileTypeDeprecated;
- begin
- DoTestFileType('integer','deprecated');
- end;
- procedure TTestTypeParser.TestFileTypePlatform;
- begin
- DoTestFileType('integer','platform');
- end;
- procedure TTestTypeParser.TestRangeType;
- begin
- DoTestRangeType('1','4','');
- end;
- procedure TTestTypeParser.TestRangeTypeDeprecated;
- begin
- DoTestRangeType('1','4','deprecated');
- end;
- procedure TTestTypeParser.TestRangeTypePlatform;
- begin
- DoTestRangeType('1','4','platform');
- end;
- procedure TTestTypeParser.TestIdentifierRangeType;
- begin
- DoTestRangeType('tkFirst','tkLast','');
- end;
- procedure TTestTypeParser.TestIdentifierRangeTypeDeprecated;
- begin
- DoTestRangeType('tkFirst','tkLast','deprecated');
- end;
- procedure TTestTypeParser.TestIdentifierRangeTypePlatform;
- begin
- DoTestRangeType('tkFirst','tkLast','platform');
- end;
- procedure TTestTypeParser.TestNegativeIdentifierRangeType;
- begin
- DoTestRangeType('-tkLast','tkLast','');
- end;
- procedure TTestTypeParser.TestSimpleSet;
- begin
- DoParseSimpleSet('Byte','');
- end;
- procedure TTestTypeParser.TestSimpleSetDeprecated;
- begin
- DoParseSimpleSet('Byte','deprecated');
- end;
- procedure TTestTypeParser.TestSimpleSetPlatform;
- begin
- DoParseSimpleSet('Byte','platform');
- end;
- procedure TTestTypeParser.TestComplexSet;
- begin
- DoParseComplexSet('(one, two, three)','');
- DoTestComplexSet;
- end;
- procedure TTestTypeParser.TestComplexSetDeprecated;
- begin
- DoParseComplexSet('(one, two, three)','deprecated');
- DoTestComplexSet;
- end;
- procedure TTestTypeParser.TestComplexSetPlatform;
- begin
- DoParseComplexSet('(one, two, three)','platform');
- DoTestComplexSet;
- end;
- procedure TTestTypeParser.TestRangeSet;
- begin
- DoParseRangeSet('0..SizeOf(Integer)*8-1','');
- end;
- procedure TTestTypeParser.TestRangeSetDeprecated;
- begin
- DoParseRangeSet('0..SizeOf(Integer)*8-1','deprecated');
- end;
- procedure TTestTypeParser.TestRangeSetPlatform;
- begin
- DoParseRangeSet('0..SizeOf(Integer)*8-1','platform');
- end;
- procedure TTestTypeParser.TestClassOf;
- begin
- DoTestClassOf('');
- end;
- procedure TTestTypeParser.TestClassOfDeprecated;
- begin
- DoTestClassOf('deprecated');
- end;
- procedure TTestTypeParser.TestClassOfPlatform;
- begin
- DoTestClassOf('Platform');
- end;
- procedure TTestTypeParser.TestReferenceAlias;
- begin
- Add('Type');
- Add(' Type1 = Integer;');
- Add(' Type2 = Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('Two type definitions',2,Declarations.Types.Count);
- AssertEquals('First declaration is type definition.',TPasAliasType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasAliasType,TObject(Declarations.Types[1]).ClassType);
- AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
- AssertSame('Second declaration references first.',Declarations.Types[0],TPasAliasType(Declarations.Types[1]).DestType);
- end;
- procedure TTestTypeParser.TestReferenceSet;
- begin
- Add('Type');
- Add(' Type1 = (a,b,c);');
- Add(' Type2 = set of Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('Two type definitions',2,Declarations.Types.Count);
- AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasSetType,TObject(Declarations.Types[1]).ClassType);
- AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
- AssertSame('Second declaration references first.',Declarations.Types[0],TPasSetType(Declarations.Types[1]).EnumType);
- end;
- procedure TTestTypeParser.TestReferenceClassOf;
- begin
- Add('Type');
- Add(' Type1 = Class(TObject);');
- Add(' Type2 = Class of Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('1 type definitions',1,Declarations.Types.Count);
- AssertEquals('1 class definitions',1,Declarations.Classes.Count);
- AssertEquals('First declaration is class definition.',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasClassOfType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('First declaration has correct name.','Type2',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type1',TPasType(Declarations.Classes[0]).Name);
- AssertSame('Second declaration references first.',Declarations.Classes[0],TPasClassOfType(Declarations.Types[0]).DestType);
- end;
- procedure TTestTypeParser.TestReferenceFile;
- begin
- Add('Type');
- Add(' Type1 = (a,b,c);');
- Add(' Type2 = File of Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('Two type definitions',2,Declarations.Types.Count);
- AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasFileType,TObject(Declarations.Types[1]).ClassType);
- AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
- AssertSame('Second declaration references first.',Declarations.Types[0],TPasFileType(Declarations.Types[1]).elType);
- end;
- procedure TTestTypeParser.TestReferenceArray;
- begin
- Add('Type');
- Add(' Type1 = (a,b,c);');
- Add(' Type2 = Array of Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('Two type definitions',2,Declarations.Types.Count);
- AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasArrayType,TObject(Declarations.Types[1]).ClassType);
- AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
- AssertSame('Second declaration references first.',Declarations.Types[0],TPasArrayType(Declarations.Types[1]).elType);
- end;
- procedure TTestTypeParser.TestReferencePointer;
- begin
- Add('Type');
- Add(' Type1 = (a,b,c);');
- Add(' Type2 = ^Type1;');
- Add('end.');
- ParseDeclarations;
- AssertEquals('Two type definitions',2,Declarations.Types.Count);
- AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
- AssertEquals('Second declaration is type definition.',TPasPointerType,TObject(Declarations.Types[1]).ClassType);
- AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
- AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
- AssertSame('Second declaration references first.',Declarations.Types[0],TPasPointerType(Declarations.Types[1]).DestType);
- end;
- initialization
- RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);
- end.