tctypeparser.pas | searchcode

/packages/fcl-passrc/tests/tctypeparser.pas

https://github.com/slibre/freepascal · Pascal · 2839 lines · 2411 code · 413 blank · 15 comment · 16 complexity · a1f7e5d4fb1b8933d72bf741719ace76 MD5 · raw file
Large files are truncated click here to view the full file

unit tctypeparser;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, fpcunit, pastree, pscanner, pparser,
  tcbaseparser, testregistry;

type
  { TBaseTestTypeParser }

  TBaseTestTypeParser= Class(TTestParser)
  private
    FType : TPasType;
    FHint : string;
    FErrorSource : String;
  Protected
    Function ParseType(ASource : String; ATypeClass : TClass;Const AHint : String = '') : TPasType; virtual; overload;
    Procedure AssertParseTypeError(ASource : String);
    Property TheType : TPasType Read FType;
    Property Hint : string Read FHint Write FHint;
    procedure SetUp; override;
    Procedure TearDown; override;
  end;

  { TTestTypeParser }

  TTestTypeParser = Class(TBaseTestTypeParser)
  private
  Protected
    Procedure DoTestAliasType(Const AnAliasType : String; Const AHint : String);
    procedure DoTestStringType(const AnAliasType: String; const AHint: String);
    procedure DoTypeError(Const AMsg,ASource : string);
    Procedure DoParseError;
    Procedure DoParsePointer(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
    Procedure DoParseArray(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
    Procedure DoParseEnumerated(Const ASource : String; Const AHint : String; ACount : integer);
    Procedure DoTestFileType(Const AType : String; Const AHint : String; ADestType : TClass = Nil);
    Procedure DoTestRangeType(Const AStart,AStop,AHint : String);
    Procedure DoParseSimpleSet(Const ASource : String; Const AHint : String);
    Procedure DoParseComplexSet(Const ASource : String; Const AHint : String);
    procedure DoParseRangeSet(const ASource: String; const AHint: String);
    Procedure DoTestComplexSet;
    Procedure DoTestClassOf(Const AHint : string);
  Published
    Procedure TestAliasType;
    Procedure TestCrossUnitAliasType;
    Procedure TestAliasTypeDeprecated;
    Procedure TestAliasTypePlatform;
    Procedure TestSimpleTypeByte;
    Procedure TestSimpleTypeByteDeprecated;
    Procedure TestSimpleTypeBytePlatform;
    Procedure TestSimpleTypeBoolean;
    Procedure TestSimpleTypeBooleanDeprecated;
    Procedure TestSimpleTypeBooleanPlatform;
    Procedure TestSimpleTypeChar;
    Procedure TestSimpleTypeCharDeprecated;
    Procedure TestSimpleTypeCharPlatform;
    Procedure TestSimpleTypeInteger;
    Procedure TestSimpleTypeIntegerDeprecated;
    Procedure TestSimpleTypeIntegerPlatform;
    Procedure TestSimpleTypeInt64;
    Procedure TestSimpleTypeInt64Deprecated;
    Procedure TestSimpleTypeInt64Platform;
    Procedure TestSimpleTypeLongInt;
    Procedure TestSimpleTypeLongIntDeprecated;
    Procedure TestSimpleTypeLongIntPlatform;
    Procedure TestSimpleTypeLongWord;
    Procedure TestSimpleTypeLongWordDeprecated;
    Procedure TestSimpleTypeLongWordPlatform;
    Procedure TestSimpleTypeDouble;
    Procedure TestSimpleTypeDoubleDeprecated;
    Procedure TestSimpleTypeDoublePlatform;
    Procedure TestSimpleTypeShortInt;
    Procedure TestSimpleTypeShortIntDeprecated;
    Procedure TestSimpleTypeShortIntPlatform;
    Procedure TestSimpleTypeSmallInt;
    Procedure TestSimpleTypeSmallIntDeprecated;
    Procedure TestSimpleTypeSmallIntPlatform;
    Procedure TestSimpleTypeString;
    Procedure TestSimpleTypeStringDeprecated;
    Procedure TestSimpleTypeStringPlatform;
    Procedure TestSimpleTypeStringSize;
    Procedure TestSimpleTypeStringSizeIncomplete;
    Procedure TestSimpleTypeStringSizeWrong;
    Procedure TestSimpleTypeStringSizeDeprecated;
    Procedure TestSimpleTypeStringSizePlatform;
    Procedure TestSimpleTypeWord;
    Procedure TestSimpleTypeWordDeprecated;
    Procedure TestSimpleTypeWordPlatform;
    Procedure TestSimpleTypeQWord;
    Procedure TestSimpleTypeQWordDeprecated;
    Procedure TestSimpleTypeQWordPlatform;
    Procedure TestSimpleTypeCardinal;
    Procedure TestSimpleTypeCardinalDeprecated;
    Procedure TestSimpleTypeCardinalPlatform;
    Procedure TestSimpleTypeWideChar;
    Procedure TestSimpleTypeWideCharDeprecated;
    Procedure TestSimpleTypeWideCharPlatform;
    Procedure TestPointerSimple;
    procedure TestPointerSimpleDeprecated;
    procedure TestPointerSimplePlatform;
    Procedure TestStaticArray;
    procedure TestStaticArrayDeprecated;
    procedure TestStaticArrayPlatform;
    Procedure TestStaticArrayPacked;
    Procedure TestStaticArrayTypedIndex;
    Procedure TestDynamicArray;
    Procedure TestSimpleEnumerated;
    Procedure TestSimpleEnumeratedDeprecated;
    Procedure TestSimpleEnumeratedPlatform;
    Procedure TestAssignedEnumerated;
    Procedure TestAssignedEnumeratedDeprecated;
    Procedure TestAssignedEnumeratedPlatform;
    Procedure TestFileType;
    Procedure TestFileTypeDeprecated;
    Procedure TestFileTypePlatform;
    Procedure TestRangeType;
    Procedure TestRangeTypeDeprecated;
    Procedure TestRangeTypePlatform;
    Procedure TestIdentifierRangeType;
    Procedure TestIdentifierRangeTypeDeprecated;
    Procedure TestIdentifierRangeTypePlatform;
    Procedure TestNegativeIdentifierRangeType;
    Procedure TestSimpleSet;
    Procedure TestSimpleSetDeprecated;
    Procedure TestSimpleSetPlatform;
    Procedure TestComplexSet;
    Procedure TestComplexSetDeprecated;
    Procedure TestComplexSetPlatform;
    Procedure TestRangeSet;
    Procedure TestRangeSetDeprecated;
    Procedure TestRangeSetPlatform;
    Procedure TestClassOf;
    Procedure TestClassOfDeprecated;
    Procedure TestClassOfPlatform;
    Procedure TestReferenceAlias;
    Procedure TestReferenceSet;
    Procedure TestReferenceClassOf;
    Procedure TestReferenceFile;
    Procedure TestReferenceArray;
    Procedure TestReferencePointer;
  end;

  { TTestRecordTypeParser }

  TTestRecordTypeParser= Class(TBaseTestTypeParser)
  private
    Function GetField(AIndex : Integer; R : TPasRecordType) : TPasVariable;
    Function GetField(AIndex : Integer; R : TPasVariant) : TPasVariable;
    function GetF(AIndex: Integer): TPasVariable;
    function GetR: TPasRecordType;
    Function GetVariant(AIndex : Integer; R : TPasRecordType) : TPasVariant;
    function GetV(AIndex: Integer): TPasVariant;
  Protected
    Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
    procedure AssertVariantSelector(AName, AType: string);
    procedure AssertField1(Hints: TPasMemberHints);
    procedure AssertField2(Hints: TPasMemberHints);
    procedure AssertVariant1(Hints: TPasMemberHints);
    procedure AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
    procedure AssertVariant2(Hints: TPasMemberHints);
    procedure AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
    procedure AssertOneIntegerField(Hints: TPasMemberHints);
    procedure AssertTwoIntegerFields(Hints1, Hints2: TPasMemberHints);
    procedure AssertRecordField(AIndex: Integer;Hints: TPasMemberHints);
    procedure AssertRecordVariant(AIndex: Integer;Hints: TPasMemberHints; VariantLabels : Array of string);
    Procedure AssertRecordVariantVariant(AIndex: Integer;Const AFieldName,ATypeName: string;Hints: TPasMemberHints; VariantLabels : Array of string);
    Procedure DoTestEmpty(Const AHint : String);
    procedure DoTestDeprecatedVariantNoStorage(Const AHint : string);
    procedure DoTestDeprecatedVariantStorage(Const AHint : string);
    procedure DoTestVariantNoStorage(Const AHint : string);
    procedure DoTestVariantStorage(Const AHint : string);
    procedure DoTestTwoVariantsNoStorage(Const AHint : string);
    procedure DoTestTwoVariantsStorage(Const AHint : string);
    procedure DoTestTwoVariantsFirstDeprecatedStorage(Const AHint : string);
    procedure DoTestTwoVariantsSecondDeprecatedStorage(Const AHint : string);
    Procedure DoTestVariantTwoLabels(Const AHint : string);
    Procedure DoTestTwoVariantsTwoLabels(Const AHint : string);
    procedure DoTestVariantNestedRecord(Const AHint : string);
    procedure DoTestVariantNestedVariant(Const AHint : string);
    procedure DoTestVariantNestedVariantFirstDeprecated(Const AHint : string);
    procedure DoTestVariantNestedVariantSecondDeprecated(const AHint: string);
    procedure DoTestVariantNestedVariantBothDeprecated(const AHint: string);
    Property TheRecord : TPasRecordType Read GetR;
    Property Field1 : TPasVariable Index 0 Read GetF;
    Property Field2 : TPasVariable Index 1 Read GetF;
    Property Variant1 : TPasVariant Index 0 Read GetV;
    Property Variant2 : TPasVariant Index 1 Read GetV;
  Published
    Procedure TestEmpty;
    Procedure TestEmptyDeprecated;
    Procedure TestEmptyPlatform;
    Procedure TestOneField;
    Procedure TestOneFieldDeprecated;
    Procedure TestOneFieldPlatform;
    Procedure TestOneFieldSemicolon;
    Procedure TestOneFieldSemicolonDeprecated;
    Procedure TestOneFieldSemicolonPlatform;
    Procedure TestOneDeprecatedField;
    Procedure TestOneDeprecatedFieldDeprecated;
    Procedure TestOneDeprecatedFieldPlatform;
    Procedure TestOnePlatformField;
    Procedure TestOnePlatformFieldDeprecated;
    Procedure TestOnePlatformFieldPlatform;
    Procedure TestTwoFields;
    Procedure TestTwoFieldDeprecated;
    Procedure TestTwoFieldPlatform;
    Procedure TestTwoFieldsFirstDeprecated;
    Procedure TestTwoFieldsFirstDeprecatedDeprecated;
    Procedure TestTwoFieldsFirstDeprecatedPlatform;
    Procedure TestTwoFieldsSecondDeprecated;
    Procedure TestTwoFieldsSecondDeprecatedDeprecated;
    Procedure TestTwoFieldsSecondDeprecatedPlatform;
    Procedure TestTwoFieldsBothDeprecated;
    Procedure TestTwoFieldsBothDeprecatedDeprecated;
    Procedure TestTwoFieldsBothDeprecatedPlatform;
    Procedure TestTwoFieldsCombined;
    Procedure TestTwoFieldsCombinedDeprecated;
    Procedure TestTwoFieldsCombinedPlatform;
    Procedure TestTwoDeprecatedFieldsCombined;
    Procedure TestTwoDeprecatedFieldsCombinedDeprecated;
    Procedure TestTwoDeprecatedFieldsCombinedPlatform;
    Procedure TestNested;
    Procedure TestNestedDeprecated;
    Procedure TestNestedPlatform;
    procedure TestNestedSemicolon;
    procedure TestNestedSemicolonDeprecated;
    procedure TestNestedSemicolonPlatform;
    procedure TestNestedFirst;
    procedure TestNestedFirstDeprecated;
    procedure TestNestedFirstPlatform;
    Procedure TestDeprecatedNested;
    Procedure TestDeprecatedNestedDeprecated;
    Procedure TestDeprecatedNestedPlatform;
    procedure TestDeprecatedNestedFirst;
    procedure TestDeprecatedNestedFirstDeprecated;
    procedure TestDeprecatedNestedFirstPlatform;
    Procedure TestVariantNoStorage;
    procedure TestVariantNoStorageDeprecated;
    procedure TestVariantNoStoragePlatform;
    Procedure TestVariantStorage;
    procedure TestVariantStorageDeprecated;
    procedure TestVariantStoragePlatform;
    Procedure TestDeprecatedVariantNoStorage;
    procedure TestDeprecatedVariantNoStorageDeprecated;
    procedure TestDeprecatedVariantNoStoragePlatform;
    Procedure TestDeprecatedVariantStorage;
    procedure TestDeprecatedVariantStorageDeprecated;
    procedure TestDeprecatedVariantStoragePlatform;
    Procedure TestTwoVariantsNoStorage;
    procedure TestTwoVariantsNoStorageDeprecated;
    procedure TestTwoVariantsNoStoragePlatform;
    Procedure TestTwoVariantsStorage;
    procedure TestTwoVariantsStorageDeprecated;
    procedure TestTwoVariantsStoragePlatform;
    Procedure TestTwoVariantsFirstDeprecatedStorage;
    procedure TestTwoVariantsFirstDeprecatedStorageDeprecated;
    procedure TestTwoVariantsFirstDeprecatedStoragePlatform;
    Procedure TestTwoVariantsSecondDeprecatedStorage;
    procedure TestTwoVariantsSecondDeprecatedStorageDeprecated;
    procedure TestTwoVariantsSecondDeprecatedStoragePlatform;
    Procedure TestVariantTwoLabels;
    Procedure TestVariantTwoLabelsDeprecated;
    Procedure TestVariantTwoLabelsPlatform;
    Procedure TestTwoVariantsTwoLabels;
    Procedure TestTwoVariantsTwoLabelsDeprecated;
    Procedure TestTwoVariantsTwoLabelsPlatform;
    Procedure TestVariantNestedRecord;
    Procedure TestVariantNestedRecordDeprecated;
    Procedure TestVariantNestedRecordPlatform;
    Procedure TestVariantNestedVariant;
    Procedure TestVariantNestedVariantDeprecated;
    Procedure TestVariantNestedVariantPlatForm;
    Procedure TestVariantNestedVariantFirstDeprecated;
    Procedure TestVariantNestedVariantFirstDeprecatedDeprecated;
    Procedure TestVariantNestedVariantFirstDeprecatedPlatform;
    Procedure TestVariantNestedVariantSecondDeprecated;
    Procedure TestVariantNestedVariantSecondDeprecatedDeprecated;
    Procedure TestVariantNestedVariantSecondDeprecatedPlatform;
    Procedure TestVariantNestedVariantBothDeprecated;
    Procedure TestVariantNestedVariantBothDeprecatedDeprecated;
    Procedure TestVariantNestedVariantBothDeprecatedPlatform;
  end;

  { TTestProcedureTypeParser }
  TCallingConventionTest = Procedure (CC : TCallingConvention;Const AHint : String) of object;

  TTestProcedureTypeParser = Class(TBaseTestTypeParser)
  Private
    FProc : TPasProcedureType;
    procedure CheckArrayOfConstArgument(Aindex: Integer; Ac: TArgumentAccess);
  Protected
    procedure DoTestFunction(CC: TCallingConvention; const AHint: String);
    procedure DoTestFunctionOfObject(CC: TCallingConvention; const AHint: String);
    procedure DoTestFunctionOneArg(CC: TCallingConvention; const AHint: String);
    procedure DoTestFunctionOneArgOfObject(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOfObject(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOfObjectOneArg(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureIsNested(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureIsNestedOneArg(CC: TCallingConvention; const AHint: String);
    procedure CheckOpenArrayArgument(Ac: TArgumentAccess);
    procedure DoTestProcedureArrayOfConst(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOpenArray(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureConstOpenArray(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureVarOpenArray(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOutOpenArray(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOneArgDefault(CC: TCallingConvention;const AHint: String);
    procedure DoTestProcedureOneArgDefaultExpr(CC: TCallingConvention;const AHint: String);
    procedure DoTestProcedureOneArgDefaultSet(CC: TCallingConvention;const AHint: String);
    procedure DoTestProcedureOneConstArgDefault(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOneVarArgDefault(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureOneOutArgDefault(CC: TCallingConvention; const AHint: String);
    function CheckArgument(AIndex : Integer; Const AName,ATypeName : String; AAccess : TArgumentAccess) : TPasArgument;
    Function ParseType(ASource : String; CC : TCallingConvention; ATypeClass : TClass;Const AHint : String = '') : TPasProcedureType; virtual; overload;
    Procedure DoTestProcedureDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureOneArgDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureOneVarArgDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureOneConstArgDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureOneOutArgDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoVarArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoConstArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoOutArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoCombinedArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoCombinedVarArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoCombinedConstArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureTwoCombinedOutArgsDecl(CC : TCallingConvention; Const AHint : String);
    Procedure DoTestProcedureDefaultConstArgsDecl(CC : TCallingConvention; Const AHint : String);
    procedure DoTestProcedureUntypedArgDecl(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureUntypedConstArgDecl(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureUntypedOutArgDecl(CC: TCallingConvention; const AHint: String);
    procedure DoTestProcedureUntypedDefArg;
    Procedure TestCallingConventions(Proc : TCallingConventionTest; Const AHint : String);
    Procedure TestCallingConventions(Proc : TCallingConventionTest);
    Function FuncProc : TPasFunctionType;
    Property Proc : TPasProcedureType Read FProc;
  Published
    Procedure TestProcedure;
    Procedure TestProcedureOneArg;
    Procedure TestProcedureOneVarArg;
    Procedure TestProcedureOneConstArg;
    Procedure TestProcedureOneOutArg;
    Procedure TestProcedureTwoArgs;
    Procedure TestProcedureTwoVarArgs;
    Procedure TestProcedureTwoConstArgs;
    Procedure TestProcedureTwoOutArgs;
    Procedure TestProcedureTwoCombinedArgs;
    Procedure TestProcedureTwoCombinedVarArgs;
    Procedure TestProcedureTwoCombinedConstArgs;
    Procedure TestProcedureTwoCombinedOutArgs;
    Procedure TestProcedureDefaultConstArgs;
    Procedure TestProcedureUntypedArg;
    Procedure TestProcedureUntypedConstArg;
    Procedure TestProcedureUntypedOutArg;
    Procedure TestProcedureUntypedDefArg;
    Procedure TestProcedureOneArgDefault;
    Procedure TestProcedureOneArgDefaultExpr;
    Procedure TestProcedureOneArgDefaultSet;
    Procedure TestProcedureOneVarArgDefault;
    Procedure TestProcedureOneConstArgDefault;
    Procedure TestProcedureOneOutArgDefault;
    Procedure TestProcedureNoMultiArgDefaults;
    Procedure TestProcedureOpenArray;
    Procedure TestProcedureConstOpenArray;
    Procedure TestProcedureOutOpenArray;
    Procedure TestProcedureVarOpenArray;
    Procedure TestProcedureArrayOfConst;
    Procedure TestProcedureOfObject;
    Procedure TestProcedureOfObjectOneArg;
    Procedure TestProcedureIsNested;
    Procedure TestProcedureIsNesteOneArg;
    Procedure TestFunction;
    Procedure TestFunctionOneArg;
    Procedure TestFunctionOfObject;
    Procedure TestFunctionOneArgOfObject;
  end;



implementation

uses typinfo;



{ TTestProcedureTypeParser }

procedure TTestProcedureTypeParser.DoTestProcedureUntypedArgDecl(
  CC: TCallingConvention; const AHint: String);

Var
  A : TPasArgument;

begin
  ParseType('procedure(var A)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','',argVar);
  AssertNull('No argument type', A.ArgType)
end;

procedure TTestProcedureTypeParser.DoTestProcedureUntypedConstArgDecl(
  CC: TCallingConvention; const AHint: String);

Var
  A : TPasArgument;

begin
  ParseType('procedure(const A)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','',argConst);
  AssertNull('No argument type', A.ArgType)
end;

procedure TTestProcedureTypeParser.DoTestProcedureUntypedOutArgDecl(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;

begin
  ParseType('procedure(out A)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','',argOut);
  AssertNull('No argument type', A.ArgType)
end;

procedure TTestProcedureTypeParser.DoTestProcedureUntypedDefArg;
begin
  ParseType('procedure(A)',ccdefault,TPasProcedureType,'');
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDefault(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;

begin
  ParseType('procedure(var A : Integer = 1)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','Integer',argVar);
  AssertNotNull('have default argument type', A.Value);
  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDefault(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;

begin
  ParseType('procedure(out A : Integer = 1)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','Integer',argOut);
  AssertNotNull('have default argument type', A.Value);
  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDefault(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;

begin
  ParseType('procedure(const A : Integer = 1)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','Integer',argConst);
  AssertNotNull('have default argument type', A.Value);
  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
end;

procedure TTestProcedureTypeParser.DoTestProcedureArrayOfConst(
  CC: TCallingConvention; const AHint: String);

begin
  ParseType('procedure(A : Array of const)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArrayOfConstArgument(0,argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOfObject(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure of Object',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',0,Proc.Args.Count);
  AssertEquals('Is OF Object',True,Proc.IsOfObject);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOfObjectOneArg(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure (A : integer)of Object',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  AssertEquals('Is OF Object',True,Proc.IsOfObject);
  CheckArgument(0,'A','Integer',argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureIsNested(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure is nested',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',0,Proc.Args.Count);
  AssertEquals('Is nested',True,Proc.IsNested);
end;

procedure TTestProcedureTypeParser.DoTestProcedureIsNestedOneArg(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure (A : integer) is nested',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  AssertEquals('Is nested',True,Proc.IsNested);
  CheckArgument(0,'A','Integer',argDefault);
end;


procedure TTestProcedureTypeParser.CheckArrayOfConstArgument(Aindex : Integer; Ac : TArgumentAccess);
Var
  A : TPasArgument;
  T : TPasArrayType;

begin
  A:=CheckArgument(Aindex,'A','',ac);
  AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
  T:=A.ArgType as TPasArrayType;
  AssertNull('Have Element type',T.ElType);
end;

procedure TTestProcedureTypeParser.DoTestFunction(CC: TCallingConvention;
  const AHint: String);
begin
  ParseType('function : integer',CC,TPasFunctionType,AHint);
  AssertEquals('Argument count',0,Proc.Args.Count);
  AssertEquals('Is OF Object',False,Proc.IsOfObject);
  AssertNotNull('Have result',FuncProc.ResultEl);
  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
end;

procedure TTestProcedureTypeParser.DoTestFunctionOfObject(CC: TCallingConvention;
  const AHint: String);
begin
  ParseType('function : integer of object',CC,TPasFunctionType,AHint);
  AssertEquals('Argument count',0,Proc.Args.Count);
  AssertEquals('Is OF Object',True,Proc.IsOfObject);
  AssertNotNull('Have result',FuncProc.ResultEl);
  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
end;

procedure TTestProcedureTypeParser.DoTestFunctionOneArg(CC: TCallingConvention;
  const AHint: String);
begin
  ParseType('function (A : Integer) : Integer',CC,TPasFunctionType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argDefault);
  AssertNotNull('Have result',FuncProc.ResultEl);
  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
end;

procedure TTestProcedureTypeParser.DoTestFunctionOneArgOfObject(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('function (A : Integer) : Integer of object',CC,TPasFunctionType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  AssertEquals('Is OF Object',True,Proc.IsOfObject);
  CheckArgument(0,'A','Integer',argDefault);
  AssertNotNull('Have result',FuncProc.ResultEl);
  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
end;

procedure TTestProcedureTypeParser.CheckOpenArrayArgument(Ac : TArgumentAccess);
Var
  A : TPasArgument;
  T : TPasArrayType;

begin
  A:=CheckArgument(0,'A','',ac);
  AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
  T:=A.ArgType as TPasArrayType;
  AssertNotNull('Have Element type',T.ElType);
  AssertEquals('Element type',TPasUnresolvedTypeRef,T.ElType.ClassType);
  AssertEquals('Element type name','Integer',TPasUnresolvedTypeRef(T.ElType).Name);
  AssertEquals('No boundaries','',T.IndexRange);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOpenArray(
  CC: TCallingConvention; const AHint: String);

begin
  ParseType('procedure(A : Array of integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckOpenArrayArgument(argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureConstOpenArray(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(const A : Array of integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckOpenArrayArgument(argConst);
end;

procedure TTestProcedureTypeParser.DoTestProcedureVarOpenArray(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(var A : Array of integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckOpenArrayArgument(argVar);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOutOpenArray(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(out A : Array of integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckOpenArrayArgument(argOut);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefault(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;

begin
  ParseType('procedure(A : Integer = 1)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','Integer',argDefault);
  AssertNotNull('have default argument type', A.ValueExpr);
  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  AssertEquals('argument expr value', '1', TPrimitiveExpr(A.ValueExpr).Value);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultExpr(
  CC: TCallingConvention; const AHint: String);

Var
  A : TPasArgument;
  B : TBinaryExpr;

begin
  ParseType('procedure(A : Integer = 1+2)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','Integer',argDefault);
  AssertNotNull('have default argument type', A.ValueExpr);
  AssertEquals('argument expr type', TBinaryExpr, A.ValueExpr.ClassType);
  B:=TBinaryExpr(A.ValueExpr);
  AssertNotNull('have left expr', B.Left);
  AssertEquals('argument left expr type', TPrimitiveExpr, B.left.ClassType);
  AssertEquals('argument left expr value', '1', TPrimitiveExpr(B.Left).Value);
  AssertNotNull('have right expr', B.Right);
  AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType);
  AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet(
  CC: TCallingConvention; const AHint: String);
Var
  A : TPasArgument;
  B : TParamsExpr;

begin
  ParseType('procedure(A : TB = [])',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  A:=CheckArgument(0,'A','TB',argDefault);
  AssertNotNull('have default argument type', A.ValueExpr);
  AssertEquals('argument expr type', TParamsExpr, A.ValueExpr.ClassType);
  B:=TParamsExpr(A.ValueExpr);
  AssertEquals('No params',0,Length(B.Params));
end;

Function TTestProcedureTypeParser.CheckArgument(AIndex: Integer; const AName,
  ATypeName: String; AAccess: TArgumentAccess) : TPAsArgument;
Var
  A : TPasArgument;
  C : String;
begin
  C:='Argument '+IntToStr(AIndex)+' : ';
  AssertNotNull(C+'assigned',Proc.Args[AIndex]);
  AssertEquals(C+'class',TPasArgument,TObject(Proc.Args[AIndex]).ClassType);
  A:=TPasArgument(Proc.Args[AIndex]);
  AssertEquals(C+'Access',AAccess,A.Access);
  AssertEquals(C+'name',AName,A.Name);
  if (ATypeName<>'') then
    begin
    AssertNotNull(C+'type assigned',A.ArgType);
    if (ATypeName[1]='[') then
      AssertEquals(C+'type classname',LowerCase(Copy(ATypeName,2,Length(ATypeName)-2)),LowerCase(A.ArgType.ClassName))
    else
      AssertEquals(C+'type name',ATypeName,A.ArgType.Name);
    end;
  Result:=A;
end;

function TTestProcedureTypeParser.ParseType(ASource: String;
  CC: TCallingConvention; ATypeClass: TClass; const AHint: String): TPasProcedureType;
begin
  if CC=ccdefault then
    Result:=TPasProcedureType(ParseType(ASource,ATypeClass,AHint))
  else
    begin
    if (AHint<>'') then
      Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC]+';',ATypeClass,AHint))
    else
      Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC],ATypeClass,AHint));
    end;
  FProc:=Result;
  AssertEquals('Correct calling convention for procedural type',cc,Result.CallingConvention);
end;

procedure TTestProcedureTypeParser.DoTestProcedureDecl(CC: TCallingConvention; Const AHint : String);

begin
  ParseType('procedure',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',0,Proc.Args.Count);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneArgDecl(
  CC: TCallingConvention; const AHint: String);

begin
  ParseType('procedure(A : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(var A : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argVar);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(const A : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argConst);
end;

procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(out A : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',1,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argOut);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(A : Integer;B : String)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argDefault);
  CheckArgument(1,'B','[TPasAliasType]',argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoVarArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(Var A : Integer;Var B : String)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argVar);
  CheckArgument(1,'B','[TPasAliasType]',argVar);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoConstArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(const A : Integer;Const B : String)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argConst);
  CheckArgument(1,'B','[TPasAliasType]',argConst);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoOutArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(out A : Integer;Out B : String)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argOut);
  CheckArgument(1,'B','[TPasAliasType]',argOut);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(A,B : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argDefault);
  CheckArgument(1,'B','Integer',argDefault);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedVarArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(Var A,B : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argVar);
  CheckArgument(1,'B','Integer',argVar);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedConstArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(Const A,B : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argConst);
  CheckArgument(1,'B','Integer',argConst);
end;

procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedOutArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(Out A,B : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argOut);
  CheckArgument(1,'B','Integer',argOut);
end;

procedure TTestProcedureTypeParser.DoTestProcedureDefaultConstArgsDecl(
  CC: TCallingConvention; const AHint: String);
begin
  ParseType('procedure(A : Integer; Const B : Integer)',CC,TPasProcedureType,AHint);
  AssertEquals('Argument count',2,Proc.Args.Count);
  CheckArgument(0,'A','Integer',argDefault);
  CheckArgument(1,'B','Integer',argConst);
end;

procedure TTestProcedureTypeParser.TestCallingConventions(
  Proc: TCallingConventionTest; Const AHint : String);

Var
  CC : TCallingConvention;

begin
  For cc:=ccDefault to High(TCallingConvention) do
    begin
    if CC<>ccDefault then
      Setup;
    try
      Proc(cc,AHint);
    finally
      tearDown;
    end;
    end;
end;

procedure TTestProcedureTypeParser.TestCallingConventions(
  Proc: TCallingConventionTest);
begin
  TestCallingConventions(Proc,'');
  Setup;
  TestCallingConventions(Proc,'deprecated');
  Setup;
  TestCallingConventions(Proc,'platform');
end;

function TTestProcedureTypeParser.FuncProc: TPasFunctionType;
begin
  Result:=Proc as TPasFunctionType;
end;

procedure TTestProcedureTypeParser.TestProcedure;
begin
  TestCallingConventions(@DoTestProcedureDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureOneArg;
begin
  TestCallingConventions(@DoTestProcedureOneArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureOneVarArg;
begin
  TestCallingConventions(@DoTestProcedureOneVarArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureOneConstArg;
begin
  TestCallingConventions(@DoTestProcedureOneConstArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureOneOutArg;
begin
  TestCallingConventions(@DoTestProcedureOneOutArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoVarArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoVarArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoConstArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoConstArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoOutArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoOutArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoCombinedArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoCombinedArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoCombinedVarArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoCombinedVarArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoCombinedConstArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoCombinedConstArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureTwoCombinedOutArgs;
begin
  TestCallingConventions(@DoTestProcedureTwoCombinedOutArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureDefaultConstArgs;
begin
  TestCallingConventions(@DoTestProcedureDefaultConstArgsDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureUntypedArg;
begin
  TestCallingConventions(@DoTestProcedureUntypedArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureUntypedConstArg;
begin
  TestCallingConventions(@DoTestProcedureUntypedConstArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureUntypedOutArg;
begin
  TestCallingConventions(@DoTestProcedureUntypedOutArgDecl);
end;

procedure TTestProcedureTypeParser.TestProcedureUntypedDefArg;
begin
  AssertException('No untyped arg by value',EParserError,@DoTestProcedureUntypedDefArg)
end;

procedure TTestProcedureTypeParser.TestProcedureOneArgDefault;
begin
  TestCallingConventions(@DoTestProcedureOneArgDefault);
end;

procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultExpr;
begin
  TestCallingConventions(@DoTestProcedureOneArgDefaultExpr);
end;

procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultSet;
begin
  TestCallingConventions(@DoTestProcedureOneArgDefaultSet);
end;

procedure TTestProcedureTypeParser.TestProcedureOneVarArgDefault;
begin
  TestCallingConventions(@DoTestProcedureOneVarArgDefault);
end;

procedure TTestProcedureTypeParser.TestProcedureOneConstArgDefault;
begin
  TestCallingConventions(@DoTestProcedureOneConstArgDefault);
end;

procedure TTestProcedureTypeParser.TestProcedureOneOutArgDefault;
begin
  TestCallingConventions(@DoTestProcedureOneOutArgDefault);
end;

procedure TTestProcedureTypeParser.TestProcedureNoMultiArgDefaults;
begin
  AssertParseTypeError('procedure (A,B : Integer = 1)');
end;

procedure TTestProcedureTypeParser.TestProcedureOpenArray;
begin
  TestCallingConventions(@DoTestProcedureOpenArray);
end;

procedure TTestProcedureTypeParser.TestProcedureConstOpenArray;
begin
  TestCallingConventions(@DoTestProcedureConstOpenArray);
end;

procedure TTestProcedureTypeParser.TestProcedureOutOpenArray;
begin
  TestCallingConventions(@DoTestProcedureVarOpenArray);
end;

procedure TTestProcedureTypeParser.TestProcedureVarOpenArray;
begin
  TestCallingConventions(@DoTestProcedureOutOpenArray);
end;

procedure TTestProcedureTypeParser.TestProcedureArrayOfConst;
begin
  TestCallingConventions(@DoTestProcedureArrayOfConst);
end;

procedure TTestProcedureTypeParser.TestProcedureOfObject;
begin
  TestCallingConventions(@DoTestProcedureOfObject);
end;

procedure TTestProcedureTypeParser.TestProcedureOfObjectOneArg;
begin
  TestCallingConventions(@DoTestProcedureOfObjectOneArg);
end;

procedure TTestProcedureTypeParser.TestProcedureIsNested;
begin
  TestCallingConventions(@DoTestProcedureIsNested);
end;

procedure TTestProcedureTypeParser.TestProcedureIsNesteOneArg;
begin
  TestCallingConventions(@DoTestProcedureIsNestedOneArg);
end;

procedure TTestProcedureTypeParser.TestFunction;
begin
  TestCallingConventions(@DoTestFunction);
end;

procedure TTestProcedureTypeParser.TestFunctionOneArg;
begin
  TestCallingConventions(@DoTestFunctionOneArg);
end;

procedure TTestProcedureTypeParser.TestFunctionOfObject;
begin
  TestCallingConventions(@DoTestFunctionOfObject);
end;

procedure TTestProcedureTypeParser.TestFunctionOneArgOfObject;
begin
  TestCallingConventions(@DoTestFunctionOneArgOfObject);

end;

{ TTestRecordTypeParser }

function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasRecordType
  ): TPasVariable;
begin
  AssertNotNull(R);
  AssertNotNull(R.Members);
  AssertTrue('Have AIndex elements',R.Members.Count>AIndex);
  AssertEquals('Correct class in member',TPasVariable,TObject(R.Members[AIndex]).ClassType);
  Result:=TPasVariable(R.Members[AIndex]);
end;

function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasVariant
  ): TPasVariable;
begin
  AssertNotNull(R);
  AssertNotNull('Have variant members', R.Members);
  AssertNotNull('Have variant members member list',R.Members.Members);
  AssertTrue('Have AIndex elements',R.Members.Members.Count>AIndex);
  AssertEquals('Correct class in member',TPasVariable,TObject(R.Members.members[AIndex]).ClassType);
  Result:=TPasVariable(R.Members.Members[AIndex]);
end;

function TTestRecordTypeParser.GetF(AIndex: Integer): TPasVariable;
begin
  Result:=GetField(AIndex,GetR);
end;

function TTestRecordTypeParser.GetR: TPasRecordType;
begin
  Result:=TheType as TPasRecordType;
end;

function TTestRecordTypeParser.GetVariant(AIndex: Integer; R: TPasRecordType
  ): TPasVariant;
begin
  AssertNotNull(R);
  AssertNotNull(R.Variants);
  AssertTrue('Have AIndex variant elements',R.Variants.Count>AIndex);
  AssertEquals('Correct class in variant',TPasVariant,TObject(R.Variants[AIndex]).ClassType);
  Result:=TPasVariant(R.Variants[AIndex]);
end;

function TTestRecordTypeParser.GetV(AIndex: Integer): TPasVariant;
begin
  Result:=GetVariant(AIndex,GetR);
end;

procedure TTestRecordTypeParser.TestFields(const Fields: array of string;
  AHint: String; HaveVariant: Boolean);

Var
  S : String;
  I : integer;

begin
  S:='';
  For I:=Low(Fields) to High(Fields) do
    begin
    if (S<>'') then
      S:=S+sLineBreak;
    S:=S+'    '+Fields[i];
    end;
  if (S<>'') then
    S:=S+sLineBreak;
  S:='record'+sLineBreak+s+'  end';
  ParseType(S,TPasRecordType,AHint);
  if HaveVariant then
    begin
    AssertNotNull('Have variants',TheRecord.Variants);
    AssertNotNull('Have variant type',TheRecord.VariantType);
    end
  else
    begin
    AssertNull('No variants',TheRecord.Variants);
    AssertNull('No variant type',TheRecord.VariantType);
    AssertEquals('No variant name','',TheRecord.VariantName);
    end;
end;

procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);

begin
  if (AType='') then
    AType:='Integer';
  AssertEquals('Have variant selector storage name',AName,TheRecord.VariantName);
  AssertNotNull('Have variant selector type',TheRecord.VariantType);
  AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantType.ClassType);
  AssertEquals('Have variant selector type name',AType,TheRecord.VariantType.Name);
end;


procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
begin
  TestFields([],AHint);
  AssertNotNull('Have members array',TheRecord.Members);
  AssertEquals('Zero members in array',0,TheRecord.Members.Count);
end;

procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints);
begin
  AssertVariant1(Hints,['0']);
end;


procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);

Var
  I : Integer;

begin
  AssertNotNull('Have variant 1',Variant1);
  AssertNotNull('Variant 1 has Values ',Variant1.Values);
  if Length(VariantLabels)=0 then
    begin
    AssertEquals('Have 1 value',1,Variant1.Values.Count);
    AssertNotNull('Assigned value',Variant1.Values[0]);
    AssertEquals('Expression',TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
    AssertExpression('First value is 0',TPasExpr(Variant1.Values[0]),pekNumber,'0');
    end
  else
    begin
    AssertEquals('Have correct number of values',Length(VariantLabels),Variant1.Values.Count);
    For I:=0 to Length(VariantLabels)-1 do
      begin
      AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
      AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
      end;
    end;
  AssertNotNull('Have members',Variant1.Members);
  AssertNotNull('Have member members',Variant1.Members.Members);
  AssertNotNull('member 0 not null',Variant1.Members.Members[0]);
  AssertEquals('Member 0 has correct name',TPasVariable,TObject(Variant1.Members.Members[0]).ClassType);
  AssertEquals('Member 0 has correct name','y',TPasVariable(Variant1.Members.Members[0]).Name);
  AssertNotNull('member 0 has not null type',TPasVariable(Variant1.Members.Members[0]).VarType);
  AssertEquals('member 0 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant1.Members.Members[0]).VarType.ClassType);
  AssertEquals('member 0 has correct type name','Integer',TPasVariable(Variant1.Members.Members[0]).VarType.Name);
  AssertTrue('Field 1 hints match',TPasVariable(Variant1.Members.Members[0]).Hints=Hints)
end;

procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints);
begin
  AssertVariant2(Hints,['1']);
end;

procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);

Var
  I : Integer;

begin
  AssertNotNull('Have variant 2',Variant2);
  AssertNotNull('Variant 2 has Values ',Variant2.Values);
  if Length(VariantLabels)=0 then
    begin
    AssertEquals('Variant 2 has 1 value',2,Variant2.Values.Count);
    AssertEquals('Expression',TPrimitiveExpr,TObject(Variant2.Values[0]).CLassType);
    AssertExpression('First value is 1',TPasExpr(Variant2.Values[0]),pekNumber,'1');
    end
  else
    begin
    AssertEquals('Variant 2 Has correct number of values',Length(VariantLabels),Variant2.Values.Count);
    For I:=0 to Length(VariantLabels)-1 do
      begin
      AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant2.Values[I]).CLassType);
      AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant2.Values[I]),pekNumber,VariantLabels[i]);
//      AssertEquals(Format('Variant 2, Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant2.Values[I]);
      end;
    end;
  AssertNotNull('Have members',Variant2.Members);
  AssertNotNull('Have member members',Variant2.Members.Members);
  AssertNotNull('member 1 not null',Variant2.Members.Members[0]);
  AssertEquals('Member 1 has correct name',TPasVariable,TObject(Variant2.Members.Members[0]).ClassType);
  AssertEquals('Member 1 has correct name','z',TPasVariable(Variant2.Members.Members[0]).Name);
  AssertNotNull('member 1 has not null type',TPasVariable(Variant2.Members.Members[0]).VarType);
  AssertEquals('member 1 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant2.Members.Members[0]).VarType.ClassType);
  AssertEquals('member 1 has correct type name','Integer',TPasVariable(Variant2.Members.Members[0]).VarType.Name);
  AssertTrue('Field 1 hints match',TPasVariable(Variant2.Members.Members[0]).Hints=Hints)
end;

procedure TTestRecordTypeParser.DoTestVariantNoStorage(const AHint: string);
begin
  TestFields(['x : integer;','case integer of','0 : (y : integer;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('','');
  AssertVariant1([]);
end;

procedure TTestRecordTypeParser.DoTestDeprecatedVariantNoStorage(
  const AHint: string);
begin
  TestFields(['x : integer;','case integer of','0 : (y : integer deprecated;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('','');
  AssertVariant1([hDeprecated]);
end;

procedure TTestRecordTypeParser.DoTestDeprecatedVariantStorage(
  const AHint: string);
begin
  TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('s','');
  AssertVariant1([hDeprecated]);
end;

procedure TTestRecordTypeParser.DoTestVariantStorage(const AHint: string);
begin
  TestFields(['x : integer;','case s : integer of','0 : (y : integer;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('s','');
  AssertVariant1([]);
end;

procedure TTestRecordTypeParser.DoTestTwoVariantsNoStorage(const AHint: string
  );
begin
  TestFields(['x : integer;','case integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('','');
  AssertVariant1([]);
  AssertVariant2([]);
end;

procedure TTestRecordTypeParser.DoTestTwoVariantsStorage(const AHint: string);
begin
  TestFields(['x : integer;','case s : integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
  AssertField1([]);
  AssertVariantSelector('s','');
  AssertVariant1([]);
  Ass…