/packages/fcl-passrc/tests/tctypeparser.pas
Pascal | 2839 lines | 2411 code | 413 blank | 15 comment | 16 complexity | a1f7e5d4fb1b8933d72bf741719ace76 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
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