PageRenderTime 114ms CodeModel.GetById 33ms app.highlight 10ms RepoModel.GetById 62ms app.codeStats 2ms

/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
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0

Large files files are truncated, but you can click here to view the full file

   1unit tctypeparser;
   2
   3{$mode objfpc}{$H+}
   4
   5interface
   6
   7uses
   8  Classes, SysUtils, fpcunit, pastree, pscanner, pparser,
   9  tcbaseparser, testregistry;
  10
  11type
  12  { TBaseTestTypeParser }
  13
  14  TBaseTestTypeParser= Class(TTestParser)
  15  private
  16    FType : TPasType;
  17    FHint : string;
  18    FErrorSource : String;
  19  Protected
  20    Function ParseType(ASource : String; ATypeClass : TClass;Const AHint : String = '') : TPasType; virtual; overload;
  21    Procedure AssertParseTypeError(ASource : String);
  22    Property TheType : TPasType Read FType;
  23    Property Hint : string Read FHint Write FHint;
  24    procedure SetUp; override;
  25    Procedure TearDown; override;
  26  end;
  27
  28  { TTestTypeParser }
  29
  30  TTestTypeParser = Class(TBaseTestTypeParser)
  31  private
  32  Protected
  33    Procedure DoTestAliasType(Const AnAliasType : String; Const AHint : String);
  34    procedure DoTestStringType(const AnAliasType: String; const AHint: String);
  35    procedure DoTypeError(Const AMsg,ASource : string);
  36    Procedure DoParseError;
  37    Procedure DoParsePointer(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
  38    Procedure DoParseArray(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
  39    Procedure DoParseEnumerated(Const ASource : String; Const AHint : String; ACount : integer);
  40    Procedure DoTestFileType(Const AType : String; Const AHint : String; ADestType : TClass = Nil);
  41    Procedure DoTestRangeType(Const AStart,AStop,AHint : String);
  42    Procedure DoParseSimpleSet(Const ASource : String; Const AHint : String);
  43    Procedure DoParseComplexSet(Const ASource : String; Const AHint : String);
  44    procedure DoParseRangeSet(const ASource: String; const AHint: String);
  45    Procedure DoTestComplexSet;
  46    Procedure DoTestClassOf(Const AHint : string);
  47  Published
  48    Procedure TestAliasType;
  49    Procedure TestCrossUnitAliasType;
  50    Procedure TestAliasTypeDeprecated;
  51    Procedure TestAliasTypePlatform;
  52    Procedure TestSimpleTypeByte;
  53    Procedure TestSimpleTypeByteDeprecated;
  54    Procedure TestSimpleTypeBytePlatform;
  55    Procedure TestSimpleTypeBoolean;
  56    Procedure TestSimpleTypeBooleanDeprecated;
  57    Procedure TestSimpleTypeBooleanPlatform;
  58    Procedure TestSimpleTypeChar;
  59    Procedure TestSimpleTypeCharDeprecated;
  60    Procedure TestSimpleTypeCharPlatform;
  61    Procedure TestSimpleTypeInteger;
  62    Procedure TestSimpleTypeIntegerDeprecated;
  63    Procedure TestSimpleTypeIntegerPlatform;
  64    Procedure TestSimpleTypeInt64;
  65    Procedure TestSimpleTypeInt64Deprecated;
  66    Procedure TestSimpleTypeInt64Platform;
  67    Procedure TestSimpleTypeLongInt;
  68    Procedure TestSimpleTypeLongIntDeprecated;
  69    Procedure TestSimpleTypeLongIntPlatform;
  70    Procedure TestSimpleTypeLongWord;
  71    Procedure TestSimpleTypeLongWordDeprecated;
  72    Procedure TestSimpleTypeLongWordPlatform;
  73    Procedure TestSimpleTypeDouble;
  74    Procedure TestSimpleTypeDoubleDeprecated;
  75    Procedure TestSimpleTypeDoublePlatform;
  76    Procedure TestSimpleTypeShortInt;
  77    Procedure TestSimpleTypeShortIntDeprecated;
  78    Procedure TestSimpleTypeShortIntPlatform;
  79    Procedure TestSimpleTypeSmallInt;
  80    Procedure TestSimpleTypeSmallIntDeprecated;
  81    Procedure TestSimpleTypeSmallIntPlatform;
  82    Procedure TestSimpleTypeString;
  83    Procedure TestSimpleTypeStringDeprecated;
  84    Procedure TestSimpleTypeStringPlatform;
  85    Procedure TestSimpleTypeStringSize;
  86    Procedure TestSimpleTypeStringSizeIncomplete;
  87    Procedure TestSimpleTypeStringSizeWrong;
  88    Procedure TestSimpleTypeStringSizeDeprecated;
  89    Procedure TestSimpleTypeStringSizePlatform;
  90    Procedure TestSimpleTypeWord;
  91    Procedure TestSimpleTypeWordDeprecated;
  92    Procedure TestSimpleTypeWordPlatform;
  93    Procedure TestSimpleTypeQWord;
  94    Procedure TestSimpleTypeQWordDeprecated;
  95    Procedure TestSimpleTypeQWordPlatform;
  96    Procedure TestSimpleTypeCardinal;
  97    Procedure TestSimpleTypeCardinalDeprecated;
  98    Procedure TestSimpleTypeCardinalPlatform;
  99    Procedure TestSimpleTypeWideChar;
 100    Procedure TestSimpleTypeWideCharDeprecated;
 101    Procedure TestSimpleTypeWideCharPlatform;
 102    Procedure TestPointerSimple;
 103    procedure TestPointerSimpleDeprecated;
 104    procedure TestPointerSimplePlatform;
 105    Procedure TestStaticArray;
 106    procedure TestStaticArrayDeprecated;
 107    procedure TestStaticArrayPlatform;
 108    Procedure TestStaticArrayPacked;
 109    Procedure TestStaticArrayTypedIndex;
 110    Procedure TestDynamicArray;
 111    Procedure TestSimpleEnumerated;
 112    Procedure TestSimpleEnumeratedDeprecated;
 113    Procedure TestSimpleEnumeratedPlatform;
 114    Procedure TestAssignedEnumerated;
 115    Procedure TestAssignedEnumeratedDeprecated;
 116    Procedure TestAssignedEnumeratedPlatform;
 117    Procedure TestFileType;
 118    Procedure TestFileTypeDeprecated;
 119    Procedure TestFileTypePlatform;
 120    Procedure TestRangeType;
 121    Procedure TestRangeTypeDeprecated;
 122    Procedure TestRangeTypePlatform;
 123    Procedure TestIdentifierRangeType;
 124    Procedure TestIdentifierRangeTypeDeprecated;
 125    Procedure TestIdentifierRangeTypePlatform;
 126    Procedure TestNegativeIdentifierRangeType;
 127    Procedure TestSimpleSet;
 128    Procedure TestSimpleSetDeprecated;
 129    Procedure TestSimpleSetPlatform;
 130    Procedure TestComplexSet;
 131    Procedure TestComplexSetDeprecated;
 132    Procedure TestComplexSetPlatform;
 133    Procedure TestRangeSet;
 134    Procedure TestRangeSetDeprecated;
 135    Procedure TestRangeSetPlatform;
 136    Procedure TestClassOf;
 137    Procedure TestClassOfDeprecated;
 138    Procedure TestClassOfPlatform;
 139    Procedure TestReferenceAlias;
 140    Procedure TestReferenceSet;
 141    Procedure TestReferenceClassOf;
 142    Procedure TestReferenceFile;
 143    Procedure TestReferenceArray;
 144    Procedure TestReferencePointer;
 145  end;
 146
 147  { TTestRecordTypeParser }
 148
 149  TTestRecordTypeParser= Class(TBaseTestTypeParser)
 150  private
 151    Function GetField(AIndex : Integer; R : TPasRecordType) : TPasVariable;
 152    Function GetField(AIndex : Integer; R : TPasVariant) : TPasVariable;
 153    function GetF(AIndex: Integer): TPasVariable;
 154    function GetR: TPasRecordType;
 155    Function GetVariant(AIndex : Integer; R : TPasRecordType) : TPasVariant;
 156    function GetV(AIndex: Integer): TPasVariant;
 157  Protected
 158    Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
 159    procedure AssertVariantSelector(AName, AType: string);
 160    procedure AssertField1(Hints: TPasMemberHints);
 161    procedure AssertField2(Hints: TPasMemberHints);
 162    procedure AssertVariant1(Hints: TPasMemberHints);
 163    procedure AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
 164    procedure AssertVariant2(Hints: TPasMemberHints);
 165    procedure AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
 166    procedure AssertOneIntegerField(Hints: TPasMemberHints);
 167    procedure AssertTwoIntegerFields(Hints1, Hints2: TPasMemberHints);
 168    procedure AssertRecordField(AIndex: Integer;Hints: TPasMemberHints);
 169    procedure AssertRecordVariant(AIndex: Integer;Hints: TPasMemberHints; VariantLabels : Array of string);
 170    Procedure AssertRecordVariantVariant(AIndex: Integer;Const AFieldName,ATypeName: string;Hints: TPasMemberHints; VariantLabels : Array of string);
 171    Procedure DoTestEmpty(Const AHint : String);
 172    procedure DoTestDeprecatedVariantNoStorage(Const AHint : string);
 173    procedure DoTestDeprecatedVariantStorage(Const AHint : string);
 174    procedure DoTestVariantNoStorage(Const AHint : string);
 175    procedure DoTestVariantStorage(Const AHint : string);
 176    procedure DoTestTwoVariantsNoStorage(Const AHint : string);
 177    procedure DoTestTwoVariantsStorage(Const AHint : string);
 178    procedure DoTestTwoVariantsFirstDeprecatedStorage(Const AHint : string);
 179    procedure DoTestTwoVariantsSecondDeprecatedStorage(Const AHint : string);
 180    Procedure DoTestVariantTwoLabels(Const AHint : string);
 181    Procedure DoTestTwoVariantsTwoLabels(Const AHint : string);
 182    procedure DoTestVariantNestedRecord(Const AHint : string);
 183    procedure DoTestVariantNestedVariant(Const AHint : string);
 184    procedure DoTestVariantNestedVariantFirstDeprecated(Const AHint : string);
 185    procedure DoTestVariantNestedVariantSecondDeprecated(const AHint: string);
 186    procedure DoTestVariantNestedVariantBothDeprecated(const AHint: string);
 187    Property TheRecord : TPasRecordType Read GetR;
 188    Property Field1 : TPasVariable Index 0 Read GetF;
 189    Property Field2 : TPasVariable Index 1 Read GetF;
 190    Property Variant1 : TPasVariant Index 0 Read GetV;
 191    Property Variant2 : TPasVariant Index 1 Read GetV;
 192  Published
 193    Procedure TestEmpty;
 194    Procedure TestEmptyDeprecated;
 195    Procedure TestEmptyPlatform;
 196    Procedure TestOneField;
 197    Procedure TestOneFieldDeprecated;
 198    Procedure TestOneFieldPlatform;
 199    Procedure TestOneFieldSemicolon;
 200    Procedure TestOneFieldSemicolonDeprecated;
 201    Procedure TestOneFieldSemicolonPlatform;
 202    Procedure TestOneDeprecatedField;
 203    Procedure TestOneDeprecatedFieldDeprecated;
 204    Procedure TestOneDeprecatedFieldPlatform;
 205    Procedure TestOnePlatformField;
 206    Procedure TestOnePlatformFieldDeprecated;
 207    Procedure TestOnePlatformFieldPlatform;
 208    Procedure TestTwoFields;
 209    Procedure TestTwoFieldDeprecated;
 210    Procedure TestTwoFieldPlatform;
 211    Procedure TestTwoFieldsFirstDeprecated;
 212    Procedure TestTwoFieldsFirstDeprecatedDeprecated;
 213    Procedure TestTwoFieldsFirstDeprecatedPlatform;
 214    Procedure TestTwoFieldsSecondDeprecated;
 215    Procedure TestTwoFieldsSecondDeprecatedDeprecated;
 216    Procedure TestTwoFieldsSecondDeprecatedPlatform;
 217    Procedure TestTwoFieldsBothDeprecated;
 218    Procedure TestTwoFieldsBothDeprecatedDeprecated;
 219    Procedure TestTwoFieldsBothDeprecatedPlatform;
 220    Procedure TestTwoFieldsCombined;
 221    Procedure TestTwoFieldsCombinedDeprecated;
 222    Procedure TestTwoFieldsCombinedPlatform;
 223    Procedure TestTwoDeprecatedFieldsCombined;
 224    Procedure TestTwoDeprecatedFieldsCombinedDeprecated;
 225    Procedure TestTwoDeprecatedFieldsCombinedPlatform;
 226    Procedure TestNested;
 227    Procedure TestNestedDeprecated;
 228    Procedure TestNestedPlatform;
 229    procedure TestNestedSemicolon;
 230    procedure TestNestedSemicolonDeprecated;
 231    procedure TestNestedSemicolonPlatform;
 232    procedure TestNestedFirst;
 233    procedure TestNestedFirstDeprecated;
 234    procedure TestNestedFirstPlatform;
 235    Procedure TestDeprecatedNested;
 236    Procedure TestDeprecatedNestedDeprecated;
 237    Procedure TestDeprecatedNestedPlatform;
 238    procedure TestDeprecatedNestedFirst;
 239    procedure TestDeprecatedNestedFirstDeprecated;
 240    procedure TestDeprecatedNestedFirstPlatform;
 241    Procedure TestVariantNoStorage;
 242    procedure TestVariantNoStorageDeprecated;
 243    procedure TestVariantNoStoragePlatform;
 244    Procedure TestVariantStorage;
 245    procedure TestVariantStorageDeprecated;
 246    procedure TestVariantStoragePlatform;
 247    Procedure TestDeprecatedVariantNoStorage;
 248    procedure TestDeprecatedVariantNoStorageDeprecated;
 249    procedure TestDeprecatedVariantNoStoragePlatform;
 250    Procedure TestDeprecatedVariantStorage;
 251    procedure TestDeprecatedVariantStorageDeprecated;
 252    procedure TestDeprecatedVariantStoragePlatform;
 253    Procedure TestTwoVariantsNoStorage;
 254    procedure TestTwoVariantsNoStorageDeprecated;
 255    procedure TestTwoVariantsNoStoragePlatform;
 256    Procedure TestTwoVariantsStorage;
 257    procedure TestTwoVariantsStorageDeprecated;
 258    procedure TestTwoVariantsStoragePlatform;
 259    Procedure TestTwoVariantsFirstDeprecatedStorage;
 260    procedure TestTwoVariantsFirstDeprecatedStorageDeprecated;
 261    procedure TestTwoVariantsFirstDeprecatedStoragePlatform;
 262    Procedure TestTwoVariantsSecondDeprecatedStorage;
 263    procedure TestTwoVariantsSecondDeprecatedStorageDeprecated;
 264    procedure TestTwoVariantsSecondDeprecatedStoragePlatform;
 265    Procedure TestVariantTwoLabels;
 266    Procedure TestVariantTwoLabelsDeprecated;
 267    Procedure TestVariantTwoLabelsPlatform;
 268    Procedure TestTwoVariantsTwoLabels;
 269    Procedure TestTwoVariantsTwoLabelsDeprecated;
 270    Procedure TestTwoVariantsTwoLabelsPlatform;
 271    Procedure TestVariantNestedRecord;
 272    Procedure TestVariantNestedRecordDeprecated;
 273    Procedure TestVariantNestedRecordPlatform;
 274    Procedure TestVariantNestedVariant;
 275    Procedure TestVariantNestedVariantDeprecated;
 276    Procedure TestVariantNestedVariantPlatForm;
 277    Procedure TestVariantNestedVariantFirstDeprecated;
 278    Procedure TestVariantNestedVariantFirstDeprecatedDeprecated;
 279    Procedure TestVariantNestedVariantFirstDeprecatedPlatform;
 280    Procedure TestVariantNestedVariantSecondDeprecated;
 281    Procedure TestVariantNestedVariantSecondDeprecatedDeprecated;
 282    Procedure TestVariantNestedVariantSecondDeprecatedPlatform;
 283    Procedure TestVariantNestedVariantBothDeprecated;
 284    Procedure TestVariantNestedVariantBothDeprecatedDeprecated;
 285    Procedure TestVariantNestedVariantBothDeprecatedPlatform;
 286  end;
 287
 288  { TTestProcedureTypeParser }
 289  TCallingConventionTest = Procedure (CC : TCallingConvention;Const AHint : String) of object;
 290
 291  TTestProcedureTypeParser = Class(TBaseTestTypeParser)
 292  Private
 293    FProc : TPasProcedureType;
 294    procedure CheckArrayOfConstArgument(Aindex: Integer; Ac: TArgumentAccess);
 295  Protected
 296    procedure DoTestFunction(CC: TCallingConvention; const AHint: String);
 297    procedure DoTestFunctionOfObject(CC: TCallingConvention; const AHint: String);
 298    procedure DoTestFunctionOneArg(CC: TCallingConvention; const AHint: String);
 299    procedure DoTestFunctionOneArgOfObject(CC: TCallingConvention; const AHint: String);
 300    procedure DoTestProcedureOfObject(CC: TCallingConvention; const AHint: String);
 301    procedure DoTestProcedureOfObjectOneArg(CC: TCallingConvention; const AHint: String);
 302    procedure DoTestProcedureIsNested(CC: TCallingConvention; const AHint: String);
 303    procedure DoTestProcedureIsNestedOneArg(CC: TCallingConvention; const AHint: String);
 304    procedure CheckOpenArrayArgument(Ac: TArgumentAccess);
 305    procedure DoTestProcedureArrayOfConst(CC: TCallingConvention; const AHint: String);
 306    procedure DoTestProcedureOpenArray(CC: TCallingConvention; const AHint: String);
 307    procedure DoTestProcedureConstOpenArray(CC: TCallingConvention; const AHint: String);
 308    procedure DoTestProcedureVarOpenArray(CC: TCallingConvention; const AHint: String);
 309    procedure DoTestProcedureOutOpenArray(CC: TCallingConvention; const AHint: String);
 310    procedure DoTestProcedureOneArgDefault(CC: TCallingConvention;const AHint: String);
 311    procedure DoTestProcedureOneArgDefaultExpr(CC: TCallingConvention;const AHint: String);
 312    procedure DoTestProcedureOneArgDefaultSet(CC: TCallingConvention;const AHint: String);
 313    procedure DoTestProcedureOneConstArgDefault(CC: TCallingConvention; const AHint: String);
 314    procedure DoTestProcedureOneVarArgDefault(CC: TCallingConvention; const AHint: String);
 315    procedure DoTestProcedureOneOutArgDefault(CC: TCallingConvention; const AHint: String);
 316    function CheckArgument(AIndex : Integer; Const AName,ATypeName : String; AAccess : TArgumentAccess) : TPasArgument;
 317    Function ParseType(ASource : String; CC : TCallingConvention; ATypeClass : TClass;Const AHint : String = '') : TPasProcedureType; virtual; overload;
 318    Procedure DoTestProcedureDecl(CC : TCallingConvention; Const AHint : String);
 319    Procedure DoTestProcedureOneArgDecl(CC : TCallingConvention; Const AHint : String);
 320    Procedure DoTestProcedureOneVarArgDecl(CC : TCallingConvention; Const AHint : String);
 321    Procedure DoTestProcedureOneConstArgDecl(CC : TCallingConvention; Const AHint : String);
 322    Procedure DoTestProcedureOneOutArgDecl(CC : TCallingConvention; Const AHint : String);
 323    Procedure DoTestProcedureTwoArgsDecl(CC : TCallingConvention; Const AHint : String);
 324    Procedure DoTestProcedureTwoVarArgsDecl(CC : TCallingConvention; Const AHint : String);
 325    Procedure DoTestProcedureTwoConstArgsDecl(CC : TCallingConvention; Const AHint : String);
 326    Procedure DoTestProcedureTwoOutArgsDecl(CC : TCallingConvention; Const AHint : String);
 327    Procedure DoTestProcedureTwoCombinedArgsDecl(CC : TCallingConvention; Const AHint : String);
 328    Procedure DoTestProcedureTwoCombinedVarArgsDecl(CC : TCallingConvention; Const AHint : String);
 329    Procedure DoTestProcedureTwoCombinedConstArgsDecl(CC : TCallingConvention; Const AHint : String);
 330    Procedure DoTestProcedureTwoCombinedOutArgsDecl(CC : TCallingConvention; Const AHint : String);
 331    Procedure DoTestProcedureDefaultConstArgsDecl(CC : TCallingConvention; Const AHint : String);
 332    procedure DoTestProcedureUntypedArgDecl(CC: TCallingConvention; const AHint: String);
 333    procedure DoTestProcedureUntypedConstArgDecl(CC: TCallingConvention; const AHint: String);
 334    procedure DoTestProcedureUntypedOutArgDecl(CC: TCallingConvention; const AHint: String);
 335    procedure DoTestProcedureUntypedDefArg;
 336    Procedure TestCallingConventions(Proc : TCallingConventionTest; Const AHint : String);
 337    Procedure TestCallingConventions(Proc : TCallingConventionTest);
 338    Function FuncProc : TPasFunctionType;
 339    Property Proc : TPasProcedureType Read FProc;
 340  Published
 341    Procedure TestProcedure;
 342    Procedure TestProcedureOneArg;
 343    Procedure TestProcedureOneVarArg;
 344    Procedure TestProcedureOneConstArg;
 345    Procedure TestProcedureOneOutArg;
 346    Procedure TestProcedureTwoArgs;
 347    Procedure TestProcedureTwoVarArgs;
 348    Procedure TestProcedureTwoConstArgs;
 349    Procedure TestProcedureTwoOutArgs;
 350    Procedure TestProcedureTwoCombinedArgs;
 351    Procedure TestProcedureTwoCombinedVarArgs;
 352    Procedure TestProcedureTwoCombinedConstArgs;
 353    Procedure TestProcedureTwoCombinedOutArgs;
 354    Procedure TestProcedureDefaultConstArgs;
 355    Procedure TestProcedureUntypedArg;
 356    Procedure TestProcedureUntypedConstArg;
 357    Procedure TestProcedureUntypedOutArg;
 358    Procedure TestProcedureUntypedDefArg;
 359    Procedure TestProcedureOneArgDefault;
 360    Procedure TestProcedureOneArgDefaultExpr;
 361    Procedure TestProcedureOneArgDefaultSet;
 362    Procedure TestProcedureOneVarArgDefault;
 363    Procedure TestProcedureOneConstArgDefault;
 364    Procedure TestProcedureOneOutArgDefault;
 365    Procedure TestProcedureNoMultiArgDefaults;
 366    Procedure TestProcedureOpenArray;
 367    Procedure TestProcedureConstOpenArray;
 368    Procedure TestProcedureOutOpenArray;
 369    Procedure TestProcedureVarOpenArray;
 370    Procedure TestProcedureArrayOfConst;
 371    Procedure TestProcedureOfObject;
 372    Procedure TestProcedureOfObjectOneArg;
 373    Procedure TestProcedureIsNested;
 374    Procedure TestProcedureIsNesteOneArg;
 375    Procedure TestFunction;
 376    Procedure TestFunctionOneArg;
 377    Procedure TestFunctionOfObject;
 378    Procedure TestFunctionOneArgOfObject;
 379  end;
 380
 381
 382
 383implementation
 384
 385uses typinfo;
 386
 387
 388
 389{ TTestProcedureTypeParser }
 390
 391procedure TTestProcedureTypeParser.DoTestProcedureUntypedArgDecl(
 392  CC: TCallingConvention; const AHint: String);
 393
 394Var
 395  A : TPasArgument;
 396
 397begin
 398  ParseType('procedure(var A)',CC,TPasProcedureType,AHint);
 399  AssertEquals('Argument count',1,Proc.Args.Count);
 400  A:=CheckArgument(0,'A','',argVar);
 401  AssertNull('No argument type', A.ArgType)
 402end;
 403
 404procedure TTestProcedureTypeParser.DoTestProcedureUntypedConstArgDecl(
 405  CC: TCallingConvention; const AHint: String);
 406
 407Var
 408  A : TPasArgument;
 409
 410begin
 411  ParseType('procedure(const A)',CC,TPasProcedureType,AHint);
 412  AssertEquals('Argument count',1,Proc.Args.Count);
 413  A:=CheckArgument(0,'A','',argConst);
 414  AssertNull('No argument type', A.ArgType)
 415end;
 416
 417procedure TTestProcedureTypeParser.DoTestProcedureUntypedOutArgDecl(
 418  CC: TCallingConvention; const AHint: String);
 419Var
 420  A : TPasArgument;
 421
 422begin
 423  ParseType('procedure(out A)',CC,TPasProcedureType,AHint);
 424  AssertEquals('Argument count',1,Proc.Args.Count);
 425  A:=CheckArgument(0,'A','',argOut);
 426  AssertNull('No argument type', A.ArgType)
 427end;
 428
 429procedure TTestProcedureTypeParser.DoTestProcedureUntypedDefArg;
 430begin
 431  ParseType('procedure(A)',ccdefault,TPasProcedureType,'');
 432end;
 433
 434procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDefault(
 435  CC: TCallingConvention; const AHint: String);
 436Var
 437  A : TPasArgument;
 438
 439begin
 440  ParseType('procedure(var A : Integer = 1)',CC,TPasProcedureType,AHint);
 441  AssertEquals('Argument count',1,Proc.Args.Count);
 442  A:=CheckArgument(0,'A','Integer',argVar);
 443  AssertNotNull('have default argument type', A.Value);
 444  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
 445  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
 446end;
 447
 448procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDefault(
 449  CC: TCallingConvention; const AHint: String);
 450Var
 451  A : TPasArgument;
 452
 453begin
 454  ParseType('procedure(out A : Integer = 1)',CC,TPasProcedureType,AHint);
 455  AssertEquals('Argument count',1,Proc.Args.Count);
 456  A:=CheckArgument(0,'A','Integer',argOut);
 457  AssertNotNull('have default argument type', A.Value);
 458  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
 459  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
 460end;
 461
 462procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDefault(
 463  CC: TCallingConvention; const AHint: String);
 464Var
 465  A : TPasArgument;
 466
 467begin
 468  ParseType('procedure(const A : Integer = 1)',CC,TPasProcedureType,AHint);
 469  AssertEquals('Argument count',1,Proc.Args.Count);
 470  A:=CheckArgument(0,'A','Integer',argConst);
 471  AssertNotNull('have default argument type', A.Value);
 472  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
 473  AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
 474end;
 475
 476procedure TTestProcedureTypeParser.DoTestProcedureArrayOfConst(
 477  CC: TCallingConvention; const AHint: String);
 478
 479begin
 480  ParseType('procedure(A : Array of const)',CC,TPasProcedureType,AHint);
 481  AssertEquals('Argument count',1,Proc.Args.Count);
 482  CheckArrayOfConstArgument(0,argDefault);
 483end;
 484
 485procedure TTestProcedureTypeParser.DoTestProcedureOfObject(
 486  CC: TCallingConvention; const AHint: String);
 487begin
 488  ParseType('procedure of Object',CC,TPasProcedureType,AHint);
 489  AssertEquals('Argument count',0,Proc.Args.Count);
 490  AssertEquals('Is OF Object',True,Proc.IsOfObject);
 491end;
 492
 493procedure TTestProcedureTypeParser.DoTestProcedureOfObjectOneArg(
 494  CC: TCallingConvention; const AHint: String);
 495begin
 496  ParseType('procedure (A : integer)of Object',CC,TPasProcedureType,AHint);
 497  AssertEquals('Argument count',1,Proc.Args.Count);
 498  AssertEquals('Is OF Object',True,Proc.IsOfObject);
 499  CheckArgument(0,'A','Integer',argDefault);
 500end;
 501
 502procedure TTestProcedureTypeParser.DoTestProcedureIsNested(
 503  CC: TCallingConvention; const AHint: String);
 504begin
 505  ParseType('procedure is nested',CC,TPasProcedureType,AHint);
 506  AssertEquals('Argument count',0,Proc.Args.Count);
 507  AssertEquals('Is nested',True,Proc.IsNested);
 508end;
 509
 510procedure TTestProcedureTypeParser.DoTestProcedureIsNestedOneArg(
 511  CC: TCallingConvention; const AHint: String);
 512begin
 513  ParseType('procedure (A : integer) is nested',CC,TPasProcedureType,AHint);
 514  AssertEquals('Argument count',1,Proc.Args.Count);
 515  AssertEquals('Is nested',True,Proc.IsNested);
 516  CheckArgument(0,'A','Integer',argDefault);
 517end;
 518
 519
 520procedure TTestProcedureTypeParser.CheckArrayOfConstArgument(Aindex : Integer; Ac : TArgumentAccess);
 521Var
 522  A : TPasArgument;
 523  T : TPasArrayType;
 524
 525begin
 526  A:=CheckArgument(Aindex,'A','',ac);
 527  AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
 528  T:=A.ArgType as TPasArrayType;
 529  AssertNull('Have Element type',T.ElType);
 530end;
 531
 532procedure TTestProcedureTypeParser.DoTestFunction(CC: TCallingConvention;
 533  const AHint: String);
 534begin
 535  ParseType('function : integer',CC,TPasFunctionType,AHint);
 536  AssertEquals('Argument count',0,Proc.Args.Count);
 537  AssertEquals('Is OF Object',False,Proc.IsOfObject);
 538  AssertNotNull('Have result',FuncProc.ResultEl);
 539  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
 540  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
 541  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
 542  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
 543end;
 544
 545procedure TTestProcedureTypeParser.DoTestFunctionOfObject(CC: TCallingConvention;
 546  const AHint: String);
 547begin
 548  ParseType('function : integer of object',CC,TPasFunctionType,AHint);
 549  AssertEquals('Argument count',0,Proc.Args.Count);
 550  AssertEquals('Is OF Object',True,Proc.IsOfObject);
 551  AssertNotNull('Have result',FuncProc.ResultEl);
 552  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
 553  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
 554  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
 555  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
 556end;
 557
 558procedure TTestProcedureTypeParser.DoTestFunctionOneArg(CC: TCallingConvention;
 559  const AHint: String);
 560begin
 561  ParseType('function (A : Integer) : Integer',CC,TPasFunctionType,AHint);
 562  AssertEquals('Argument count',1,Proc.Args.Count);
 563  CheckArgument(0,'A','Integer',argDefault);
 564  AssertNotNull('Have result',FuncProc.ResultEl);
 565  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
 566  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
 567  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
 568  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
 569end;
 570
 571procedure TTestProcedureTypeParser.DoTestFunctionOneArgOfObject(
 572  CC: TCallingConvention; const AHint: String);
 573begin
 574  ParseType('function (A : Integer) : Integer of object',CC,TPasFunctionType,AHint);
 575  AssertEquals('Argument count',1,Proc.Args.Count);
 576  AssertEquals('Is OF Object',True,Proc.IsOfObject);
 577  CheckArgument(0,'A','Integer',argDefault);
 578  AssertNotNull('Have result',FuncProc.ResultEl);
 579  AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
 580  AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
 581  AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
 582  AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
 583end;
 584
 585procedure TTestProcedureTypeParser.CheckOpenArrayArgument(Ac : TArgumentAccess);
 586Var
 587  A : TPasArgument;
 588  T : TPasArrayType;
 589
 590begin
 591  A:=CheckArgument(0,'A','',ac);
 592  AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
 593  T:=A.ArgType as TPasArrayType;
 594  AssertNotNull('Have Element type',T.ElType);
 595  AssertEquals('Element type',TPasUnresolvedTypeRef,T.ElType.ClassType);
 596  AssertEquals('Element type name','Integer',TPasUnresolvedTypeRef(T.ElType).Name);
 597  AssertEquals('No boundaries','',T.IndexRange);
 598end;
 599
 600procedure TTestProcedureTypeParser.DoTestProcedureOpenArray(
 601  CC: TCallingConvention; const AHint: String);
 602
 603begin
 604  ParseType('procedure(A : Array of integer)',CC,TPasProcedureType,AHint);
 605  AssertEquals('Argument count',1,Proc.Args.Count);
 606  CheckOpenArrayArgument(argDefault);
 607end;
 608
 609procedure TTestProcedureTypeParser.DoTestProcedureConstOpenArray(
 610  CC: TCallingConvention; const AHint: String);
 611begin
 612  ParseType('procedure(const A : Array of integer)',CC,TPasProcedureType,AHint);
 613  AssertEquals('Argument count',1,Proc.Args.Count);
 614  CheckOpenArrayArgument(argConst);
 615end;
 616
 617procedure TTestProcedureTypeParser.DoTestProcedureVarOpenArray(
 618  CC: TCallingConvention; const AHint: String);
 619begin
 620  ParseType('procedure(var A : Array of integer)',CC,TPasProcedureType,AHint);
 621  AssertEquals('Argument count',1,Proc.Args.Count);
 622  CheckOpenArrayArgument(argVar);
 623end;
 624
 625procedure TTestProcedureTypeParser.DoTestProcedureOutOpenArray(
 626  CC: TCallingConvention; const AHint: String);
 627begin
 628  ParseType('procedure(out A : Array of integer)',CC,TPasProcedureType,AHint);
 629  AssertEquals('Argument count',1,Proc.Args.Count);
 630  CheckOpenArrayArgument(argOut);
 631end;
 632
 633procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefault(
 634  CC: TCallingConvention; const AHint: String);
 635Var
 636  A : TPasArgument;
 637
 638begin
 639  ParseType('procedure(A : Integer = 1)',CC,TPasProcedureType,AHint);
 640  AssertEquals('Argument count',1,Proc.Args.Count);
 641  A:=CheckArgument(0,'A','Integer',argDefault);
 642  AssertNotNull('have default argument type', A.ValueExpr);
 643  AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
 644  AssertEquals('argument expr value', '1', TPrimitiveExpr(A.ValueExpr).Value);
 645end;
 646
 647procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultExpr(
 648  CC: TCallingConvention; const AHint: String);
 649
 650Var
 651  A : TPasArgument;
 652  B : TBinaryExpr;
 653
 654begin
 655  ParseType('procedure(A : Integer = 1+2)',CC,TPasProcedureType,AHint);
 656  AssertEquals('Argument count',1,Proc.Args.Count);
 657  A:=CheckArgument(0,'A','Integer',argDefault);
 658  AssertNotNull('have default argument type', A.ValueExpr);
 659  AssertEquals('argument expr type', TBinaryExpr, A.ValueExpr.ClassType);
 660  B:=TBinaryExpr(A.ValueExpr);
 661  AssertNotNull('have left expr', B.Left);
 662  AssertEquals('argument left expr type', TPrimitiveExpr, B.left.ClassType);
 663  AssertEquals('argument left expr value', '1', TPrimitiveExpr(B.Left).Value);
 664  AssertNotNull('have right expr', B.Right);
 665  AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType);
 666  AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value);
 667end;
 668
 669procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet(
 670  CC: TCallingConvention; const AHint: String);
 671Var
 672  A : TPasArgument;
 673  B : TParamsExpr;
 674
 675begin
 676  ParseType('procedure(A : TB = [])',CC,TPasProcedureType,AHint);
 677  AssertEquals('Argument count',1,Proc.Args.Count);
 678  A:=CheckArgument(0,'A','TB',argDefault);
 679  AssertNotNull('have default argument type', A.ValueExpr);
 680  AssertEquals('argument expr type', TParamsExpr, A.ValueExpr.ClassType);
 681  B:=TParamsExpr(A.ValueExpr);
 682  AssertEquals('No params',0,Length(B.Params));
 683end;
 684
 685Function TTestProcedureTypeParser.CheckArgument(AIndex: Integer; const AName,
 686  ATypeName: String; AAccess: TArgumentAccess) : TPAsArgument;
 687Var
 688  A : TPasArgument;
 689  C : String;
 690begin
 691  C:='Argument '+IntToStr(AIndex)+' : ';
 692  AssertNotNull(C+'assigned',Proc.Args[AIndex]);
 693  AssertEquals(C+'class',TPasArgument,TObject(Proc.Args[AIndex]).ClassType);
 694  A:=TPasArgument(Proc.Args[AIndex]);
 695  AssertEquals(C+'Access',AAccess,A.Access);
 696  AssertEquals(C+'name',AName,A.Name);
 697  if (ATypeName<>'') then
 698    begin
 699    AssertNotNull(C+'type assigned',A.ArgType);
 700    if (ATypeName[1]='[') then
 701      AssertEquals(C+'type classname',LowerCase(Copy(ATypeName,2,Length(ATypeName)-2)),LowerCase(A.ArgType.ClassName))
 702    else
 703      AssertEquals(C+'type name',ATypeName,A.ArgType.Name);
 704    end;
 705  Result:=A;
 706end;
 707
 708function TTestProcedureTypeParser.ParseType(ASource: String;
 709  CC: TCallingConvention; ATypeClass: TClass; const AHint: String): TPasProcedureType;
 710begin
 711  if CC=ccdefault then
 712    Result:=TPasProcedureType(ParseType(ASource,ATypeClass,AHint))
 713  else
 714    begin
 715    if (AHint<>'') then
 716      Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC]+';',ATypeClass,AHint))
 717    else
 718      Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC],ATypeClass,AHint));
 719    end;
 720  FProc:=Result;
 721  AssertEquals('Correct calling convention for procedural type',cc,Result.CallingConvention);
 722end;
 723
 724procedure TTestProcedureTypeParser.DoTestProcedureDecl(CC: TCallingConvention; Const AHint : String);
 725
 726begin
 727  ParseType('procedure',CC,TPasProcedureType,AHint);
 728  AssertEquals('Argument count',0,Proc.Args.Count);
 729end;
 730
 731procedure TTestProcedureTypeParser.DoTestProcedureOneArgDecl(
 732  CC: TCallingConvention; const AHint: String);
 733
 734begin
 735  ParseType('procedure(A : Integer)',CC,TPasProcedureType,AHint);
 736  AssertEquals('Argument count',1,Proc.Args.Count);
 737  CheckArgument(0,'A','Integer',argDefault);
 738end;
 739
 740procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDecl(
 741  CC: TCallingConvention; const AHint: String);
 742begin
 743  ParseType('procedure(var A : Integer)',CC,TPasProcedureType,AHint);
 744  AssertEquals('Argument count',1,Proc.Args.Count);
 745  CheckArgument(0,'A','Integer',argVar);
 746end;
 747
 748procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDecl(
 749  CC: TCallingConvention; const AHint: String);
 750begin
 751  ParseType('procedure(const A : Integer)',CC,TPasProcedureType,AHint);
 752  AssertEquals('Argument count',1,Proc.Args.Count);
 753  CheckArgument(0,'A','Integer',argConst);
 754end;
 755
 756procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDecl(
 757  CC: TCallingConvention; const AHint: String);
 758begin
 759  ParseType('procedure(out A : Integer)',CC,TPasProcedureType,AHint);
 760  AssertEquals('Argument count',1,Proc.Args.Count);
 761  CheckArgument(0,'A','Integer',argOut);
 762end;
 763
 764procedure TTestProcedureTypeParser.DoTestProcedureTwoArgsDecl(
 765  CC: TCallingConvention; const AHint: String);
 766begin
 767  ParseType('procedure(A : Integer;B : String)',CC,TPasProcedureType,AHint);
 768  AssertEquals('Argument count',2,Proc.Args.Count);
 769  CheckArgument(0,'A','Integer',argDefault);
 770  CheckArgument(1,'B','[TPasAliasType]',argDefault);
 771end;
 772
 773procedure TTestProcedureTypeParser.DoTestProcedureTwoVarArgsDecl(
 774  CC: TCallingConvention; const AHint: String);
 775begin
 776  ParseType('procedure(Var A : Integer;Var B : String)',CC,TPasProcedureType,AHint);
 777  AssertEquals('Argument count',2,Proc.Args.Count);
 778  CheckArgument(0,'A','Integer',argVar);
 779  CheckArgument(1,'B','[TPasAliasType]',argVar);
 780end;
 781
 782procedure TTestProcedureTypeParser.DoTestProcedureTwoConstArgsDecl(
 783  CC: TCallingConvention; const AHint: String);
 784begin
 785  ParseType('procedure(const A : Integer;Const B : String)',CC,TPasProcedureType,AHint);
 786  AssertEquals('Argument count',2,Proc.Args.Count);
 787  CheckArgument(0,'A','Integer',argConst);
 788  CheckArgument(1,'B','[TPasAliasType]',argConst);
 789end;
 790
 791procedure TTestProcedureTypeParser.DoTestProcedureTwoOutArgsDecl(
 792  CC: TCallingConvention; const AHint: String);
 793begin
 794  ParseType('procedure(out A : Integer;Out B : String)',CC,TPasProcedureType,AHint);
 795  AssertEquals('Argument count',2,Proc.Args.Count);
 796  CheckArgument(0,'A','Integer',argOut);
 797  CheckArgument(1,'B','[TPasAliasType]',argOut);
 798end;
 799
 800procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedArgsDecl(
 801  CC: TCallingConvention; const AHint: String);
 802begin
 803  ParseType('procedure(A,B : Integer)',CC,TPasProcedureType,AHint);
 804  AssertEquals('Argument count',2,Proc.Args.Count);
 805  CheckArgument(0,'A','Integer',argDefault);
 806  CheckArgument(1,'B','Integer',argDefault);
 807end;
 808
 809procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedVarArgsDecl(
 810  CC: TCallingConvention; const AHint: String);
 811begin
 812  ParseType('procedure(Var A,B : Integer)',CC,TPasProcedureType,AHint);
 813  AssertEquals('Argument count',2,Proc.Args.Count);
 814  CheckArgument(0,'A','Integer',argVar);
 815  CheckArgument(1,'B','Integer',argVar);
 816end;
 817
 818procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedConstArgsDecl(
 819  CC: TCallingConvention; const AHint: String);
 820begin
 821  ParseType('procedure(Const A,B : Integer)',CC,TPasProcedureType,AHint);
 822  AssertEquals('Argument count',2,Proc.Args.Count);
 823  CheckArgument(0,'A','Integer',argConst);
 824  CheckArgument(1,'B','Integer',argConst);
 825end;
 826
 827procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedOutArgsDecl(
 828  CC: TCallingConvention; const AHint: String);
 829begin
 830  ParseType('procedure(Out A,B : Integer)',CC,TPasProcedureType,AHint);
 831  AssertEquals('Argument count',2,Proc.Args.Count);
 832  CheckArgument(0,'A','Integer',argOut);
 833  CheckArgument(1,'B','Integer',argOut);
 834end;
 835
 836procedure TTestProcedureTypeParser.DoTestProcedureDefaultConstArgsDecl(
 837  CC: TCallingConvention; const AHint: String);
 838begin
 839  ParseType('procedure(A : Integer; Const B : Integer)',CC,TPasProcedureType,AHint);
 840  AssertEquals('Argument count',2,Proc.Args.Count);
 841  CheckArgument(0,'A','Integer',argDefault);
 842  CheckArgument(1,'B','Integer',argConst);
 843end;
 844
 845procedure TTestProcedureTypeParser.TestCallingConventions(
 846  Proc: TCallingConventionTest; Const AHint : String);
 847
 848Var
 849  CC : TCallingConvention;
 850
 851begin
 852  For cc:=ccDefault to High(TCallingConvention) do
 853    begin
 854    if CC<>ccDefault then
 855      Setup;
 856    try
 857      Proc(cc,AHint);
 858    finally
 859      tearDown;
 860    end;
 861    end;
 862end;
 863
 864procedure TTestProcedureTypeParser.TestCallingConventions(
 865  Proc: TCallingConventionTest);
 866begin
 867  TestCallingConventions(Proc,'');
 868  Setup;
 869  TestCallingConventions(Proc,'deprecated');
 870  Setup;
 871  TestCallingConventions(Proc,'platform');
 872end;
 873
 874function TTestProcedureTypeParser.FuncProc: TPasFunctionType;
 875begin
 876  Result:=Proc as TPasFunctionType;
 877end;
 878
 879procedure TTestProcedureTypeParser.TestProcedure;
 880begin
 881  TestCallingConventions(@DoTestProcedureDecl);
 882end;
 883
 884procedure TTestProcedureTypeParser.TestProcedureOneArg;
 885begin
 886  TestCallingConventions(@DoTestProcedureOneArgDecl);
 887end;
 888
 889procedure TTestProcedureTypeParser.TestProcedureOneVarArg;
 890begin
 891  TestCallingConventions(@DoTestProcedureOneVarArgDecl);
 892end;
 893
 894procedure TTestProcedureTypeParser.TestProcedureOneConstArg;
 895begin
 896  TestCallingConventions(@DoTestProcedureOneConstArgDecl);
 897end;
 898
 899procedure TTestProcedureTypeParser.TestProcedureOneOutArg;
 900begin
 901  TestCallingConventions(@DoTestProcedureOneOutArgDecl);
 902end;
 903
 904procedure TTestProcedureTypeParser.TestProcedureTwoArgs;
 905begin
 906  TestCallingConventions(@DoTestProcedureTwoArgsDecl);
 907end;
 908
 909procedure TTestProcedureTypeParser.TestProcedureTwoVarArgs;
 910begin
 911  TestCallingConventions(@DoTestProcedureTwoVarArgsDecl);
 912end;
 913
 914procedure TTestProcedureTypeParser.TestProcedureTwoConstArgs;
 915begin
 916  TestCallingConventions(@DoTestProcedureTwoConstArgsDecl);
 917end;
 918
 919procedure TTestProcedureTypeParser.TestProcedureTwoOutArgs;
 920begin
 921  TestCallingConventions(@DoTestProcedureTwoOutArgsDecl);
 922end;
 923
 924procedure TTestProcedureTypeParser.TestProcedureTwoCombinedArgs;
 925begin
 926  TestCallingConventions(@DoTestProcedureTwoCombinedArgsDecl);
 927end;
 928
 929procedure TTestProcedureTypeParser.TestProcedureTwoCombinedVarArgs;
 930begin
 931  TestCallingConventions(@DoTestProcedureTwoCombinedVarArgsDecl);
 932end;
 933
 934procedure TTestProcedureTypeParser.TestProcedureTwoCombinedConstArgs;
 935begin
 936  TestCallingConventions(@DoTestProcedureTwoCombinedConstArgsDecl);
 937end;
 938
 939procedure TTestProcedureTypeParser.TestProcedureTwoCombinedOutArgs;
 940begin
 941  TestCallingConventions(@DoTestProcedureTwoCombinedOutArgsDecl);
 942end;
 943
 944procedure TTestProcedureTypeParser.TestProcedureDefaultConstArgs;
 945begin
 946  TestCallingConventions(@DoTestProcedureDefaultConstArgsDecl);
 947end;
 948
 949procedure TTestProcedureTypeParser.TestProcedureUntypedArg;
 950begin
 951  TestCallingConventions(@DoTestProcedureUntypedArgDecl);
 952end;
 953
 954procedure TTestProcedureTypeParser.TestProcedureUntypedConstArg;
 955begin
 956  TestCallingConventions(@DoTestProcedureUntypedConstArgDecl);
 957end;
 958
 959procedure TTestProcedureTypeParser.TestProcedureUntypedOutArg;
 960begin
 961  TestCallingConventions(@DoTestProcedureUntypedOutArgDecl);
 962end;
 963
 964procedure TTestProcedureTypeParser.TestProcedureUntypedDefArg;
 965begin
 966  AssertException('No untyped arg by value',EParserError,@DoTestProcedureUntypedDefArg)
 967end;
 968
 969procedure TTestProcedureTypeParser.TestProcedureOneArgDefault;
 970begin
 971  TestCallingConventions(@DoTestProcedureOneArgDefault);
 972end;
 973
 974procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultExpr;
 975begin
 976  TestCallingConventions(@DoTestProcedureOneArgDefaultExpr);
 977end;
 978
 979procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultSet;
 980begin
 981  TestCallingConventions(@DoTestProcedureOneArgDefaultSet);
 982end;
 983
 984procedure TTestProcedureTypeParser.TestProcedureOneVarArgDefault;
 985begin
 986  TestCallingConventions(@DoTestProcedureOneVarArgDefault);
 987end;
 988
 989procedure TTestProcedureTypeParser.TestProcedureOneConstArgDefault;
 990begin
 991  TestCallingConventions(@DoTestProcedureOneConstArgDefault);
 992end;
 993
 994procedure TTestProcedureTypeParser.TestProcedureOneOutArgDefault;
 995begin
 996  TestCallingConventions(@DoTestProcedureOneOutArgDefault);
 997end;
 998
 999procedure TTestProcedureTypeParser.TestProcedureNoMultiArgDefaults;
