|
@@ -0,0 +1,2824 @@
|
|
|
|
+unit tctypeparser;
|
|
|
|
+
|
|
|
|
+{$mode objfpc}{$H+}
|
|
|
|
+
|
|
|
|
+interface
|
|
|
|
+
|
|
|
|
+uses
|
|
|
|
+ Classes, SysUtils, fpcunit, testutils, 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);
|
|
|
|
+Var
|
|
|
|
+ A : TPasArgument;
|
|
|
|
+
|
|
|
|
+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);
|
|
|
|
+ AssertEquals('First value is 0','0',Variant1.Values[0]);
|
|
|
|
+ end
|
|
|
|
+ else
|
|
|
|
+ begin
|
|
|
|
+ AssertEquals('Have correct number of values',Length(VariantLabels),Variant1.Values.Count);
|
|
|
|
+ For I:=0 to Length(VariantLabels)-1 do
|
|
|
|
+ AssertEquals(Format('Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant1.Values[I]);
|
|
|
|
+ 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('Variant 2 First value is 0','1',Variant2.Values[0]);
|
|
|
|
+ end
|
|
|
|
+ else
|
|
|
|
+ begin
|
|
|
|
+ AssertEquals('Variant 2 Has correct number of values',Length(VariantLabels),Variant2.Values.Count);
|
|
|
|
+ For I:=0 to Length(VariantLabels)-1 do
|
|
|
|
+ AssertEquals(Format('Variant 2, Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant2.Values[I]);
|
|
|
|
+ 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
|
|
|
|
+ AssertEquals(Format('Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],F.Values[I]);
|
|
|
|
+ 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('Value 1 is 0','0',F.Values[I]);
|
|
|
|
+ // 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
|
|
|
|
+ AssertEquals(Format('Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],F.Values[I]);
|
|
|
|
+ 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.
|
|
|
|
+
|