1000begin
1001  AssertParseTypeError('procedure (A,B : Integer = 1)');
1002end;
1003
1004procedure TTestProcedureTypeParser.TestProcedureOpenArray;
1005begin
1006  TestCallingConventions(@DoTestProcedureOpenArray);
1007end;
1008
1009procedure TTestProcedureTypeParser.TestProcedureConstOpenArray;
1010begin
1011  TestCallingConventions(@DoTestProcedureConstOpenArray);
1012end;
1013
1014procedure TTestProcedureTypeParser.TestProcedureOutOpenArray;
1015begin
1016  TestCallingConventions(@DoTestProcedureVarOpenArray);
1017end;
1018
1019procedure TTestProcedureTypeParser.TestProcedureVarOpenArray;
1020begin
1021  TestCallingConventions(@DoTestProcedureOutOpenArray);
1022end;
1023
1024procedure TTestProcedureTypeParser.TestProcedureArrayOfConst;
1025begin
1026  TestCallingConventions(@DoTestProcedureArrayOfConst);
1027end;
1028
1029procedure TTestProcedureTypeParser.TestProcedureOfObject;
1030begin
1031  TestCallingConventions(@DoTestProcedureOfObject);
1032end;
1033
1034procedure TTestProcedureTypeParser.TestProcedureOfObjectOneArg;
1035begin
1036  TestCallingConventions(@DoTestProcedureOfObjectOneArg);
1037end;
1038
1039procedure TTestProcedureTypeParser.TestProcedureIsNested;
1040begin
1041  TestCallingConventions(@DoTestProcedureIsNested);
1042end;
1043
1044procedure TTestProcedureTypeParser.TestProcedureIsNesteOneArg;
1045begin
1046  TestCallingConventions(@DoTestProcedureIsNestedOneArg);
1047end;
1048
1049procedure TTestProcedureTypeParser.TestFunction;
1050begin
1051  TestCallingConventions(@DoTestFunction);
1052end;
1053
1054procedure TTestProcedureTypeParser.TestFunctionOneArg;
1055begin
1056  TestCallingConventions(@DoTestFunctionOneArg);
1057end;
1058
1059procedure TTestProcedureTypeParser.TestFunctionOfObject;
1060begin
1061  TestCallingConventions(@DoTestFunctionOfObject);
1062end;
1063
1064procedure TTestProcedureTypeParser.TestFunctionOneArgOfObject;
1065begin
1066  TestCallingConventions(@DoTestFunctionOneArgOfObject);
1067
1068end;
1069
1070{ TTestRecordTypeParser }
1071
1072function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasRecordType
1073  ): TPasVariable;
1074begin
1075  AssertNotNull(R);
1076  AssertNotNull(R.Members);
1077  AssertTrue('Have AIndex elements',R.Members.Count>AIndex);
1078  AssertEquals('Correct class in member',TPasVariable,TObject(R.Members[AIndex]).ClassType);
1079  Result:=TPasVariable(R.Members[AIndex]);
1080end;
1081
1082function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasVariant
1083  ): TPasVariable;
1084begin
1085  AssertNotNull(R);
1086  AssertNotNull('Have variant members', R.Members);
1087  AssertNotNull('Have variant members member list',R.Members.Members);
1088  AssertTrue('Have AIndex elements',R.Members.Members.Count>AIndex);
1089  AssertEquals('Correct class in member',TPasVariable,TObject(R.Members.members[AIndex]).ClassType);
1090  Result:=TPasVariable(R.Members.Members[AIndex]);
1091end;
1092
1093function TTestRecordTypeParser.GetF(AIndex: Integer): TPasVariable;
1094begin
1095  Result:=GetField(AIndex,GetR);
1096end;
1097
1098function TTestRecordTypeParser.GetR: TPasRecordType;
1099begin
1100  Result:=TheType as TPasRecordType;
1101end;
1102
1103function TTestRecordTypeParser.GetVariant(AIndex: Integer; R: TPasRecordType
1104  ): TPasVariant;
1105begin
1106  AssertNotNull(R);
1107  AssertNotNull(R.Variants);
1108  AssertTrue('Have AIndex variant elements',R.Variants.Count>AIndex);
1109  AssertEquals('Correct class in variant',TPasVariant,TObject(R.Variants[AIndex]).ClassType);
1110  Result:=TPasVariant(R.Variants[AIndex]);
1111end;
1112
1113function TTestRecordTypeParser.GetV(AIndex: Integer): TPasVariant;
1114begin
1115  Result:=GetVariant(AIndex,GetR);
1116end;
1117
1118procedure TTestRecordTypeParser.TestFields(const Fields: array of string;
1119  AHint: String; HaveVariant: Boolean);
1120
1121Var
1122  S : String;
1123  I : integer;
1124
1125begin
1126  S:='';
1127  For I:=Low(Fields) to High(Fields) do
1128    begin
1129    if (S<>'') then
1130      S:=S+sLineBreak;
1131    S:=S+'    '+Fields[i];
1132    end;
1133  if (S<>'') then
1134    S:=S+sLineBreak;
1135  S:='record'+sLineBreak+s+'  end';
1136  ParseType(S,TPasRecordType,AHint);
1137  if HaveVariant then
1138    begin
1139    AssertNotNull('Have variants',TheRecord.Variants);
1140    AssertNotNull('Have variant type',TheRecord.VariantType);
1141    end
1142  else
1143    begin
1144    AssertNull('No variants',TheRecord.Variants);
1145    AssertNull('No variant type',TheRecord.VariantType);
1146    AssertEquals('No variant name','',TheRecord.VariantName);
1147    end;
1148end;
1149
1150procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);
1151
1152begin
1153  if (AType='') then
1154    AType:='Integer';
1155  AssertEquals('Have variant selector storage name',AName,TheRecord.VariantName);
1156  AssertNotNull('Have variant selector type',TheRecord.VariantType);
1157  AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantType.ClassType);
1158  AssertEquals('Have variant selector type name',AType,TheRecord.VariantType.Name);
1159end;
1160
1161
1162procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
1163begin
1164  TestFields([],AHint);
1165  AssertNotNull('Have members array',TheRecord.Members);
1166  AssertEquals('Zero members in array',0,TheRecord.Members.Count);
1167end;
1168
1169procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints);
1170begin
1171  AssertVariant1(Hints,['0']);
1172end;
1173
1174
1175procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
1176
1177Var
1178  I : Integer;
1179
1180begin
1181  AssertNotNull('Have variant 1',Variant1);
1182  AssertNotNull('Variant 1 has Values ',Variant1.Values);
1183  if Length(VariantLabels)=0 then
1184    begin
1185    AssertEquals('Have 1 value',1,Variant1.Values.Count);
1186    AssertNotNull('Assigned value',Variant1.Values[0]);
1187    AssertEquals('Expression',TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
1188    AssertExpression('First value is 0',TPasExpr(Variant1.Values[0]),pekNumber,'0');
1189    end
1190  else
1191    begin
1192    AssertEquals('Have correct number of values',Length(VariantLabels),Variant1.Values.Count);
1193    For I:=0 to Length(VariantLabels)-1 do
1194      begin
1195      AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
1196      AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
1197      end;
1198    end;
1199  AssertNotNull('Have members',Variant1.Members);
1200  AssertNotNull('Have member members',Variant1.Members.Members);
1201  AssertNotNull('member 0 not null',Variant1.Members.Members[0]);
1202  AssertEquals('Member 0 has correct name',TPasVariable,TObject(Variant1.Members.Members[0]).ClassType);
1203  AssertEquals('Member 0 has correct name','y',TPasVariable(Variant1.Members.Members[0]).Name);
1204  AssertNotNull('member 0 has not null type',TPasVariable(Variant1.Members.Members[0]).VarType);
1205  AssertEquals('member 0 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant1.Members.Members[0]).VarType.ClassType);
1206  AssertEquals('member 0 has correct type name','Integer',TPasVariable(Variant1.Members.Members[0]).VarType.Name);
1207  AssertTrue('Field 1 hints match',TPasVariable(Variant1.Members.Members[0]).Hints=Hints)
1208end;
1209
1210procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints);
1211begin
1212  AssertVariant2(Hints,['1']);
1213end;
1214
1215procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
1216
1217Var
1218  I : Integer;
1219
1220begin
1221  AssertNotNull('Have variant 2',Variant2);
1222  AssertNotNull('Variant 2 has Values ',Variant2.Values);
1223  if Length(VariantLabels)=0 then
1224    begin
1225    AssertEquals('Variant 2 has 1 value',2,Variant2.Values.Count);
1226    AssertEquals('Expression',TPrimitiveExpr,TObject(Variant2.Values[0]).CLassType);
1227    AssertExpression('First value is 1',TPasExpr(Variant2.Values[0]),pekNumber,'1');
1228    end
1229  else
1230    begin
1231    AssertEquals('Variant 2 Has correct number of values',Length(VariantLabels),Variant2.Values.Count);
1232    For I:=0 to Length(VariantLabels)-1 do
1233      begin
1234      AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant2.Values[I]).CLassType);
1235      AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant2.Values[I]),pekNumber,VariantLabels[i]);
1236//      AssertEquals(Format('Variant 2, Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant2.Values[I]);
1237      end;
1238    end;
1239  AssertNotNull('Have members',Variant2.Members);
1240  AssertNotNull('Have member members',Variant2.Members.Members);
1241  AssertNotNull('member 1 not null',Variant2.Members.Members[0]);
1242  AssertEquals('Member 1 has correct name',TPasVariable,TObject(Variant2.Members.Members[0]).ClassType);
1243  AssertEquals('Member 1 has correct name','z',TPasVariable(Variant2.Members.Members[0]).Name);
1244  AssertNotNull('member 1 has not null type',TPasVariable(Variant2.Members.Members[0]).VarType);
1245  AssertEquals('member 1 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant2.Members.Members[0]).VarType.ClassType);
1246  AssertEquals('member 1 has correct type name','Integer',TPasVariable(Variant2.Members.Members[0]).VarType.Name);
1247  AssertTrue('Field 1 hints match',TPasVariable(Variant2.Members.Members[0]).Hints=Hints)
1248end;
1249
1250procedure TTestRecordTypeParser.DoTestVariantNoStorage(const AHint: string);
1251begin
1252  TestFields(['x : integer;','case integer of','0 : (y : integer;)'],AHint,True);
1253  AssertField1([]);
1254  AssertVariantSelector('','');
1255  AssertVariant1([]);
1256end;
1257
1258procedure TTestRecordTypeParser.DoTestDeprecatedVariantNoStorage(
1259  const AHint: string);
1260begin
1261  TestFields(['x : integer;','case integer of','0 : (y : integer deprecated;)'],AHint,True);
1262  AssertField1([]);
1263  AssertVariantSelector('','');
1264  AssertVariant1([hDeprecated]);
1265end;
1266
1267procedure TTestRecordTypeParser.DoTestDeprecatedVariantStorage(
1268  const AHint: string);
1269begin
1270  TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;)'],AHint,True);
1271  AssertField1([]);
1272  AssertVariantSelector('s','');
1273  AssertVariant1([hDeprecated]);
1274end;
1275
1276procedure TTestRecordTypeParser.DoTestVariantStorage(const AHint: string);
1277begin
1278  TestFields(['x : integer;','case s : integer of','0 : (y : integer;)'],AHint,True);
1279  AssertField1([]);
1280  AssertVariantSelector('s','');
1281  AssertVariant1([]);
1282end;
1283
1284procedure TTestRecordTypeParser.DoTestTwoVariantsNoStorage(const AHint: string
1285  );
1286begin
1287  TestFields(['x : integer;','case integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
1288  AssertField1([]);
1289  AssertVariantSelector('','');
1290  AssertVariant1([]);
1291  AssertVariant2([]);
1292end;
1293
1294procedure TTestRecordTypeParser.DoTestTwoVariantsStorage(const AHint: string);
1295begin
1296  TestFields(['x : integer;','case s : integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
1297  AssertField1([]);
1298  AssertVariantSelector('s','');
1299  AssertVariant1([]);
1300  Ass…

Large files files are truncated, but you can click here to view the full file