PageRenderTime 164ms CodeModel.GetById 25ms RepoModel.GetById 0ms app.codeStats 0ms

/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
  1. unit tctypeparser;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5. Classes, SysUtils, fpcunit, pastree, pscanner, pparser,
  6. tcbaseparser, testregistry;
  7. type
  8. { TBaseTestTypeParser }
  9. TBaseTestTypeParser= Class(TTestParser)
  10. private
  11. FType : TPasType;
  12. FHint : string;
  13. FErrorSource : String;
  14. Protected
  15. Function ParseType(ASource : String; ATypeClass : TClass;Const AHint : String = '') : TPasType; virtual; overload;
  16. Procedure AssertParseTypeError(ASource : String);
  17. Property TheType : TPasType Read FType;
  18. Property Hint : string Read FHint Write FHint;
  19. procedure SetUp; override;
  20. Procedure TearDown; override;
  21. end;
  22. { TTestTypeParser }
  23. TTestTypeParser = Class(TBaseTestTypeParser)
  24. private
  25. Protected
  26. Procedure DoTestAliasType(Const AnAliasType : String; Const AHint : String);
  27. procedure DoTestStringType(const AnAliasType: String; const AHint: String);
  28. procedure DoTypeError(Const AMsg,ASource : string);
  29. Procedure DoParseError;
  30. Procedure DoParsePointer(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
  31. Procedure DoParseArray(Const ASource : String; Const AHint : String; ADestType : TClass = Nil);
  32. Procedure DoParseEnumerated(Const ASource : String; Const AHint : String; ACount : integer);
  33. Procedure DoTestFileType(Const AType : String; Const AHint : String; ADestType : TClass = Nil);
  34. Procedure DoTestRangeType(Const AStart,AStop,AHint : String);
  35. Procedure DoParseSimpleSet(Const ASource : String; Const AHint : String);
  36. Procedure DoParseComplexSet(Const ASource : String; Const AHint : String);
  37. procedure DoParseRangeSet(const ASource: String; const AHint: String);
  38. Procedure DoTestComplexSet;
  39. Procedure DoTestClassOf(Const AHint : string);
  40. Published
  41. Procedure TestAliasType;
  42. Procedure TestCrossUnitAliasType;
  43. Procedure TestAliasTypeDeprecated;
  44. Procedure TestAliasTypePlatform;
  45. Procedure TestSimpleTypeByte;
  46. Procedure TestSimpleTypeByteDeprecated;
  47. Procedure TestSimpleTypeBytePlatform;
  48. Procedure TestSimpleTypeBoolean;
  49. Procedure TestSimpleTypeBooleanDeprecated;
  50. Procedure TestSimpleTypeBooleanPlatform;
  51. Procedure TestSimpleTypeChar;
  52. Procedure TestSimpleTypeCharDeprecated;
  53. Procedure TestSimpleTypeCharPlatform;
  54. Procedure TestSimpleTypeInteger;
  55. Procedure TestSimpleTypeIntegerDeprecated;
  56. Procedure TestSimpleTypeIntegerPlatform;
  57. Procedure TestSimpleTypeInt64;
  58. Procedure TestSimpleTypeInt64Deprecated;
  59. Procedure TestSimpleTypeInt64Platform;
  60. Procedure TestSimpleTypeLongInt;
  61. Procedure TestSimpleTypeLongIntDeprecated;
  62. Procedure TestSimpleTypeLongIntPlatform;
  63. Procedure TestSimpleTypeLongWord;
  64. Procedure TestSimpleTypeLongWordDeprecated;
  65. Procedure TestSimpleTypeLongWordPlatform;
  66. Procedure TestSimpleTypeDouble;
  67. Procedure TestSimpleTypeDoubleDeprecated;
  68. Procedure TestSimpleTypeDoublePlatform;
  69. Procedure TestSimpleTypeShortInt;
  70. Procedure TestSimpleTypeShortIntDeprecated;
  71. Procedure TestSimpleTypeShortIntPlatform;
  72. Procedure TestSimpleTypeSmallInt;
  73. Procedure TestSimpleTypeSmallIntDeprecated;
  74. Procedure TestSimpleTypeSmallIntPlatform;
  75. Procedure TestSimpleTypeString;
  76. Procedure TestSimpleTypeStringDeprecated;
  77. Procedure TestSimpleTypeStringPlatform;
  78. Procedure TestSimpleTypeStringSize;
  79. Procedure TestSimpleTypeStringSizeIncomplete;
  80. Procedure TestSimpleTypeStringSizeWrong;
  81. Procedure TestSimpleTypeStringSizeDeprecated;
  82. Procedure TestSimpleTypeStringSizePlatform;
  83. Procedure TestSimpleTypeWord;
  84. Procedure TestSimpleTypeWordDeprecated;
  85. Procedure TestSimpleTypeWordPlatform;
  86. Procedure TestSimpleTypeQWord;
  87. Procedure TestSimpleTypeQWordDeprecated;
  88. Procedure TestSimpleTypeQWordPlatform;
  89. Procedure TestSimpleTypeCardinal;
  90. Procedure TestSimpleTypeCardinalDeprecated;
  91. Procedure TestSimpleTypeCardinalPlatform;
  92. Procedure TestSimpleTypeWideChar;
  93. Procedure TestSimpleTypeWideCharDeprecated;
  94. Procedure TestSimpleTypeWideCharPlatform;
  95. Procedure TestPointerSimple;
  96. procedure TestPointerSimpleDeprecated;
  97. procedure TestPointerSimplePlatform;
  98. Procedure TestStaticArray;
  99. procedure TestStaticArrayDeprecated;
  100. procedure TestStaticArrayPlatform;
  101. Procedure TestStaticArrayPacked;
  102. Procedure TestStaticArrayTypedIndex;
  103. Procedure TestDynamicArray;
  104. Procedure TestSimpleEnumerated;
  105. Procedure TestSimpleEnumeratedDeprecated;
  106. Procedure TestSimpleEnumeratedPlatform;
  107. Procedure TestAssignedEnumerated;
  108. Procedure TestAssignedEnumeratedDeprecated;
  109. Procedure TestAssignedEnumeratedPlatform;
  110. Procedure TestFileType;
  111. Procedure TestFileTypeDeprecated;
  112. Procedure TestFileTypePlatform;
  113. Procedure TestRangeType;
  114. Procedure TestRangeTypeDeprecated;
  115. Procedure TestRangeTypePlatform;
  116. Procedure TestIdentifierRangeType;
  117. Procedure TestIdentifierRangeTypeDeprecated;
  118. Procedure TestIdentifierRangeTypePlatform;
  119. Procedure TestNegativeIdentifierRangeType;
  120. Procedure TestSimpleSet;
  121. Procedure TestSimpleSetDeprecated;
  122. Procedure TestSimpleSetPlatform;
  123. Procedure TestComplexSet;
  124. Procedure TestComplexSetDeprecated;
  125. Procedure TestComplexSetPlatform;
  126. Procedure TestRangeSet;
  127. Procedure TestRangeSetDeprecated;
  128. Procedure TestRangeSetPlatform;
  129. Procedure TestClassOf;
  130. Procedure TestClassOfDeprecated;
  131. Procedure TestClassOfPlatform;
  132. Procedure TestReferenceAlias;
  133. Procedure TestReferenceSet;
  134. Procedure TestReferenceClassOf;
  135. Procedure TestReferenceFile;
  136. Procedure TestReferenceArray;
  137. Procedure TestReferencePointer;
  138. end;
  139. { TTestRecordTypeParser }
  140. TTestRecordTypeParser= Class(TBaseTestTypeParser)
  141. private
  142. Function GetField(AIndex : Integer; R : TPasRecordType) : TPasVariable;
  143. Function GetField(AIndex : Integer; R : TPasVariant) : TPasVariable;
  144. function GetF(AIndex: Integer): TPasVariable;
  145. function GetR: TPasRecordType;
  146. Function GetVariant(AIndex : Integer; R : TPasRecordType) : TPasVariant;
  147. function GetV(AIndex: Integer): TPasVariant;
  148. Protected
  149. Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
  150. procedure AssertVariantSelector(AName, AType: string);
  151. procedure AssertField1(Hints: TPasMemberHints);
  152. procedure AssertField2(Hints: TPasMemberHints);
  153. procedure AssertVariant1(Hints: TPasMemberHints);
  154. procedure AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
  155. procedure AssertVariant2(Hints: TPasMemberHints);
  156. procedure AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
  157. procedure AssertOneIntegerField(Hints: TPasMemberHints);
  158. procedure AssertTwoIntegerFields(Hints1, Hints2: TPasMemberHints);
  159. procedure AssertRecordField(AIndex: Integer;Hints: TPasMemberHints);
  160. procedure AssertRecordVariant(AIndex: Integer;Hints: TPasMemberHints; VariantLabels : Array of string);
  161. Procedure AssertRecordVariantVariant(AIndex: Integer;Const AFieldName,ATypeName: string;Hints: TPasMemberHints; VariantLabels : Array of string);
  162. Procedure DoTestEmpty(Const AHint : String);
  163. procedure DoTestDeprecatedVariantNoStorage(Const AHint : string);
  164. procedure DoTestDeprecatedVariantStorage(Const AHint : string);
  165. procedure DoTestVariantNoStorage(Const AHint : string);
  166. procedure DoTestVariantStorage(Const AHint : string);
  167. procedure DoTestTwoVariantsNoStorage(Const AHint : string);
  168. procedure DoTestTwoVariantsStorage(Const AHint : string);
  169. procedure DoTestTwoVariantsFirstDeprecatedStorage(Const AHint : string);
  170. procedure DoTestTwoVariantsSecondDeprecatedStorage(Const AHint : string);
  171. Procedure DoTestVariantTwoLabels(Const AHint : string);
  172. Procedure DoTestTwoVariantsTwoLabels(Const AHint : string);
  173. procedure DoTestVariantNestedRecord(Const AHint : string);
  174. procedure DoTestVariantNestedVariant(Const AHint : string);
  175. procedure DoTestVariantNestedVariantFirstDeprecated(Const AHint : string);
  176. procedure DoTestVariantNestedVariantSecondDeprecated(const AHint: string);
  177. procedure DoTestVariantNestedVariantBothDeprecated(const AHint: string);
  178. Property TheRecord : TPasRecordType Read GetR;
  179. Property Field1 : TPasVariable Index 0 Read GetF;
  180. Property Field2 : TPasVariable Index 1 Read GetF;
  181. Property Variant1 : TPasVariant Index 0 Read GetV;
  182. Property Variant2 : TPasVariant Index 1 Read GetV;
  183. Published
  184. Procedure TestEmpty;
  185. Procedure TestEmptyDeprecated;
  186. Procedure TestEmptyPlatform;
  187. Procedure TestOneField;
  188. Procedure TestOneFieldDeprecated;
  189. Procedure TestOneFieldPlatform;
  190. Procedure TestOneFieldSemicolon;
  191. Procedure TestOneFieldSemicolonDeprecated;
  192. Procedure TestOneFieldSemicolonPlatform;
  193. Procedure TestOneDeprecatedField;
  194. Procedure TestOneDeprecatedFieldDeprecated;
  195. Procedure TestOneDeprecatedFieldPlatform;
  196. Procedure TestOnePlatformField;
  197. Procedure TestOnePlatformFieldDeprecated;
  198. Procedure TestOnePlatformFieldPlatform;
  199. Procedure TestTwoFields;
  200. Procedure TestTwoFieldDeprecated;
  201. Procedure TestTwoFieldPlatform;
  202. Procedure TestTwoFieldsFirstDeprecated;
  203. Procedure TestTwoFieldsFirstDeprecatedDeprecated;
  204. Procedure TestTwoFieldsFirstDeprecatedPlatform;
  205. Procedure TestTwoFieldsSecondDeprecated;
  206. Procedure TestTwoFieldsSecondDeprecatedDeprecated;
  207. Procedure TestTwoFieldsSecondDeprecatedPlatform;
  208. Procedure TestTwoFieldsBothDeprecated;
  209. Procedure TestTwoFieldsBothDeprecatedDeprecated;
  210. Procedure TestTwoFieldsBothDeprecatedPlatform;
  211. Procedure TestTwoFieldsCombined;
  212. Procedure TestTwoFieldsCombinedDeprecated;
  213. Procedure TestTwoFieldsCombinedPlatform;
  214. Procedure TestTwoDeprecatedFieldsCombined;
  215. Procedure TestTwoDeprecatedFieldsCombinedDeprecated;
  216. Procedure TestTwoDeprecatedFieldsCombinedPlatform;
  217. Procedure TestNested;
  218. Procedure TestNestedDeprecated;
  219. Procedure TestNestedPlatform;
  220. procedure TestNestedSemicolon;
  221. procedure TestNestedSemicolonDeprecated;
  222. procedure TestNestedSemicolonPlatform;
  223. procedure TestNestedFirst;
  224. procedure TestNestedFirstDeprecated;
  225. procedure TestNestedFirstPlatform;
  226. Procedure TestDeprecatedNested;
  227. Procedure TestDeprecatedNestedDeprecated;
  228. Procedure TestDeprecatedNestedPlatform;
  229. procedure TestDeprecatedNestedFirst;
  230. procedure TestDeprecatedNestedFirstDeprecated;
  231. procedure TestDeprecatedNestedFirstPlatform;
  232. Procedure TestVariantNoStorage;
  233. procedure TestVariantNoStorageDeprecated;
  234. procedure TestVariantNoStoragePlatform;
  235. Procedure TestVariantStorage;
  236. procedure TestVariantStorageDeprecated;
  237. procedure TestVariantStoragePlatform;
  238. Procedure TestDeprecatedVariantNoStorage;
  239. procedure TestDeprecatedVariantNoStorageDeprecated;
  240. procedure TestDeprecatedVariantNoStoragePlatform;
  241. Procedure TestDeprecatedVariantStorage;
  242. procedure TestDeprecatedVariantStorageDeprecated;
  243. procedure TestDeprecatedVariantStoragePlatform;
  244. Procedure TestTwoVariantsNoStorage;
  245. procedure TestTwoVariantsNoStorageDeprecated;
  246. procedure TestTwoVariantsNoStoragePlatform;
  247. Procedure TestTwoVariantsStorage;
  248. procedure TestTwoVariantsStorageDeprecated;
  249. procedure TestTwoVariantsStoragePlatform;
  250. Procedure TestTwoVariantsFirstDeprecatedStorage;
  251. procedure TestTwoVariantsFirstDeprecatedStorageDeprecated;
  252. procedure TestTwoVariantsFirstDeprecatedStoragePlatform;
  253. Procedure TestTwoVariantsSecondDeprecatedStorage;
  254. procedure TestTwoVariantsSecondDeprecatedStorageDeprecated;
  255. procedure TestTwoVariantsSecondDeprecatedStoragePlatform;
  256. Procedure TestVariantTwoLabels;
  257. Procedure TestVariantTwoLabelsDeprecated;
  258. Procedure TestVariantTwoLabelsPlatform;
  259. Procedure TestTwoVariantsTwoLabels;
  260. Procedure TestTwoVariantsTwoLabelsDeprecated;
  261. Procedure TestTwoVariantsTwoLabelsPlatform;
  262. Procedure TestVariantNestedRecord;
  263. Procedure TestVariantNestedRecordDeprecated;
  264. Procedure TestVariantNestedRecordPlatform;
  265. Procedure TestVariantNestedVariant;
  266. Procedure TestVariantNestedVariantDeprecated;
  267. Procedure TestVariantNestedVariantPlatForm;
  268. Procedure TestVariantNestedVariantFirstDeprecated;
  269. Procedure TestVariantNestedVariantFirstDeprecatedDeprecated;
  270. Procedure TestVariantNestedVariantFirstDeprecatedPlatform;
  271. Procedure TestVariantNestedVariantSecondDeprecated;
  272. Procedure TestVariantNestedVariantSecondDeprecatedDeprecated;
  273. Procedure TestVariantNestedVariantSecondDeprecatedPlatform;
  274. Procedure TestVariantNestedVariantBothDeprecated;
  275. Procedure TestVariantNestedVariantBothDeprecatedDeprecated;
  276. Procedure TestVariantNestedVariantBothDeprecatedPlatform;
  277. end;
  278. { TTestProcedureTypeParser }
  279. TCallingConventionTest = Procedure (CC : TCallingConvention;Const AHint : String) of object;
  280. TTestProcedureTypeParser = Class(TBaseTestTypeParser)
  281. Private
  282. FProc : TPasProcedureType;
  283. procedure CheckArrayOfConstArgument(Aindex: Integer; Ac: TArgumentAccess);
  284. Protected
  285. procedure DoTestFunction(CC: TCallingConvention; const AHint: String);
  286. procedure DoTestFunctionOfObject(CC: TCallingConvention; const AHint: String);
  287. procedure DoTestFunctionOneArg(CC: TCallingConvention; const AHint: String);
  288. procedure DoTestFunctionOneArgOfObject(CC: TCallingConvention; const AHint: String);
  289. procedure DoTestProcedureOfObject(CC: TCallingConvention; const AHint: String);
  290. procedure DoTestProcedureOfObjectOneArg(CC: TCallingConvention; const AHint: String);
  291. procedure DoTestProcedureIsNested(CC: TCallingConvention; const AHint: String);
  292. procedure DoTestProcedureIsNestedOneArg(CC: TCallingConvention; const AHint: String);
  293. procedure CheckOpenArrayArgument(Ac: TArgumentAccess);
  294. procedure DoTestProcedureArrayOfConst(CC: TCallingConvention; const AHint: String);
  295. procedure DoTestProcedureOpenArray(CC: TCallingConvention; const AHint: String);
  296. procedure DoTestProcedureConstOpenArray(CC: TCallingConvention; const AHint: String);
  297. procedure DoTestProcedureVarOpenArray(CC: TCallingConvention; const AHint: String);
  298. procedure DoTestProcedureOutOpenArray(CC: TCallingConvention; const AHint: String);
  299. procedure DoTestProcedureOneArgDefault(CC: TCallingConvention;const AHint: String);
  300. procedure DoTestProcedureOneArgDefaultExpr(CC: TCallingConvention;const AHint: String);
  301. procedure DoTestProcedureOneArgDefaultSet(CC: TCallingConvention;const AHint: String);
  302. procedure DoTestProcedureOneConstArgDefault(CC: TCallingConvention; const AHint: String);
  303. procedure DoTestProcedureOneVarArgDefault(CC: TCallingConvention; const AHint: String);
  304. procedure DoTestProcedureOneOutArgDefault(CC: TCallingConvention; const AHint: String);
  305. function CheckArgument(AIndex : Integer; Const AName,ATypeName : String; AAccess : TArgumentAccess) : TPasArgument;
  306. Function ParseType(ASource : String; CC : TCallingConvention; ATypeClass : TClass;Const AHint : String = '') : TPasProcedureType; virtual; overload;
  307. Procedure DoTestProcedureDecl(CC : TCallingConvention; Const AHint : String);
  308. Procedure DoTestProcedureOneArgDecl(CC : TCallingConvention; Const AHint : String);
  309. Procedure DoTestProcedureOneVarArgDecl(CC : TCallingConvention; Const AHint : String);
  310. Procedure DoTestProcedureOneConstArgDecl(CC : TCallingConvention; Const AHint : String);
  311. Procedure DoTestProcedureOneOutArgDecl(CC : TCallingConvention; Const AHint : String);
  312. Procedure DoTestProcedureTwoArgsDecl(CC : TCallingConvention; Const AHint : String);
  313. Procedure DoTestProcedureTwoVarArgsDecl(CC : TCallingConvention; Const AHint : String);
  314. Procedure DoTestProcedureTwoConstArgsDecl(CC : TCallingConvention; Const AHint : String);
  315. Procedure DoTestProcedureTwoOutArgsDecl(CC : TCallingConvention; Const AHint : String);
  316. Procedure DoTestProcedureTwoCombinedArgsDecl(CC : TCallingConvention; Const AHint : String);
  317. Procedure DoTestProcedureTwoCombinedVarArgsDecl(CC : TCallingConvention; Const AHint : String);
  318. Procedure DoTestProcedureTwoCombinedConstArgsDecl(CC : TCallingConvention; Const AHint : String);
  319. Procedure DoTestProcedureTwoCombinedOutArgsDecl(CC : TCallingConvention; Const AHint : String);
  320. Procedure DoTestProcedureDefaultConstArgsDecl(CC : TCallingConvention; Const AHint : String);
  321. procedure DoTestProcedureUntypedArgDecl(CC: TCallingConvention; const AHint: String);
  322. procedure DoTestProcedureUntypedConstArgDecl(CC: TCallingConvention; const AHint: String);
  323. procedure DoTestProcedureUntypedOutArgDecl(CC: TCallingConvention; const AHint: String);
  324. procedure DoTestProcedureUntypedDefArg;
  325. Procedure TestCallingConventions(Proc : TCallingConventionTest; Const AHint : String);
  326. Procedure TestCallingConventions(Proc : TCallingConventionTest);
  327. Function FuncProc : TPasFunctionType;
  328. Property Proc : TPasProcedureType Read FProc;
  329. Published
  330. Procedure TestProcedure;
  331. Procedure TestProcedureOneArg;
  332. Procedure TestProcedureOneVarArg;
  333. Procedure TestProcedureOneConstArg;
  334. Procedure TestProcedureOneOutArg;
  335. Procedure TestProcedureTwoArgs;
  336. Procedure TestProcedureTwoVarArgs;
  337. Procedure TestProcedureTwoConstArgs;
  338. Procedure TestProcedureTwoOutArgs;
  339. Procedure TestProcedureTwoCombinedArgs;
  340. Procedure TestProcedureTwoCombinedVarArgs;
  341. Procedure TestProcedureTwoCombinedConstArgs;
  342. Procedure TestProcedureTwoCombinedOutArgs;
  343. Procedure TestProcedureDefaultConstArgs;
  344. Procedure TestProcedureUntypedArg;
  345. Procedure TestProcedureUntypedConstArg;
  346. Procedure TestProcedureUntypedOutArg;
  347. Procedure TestProcedureUntypedDefArg;
  348. Procedure TestProcedureOneArgDefault;
  349. Procedure TestProcedureOneArgDefaultExpr;
  350. Procedure TestProcedureOneArgDefaultSet;
  351. Procedure TestProcedureOneVarArgDefault;
  352. Procedure TestProcedureOneConstArgDefault;
  353. Procedure TestProcedureOneOutArgDefault;
  354. Procedure TestProcedureNoMultiArgDefaults;
  355. Procedure TestProcedureOpenArray;
  356. Procedure TestProcedureConstOpenArray;
  357. Procedure TestProcedureOutOpenArray;
  358. Procedure TestProcedureVarOpenArray;
  359. Procedure TestProcedureArrayOfConst;
  360. Procedure TestProcedureOfObject;
  361. Procedure TestProcedureOfObjectOneArg;
  362. Procedure TestProcedureIsNested;
  363. Procedure TestProcedureIsNesteOneArg;
  364. Procedure TestFunction;
  365. Procedure TestFunctionOneArg;
  366. Procedure TestFunctionOfObject;
  367. Procedure TestFunctionOneArgOfObject;
  368. end;
  369. implementation
  370. uses typinfo;
  371. { TTestProcedureTypeParser }
  372. procedure TTestProcedureTypeParser.DoTestProcedureUntypedArgDecl(
  373. CC: TCallingConvention; const AHint: String);
  374. Var
  375. A : TPasArgument;
  376. begin
  377. ParseType('procedure(var A)',CC,TPasProcedureType,AHint);
  378. AssertEquals('Argument count',1,Proc.Args.Count);
  379. A:=CheckArgument(0,'A','',argVar);
  380. AssertNull('No argument type', A.ArgType)
  381. end;
  382. procedure TTestProcedureTypeParser.DoTestProcedureUntypedConstArgDecl(
  383. CC: TCallingConvention; const AHint: String);
  384. Var
  385. A : TPasArgument;
  386. begin
  387. ParseType('procedure(const A)',CC,TPasProcedureType,AHint);
  388. AssertEquals('Argument count',1,Proc.Args.Count);
  389. A:=CheckArgument(0,'A','',argConst);
  390. AssertNull('No argument type', A.ArgType)
  391. end;
  392. procedure TTestProcedureTypeParser.DoTestProcedureUntypedOutArgDecl(
  393. CC: TCallingConvention; const AHint: String);
  394. Var
  395. A : TPasArgument;
  396. begin
  397. ParseType('procedure(out A)',CC,TPasProcedureType,AHint);
  398. AssertEquals('Argument count',1,Proc.Args.Count);
  399. A:=CheckArgument(0,'A','',argOut);
  400. AssertNull('No argument type', A.ArgType)
  401. end;
  402. procedure TTestProcedureTypeParser.DoTestProcedureUntypedDefArg;
  403. begin
  404. ParseType('procedure(A)',ccdefault,TPasProcedureType,'');
  405. end;
  406. procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDefault(
  407. CC: TCallingConvention; const AHint: String);
  408. Var
  409. A : TPasArgument;
  410. begin
  411. ParseType('procedure(var A : Integer = 1)',CC,TPasProcedureType,AHint);
  412. AssertEquals('Argument count',1,Proc.Args.Count);
  413. A:=CheckArgument(0,'A','Integer',argVar);
  414. AssertNotNull('have default argument type', A.Value);
  415. AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  416. AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
  417. end;
  418. procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDefault(
  419. CC: TCallingConvention; const AHint: String);
  420. Var
  421. A : TPasArgument;
  422. begin
  423. ParseType('procedure(out A : Integer = 1)',CC,TPasProcedureType,AHint);
  424. AssertEquals('Argument count',1,Proc.Args.Count);
  425. A:=CheckArgument(0,'A','Integer',argOut);
  426. AssertNotNull('have default argument type', A.Value);
  427. AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  428. AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
  429. end;
  430. procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDefault(
  431. CC: TCallingConvention; const AHint: String);
  432. Var
  433. A : TPasArgument;
  434. begin
  435. ParseType('procedure(const A : Integer = 1)',CC,TPasProcedureType,AHint);
  436. AssertEquals('Argument count',1,Proc.Args.Count);
  437. A:=CheckArgument(0,'A','Integer',argConst);
  438. AssertNotNull('have default argument type', A.Value);
  439. AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  440. AssertEquals('argument expr type', '1', TPrimitiveExpr(A.ValueExpr).Value);
  441. end;
  442. procedure TTestProcedureTypeParser.DoTestProcedureArrayOfConst(
  443. CC: TCallingConvention; const AHint: String);
  444. begin
  445. ParseType('procedure(A : Array of const)',CC,TPasProcedureType,AHint);
  446. AssertEquals('Argument count',1,Proc.Args.Count);
  447. CheckArrayOfConstArgument(0,argDefault);
  448. end;
  449. procedure TTestProcedureTypeParser.DoTestProcedureOfObject(
  450. CC: TCallingConvention; const AHint: String);
  451. begin
  452. ParseType('procedure of Object',CC,TPasProcedureType,AHint);
  453. AssertEquals('Argument count',0,Proc.Args.Count);
  454. AssertEquals('Is OF Object',True,Proc.IsOfObject);
  455. end;
  456. procedure TTestProcedureTypeParser.DoTestProcedureOfObjectOneArg(
  457. CC: TCallingConvention; const AHint: String);
  458. begin
  459. ParseType('procedure (A : integer)of Object',CC,TPasProcedureType,AHint);
  460. AssertEquals('Argument count',1,Proc.Args.Count);
  461. AssertEquals('Is OF Object',True,Proc.IsOfObject);
  462. CheckArgument(0,'A','Integer',argDefault);
  463. end;
  464. procedure TTestProcedureTypeParser.DoTestProcedureIsNested(
  465. CC: TCallingConvention; const AHint: String);
  466. begin
  467. ParseType('procedure is nested',CC,TPasProcedureType,AHint);
  468. AssertEquals('Argument count',0,Proc.Args.Count);
  469. AssertEquals('Is nested',True,Proc.IsNested);
  470. end;
  471. procedure TTestProcedureTypeParser.DoTestProcedureIsNestedOneArg(
  472. CC: TCallingConvention; const AHint: String);
  473. begin
  474. ParseType('procedure (A : integer) is nested',CC,TPasProcedureType,AHint);
  475. AssertEquals('Argument count',1,Proc.Args.Count);
  476. AssertEquals('Is nested',True,Proc.IsNested);
  477. CheckArgument(0,'A','Integer',argDefault);
  478. end;
  479. procedure TTestProcedureTypeParser.CheckArrayOfConstArgument(Aindex : Integer; Ac : TArgumentAccess);
  480. Var
  481. A : TPasArgument;
  482. T : TPasArrayType;
  483. begin
  484. A:=CheckArgument(Aindex,'A','',ac);
  485. AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
  486. T:=A.ArgType as TPasArrayType;
  487. AssertNull('Have Element type',T.ElType);
  488. end;
  489. procedure TTestProcedureTypeParser.DoTestFunction(CC: TCallingConvention;
  490. const AHint: String);
  491. begin
  492. ParseType('function : integer',CC,TPasFunctionType,AHint);
  493. AssertEquals('Argument count',0,Proc.Args.Count);
  494. AssertEquals('Is OF Object',False,Proc.IsOfObject);
  495. AssertNotNull('Have result',FuncProc.ResultEl);
  496. AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  497. AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  498. AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  499. AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
  500. end;
  501. procedure TTestProcedureTypeParser.DoTestFunctionOfObject(CC: TCallingConvention;
  502. const AHint: String);
  503. begin
  504. ParseType('function : integer of object',CC,TPasFunctionType,AHint);
  505. AssertEquals('Argument count',0,Proc.Args.Count);
  506. AssertEquals('Is OF Object',True,Proc.IsOfObject);
  507. AssertNotNull('Have result',FuncProc.ResultEl);
  508. AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  509. AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  510. AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  511. AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
  512. end;
  513. procedure TTestProcedureTypeParser.DoTestFunctionOneArg(CC: TCallingConvention;
  514. const AHint: String);
  515. begin
  516. ParseType('function (A : Integer) : Integer',CC,TPasFunctionType,AHint);
  517. AssertEquals('Argument count',1,Proc.Args.Count);
  518. CheckArgument(0,'A','Integer',argDefault);
  519. AssertNotNull('Have result',FuncProc.ResultEl);
  520. AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  521. AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  522. AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  523. AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
  524. end;
  525. procedure TTestProcedureTypeParser.DoTestFunctionOneArgOfObject(
  526. CC: TCallingConvention; const AHint: String);
  527. begin
  528. ParseType('function (A : Integer) : Integer of object',CC,TPasFunctionType,AHint);
  529. AssertEquals('Argument count',1,Proc.Args.Count);
  530. AssertEquals('Is OF Object',True,Proc.IsOfObject);
  531. CheckArgument(0,'A','Integer',argDefault);
  532. AssertNotNull('Have result',FuncProc.ResultEl);
  533. AssertEquals('Result type class',TPasResultElement,FuncProc.ResultEl.ClassType);
  534. AssertNotNull('Have result',FuncProc.ResultEl.ResultType);
  535. AssertEquals('Result type element class ',TPasUnresolvedTypeRef,FuncProc.ResultEl.ResultType.ClassType);
  536. AssertEquals('Result type element name','Integer',FuncProc.ResultEl.ResultType.Name);
  537. end;
  538. procedure TTestProcedureTypeParser.CheckOpenArrayArgument(Ac : TArgumentAccess);
  539. Var
  540. A : TPasArgument;
  541. T : TPasArrayType;
  542. begin
  543. A:=CheckArgument(0,'A','',ac);
  544. AssertEquals('ArrayType',TPasArrayType,A.ArgType.ClassType);
  545. T:=A.ArgType as TPasArrayType;
  546. AssertNotNull('Have Element type',T.ElType);
  547. AssertEquals('Element type',TPasUnresolvedTypeRef,T.ElType.ClassType);
  548. AssertEquals('Element type name','Integer',TPasUnresolvedTypeRef(T.ElType).Name);
  549. AssertEquals('No boundaries','',T.IndexRange);
  550. end;
  551. procedure TTestProcedureTypeParser.DoTestProcedureOpenArray(
  552. CC: TCallingConvention; const AHint: String);
  553. begin
  554. ParseType('procedure(A : Array of integer)',CC,TPasProcedureType,AHint);
  555. AssertEquals('Argument count',1,Proc.Args.Count);
  556. CheckOpenArrayArgument(argDefault);
  557. end;
  558. procedure TTestProcedureTypeParser.DoTestProcedureConstOpenArray(
  559. CC: TCallingConvention; const AHint: String);
  560. begin
  561. ParseType('procedure(const A : Array of integer)',CC,TPasProcedureType,AHint);
  562. AssertEquals('Argument count',1,Proc.Args.Count);
  563. CheckOpenArrayArgument(argConst);
  564. end;
  565. procedure TTestProcedureTypeParser.DoTestProcedureVarOpenArray(
  566. CC: TCallingConvention; const AHint: String);
  567. begin
  568. ParseType('procedure(var A : Array of integer)',CC,TPasProcedureType,AHint);
  569. AssertEquals('Argument count',1,Proc.Args.Count);
  570. CheckOpenArrayArgument(argVar);
  571. end;
  572. procedure TTestProcedureTypeParser.DoTestProcedureOutOpenArray(
  573. CC: TCallingConvention; const AHint: String);
  574. begin
  575. ParseType('procedure(out A : Array of integer)',CC,TPasProcedureType,AHint);
  576. AssertEquals('Argument count',1,Proc.Args.Count);
  577. CheckOpenArrayArgument(argOut);
  578. end;
  579. procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefault(
  580. CC: TCallingConvention; const AHint: String);
  581. Var
  582. A : TPasArgument;
  583. begin
  584. ParseType('procedure(A : Integer = 1)',CC,TPasProcedureType,AHint);
  585. AssertEquals('Argument count',1,Proc.Args.Count);
  586. A:=CheckArgument(0,'A','Integer',argDefault);
  587. AssertNotNull('have default argument type', A.ValueExpr);
  588. AssertEquals('argument expr type', TPrimitiveExpr, A.ValueExpr.ClassType);
  589. AssertEquals('argument expr value', '1', TPrimitiveExpr(A.ValueExpr).Value);
  590. end;
  591. procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultExpr(
  592. CC: TCallingConvention; const AHint: String);
  593. Var
  594. A : TPasArgument;
  595. B : TBinaryExpr;
  596. begin
  597. ParseType('procedure(A : Integer = 1+2)',CC,TPasProcedureType,AHint);
  598. AssertEquals('Argument count',1,Proc.Args.Count);
  599. A:=CheckArgument(0,'A','Integer',argDefault);
  600. AssertNotNull('have default argument type', A.ValueExpr);
  601. AssertEquals('argument expr type', TBinaryExpr, A.ValueExpr.ClassType);
  602. B:=TBinaryExpr(A.ValueExpr);
  603. AssertNotNull('have left expr', B.Left);
  604. AssertEquals('argument left expr type', TPrimitiveExpr, B.left.ClassType);
  605. AssertEquals('argument left expr value', '1', TPrimitiveExpr(B.Left).Value);
  606. AssertNotNull('have right expr', B.Right);
  607. AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType);
  608. AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value);
  609. end;
  610. procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet(
  611. CC: TCallingConvention; const AHint: String);
  612. Var
  613. A : TPasArgument;
  614. B : TParamsExpr;
  615. begin
  616. ParseType('procedure(A : TB = [])',CC,TPasProcedureType,AHint);
  617. AssertEquals('Argument count',1,Proc.Args.Count);
  618. A:=CheckArgument(0,'A','TB',argDefault);
  619. AssertNotNull('have default argument type', A.ValueExpr);
  620. AssertEquals('argument expr type', TParamsExpr, A.ValueExpr.ClassType);
  621. B:=TParamsExpr(A.ValueExpr);
  622. AssertEquals('No params',0,Length(B.Params));
  623. end;
  624. Function TTestProcedureTypeParser.CheckArgument(AIndex: Integer; const AName,
  625. ATypeName: String; AAccess: TArgumentAccess) : TPAsArgument;
  626. Var
  627. A : TPasArgument;
  628. C : String;
  629. begin
  630. C:='Argument '+IntToStr(AIndex)+' : ';
  631. AssertNotNull(C+'assigned',Proc.Args[AIndex]);
  632. AssertEquals(C+'class',TPasArgument,TObject(Proc.Args[AIndex]).ClassType);
  633. A:=TPasArgument(Proc.Args[AIndex]);
  634. AssertEquals(C+'Access',AAccess,A.Access);
  635. AssertEquals(C+'name',AName,A.Name);
  636. if (ATypeName<>'') then
  637. begin
  638. AssertNotNull(C+'type assigned',A.ArgType);
  639. if (ATypeName[1]='[') then
  640. AssertEquals(C+'type classname',LowerCase(Copy(ATypeName,2,Length(ATypeName)-2)),LowerCase(A.ArgType.ClassName))
  641. else
  642. AssertEquals(C+'type name',ATypeName,A.ArgType.Name);
  643. end;
  644. Result:=A;
  645. end;
  646. function TTestProcedureTypeParser.ParseType(ASource: String;
  647. CC: TCallingConvention; ATypeClass: TClass; const AHint: String): TPasProcedureType;
  648. begin
  649. if CC=ccdefault then
  650. Result:=TPasProcedureType(ParseType(ASource,ATypeClass,AHint))
  651. else
  652. begin
  653. if (AHint<>'') then
  654. Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC]+';',ATypeClass,AHint))
  655. else
  656. Result:=TPasProcedureType(ParseType(ASource+';' +cCallingConventions[CC],ATypeClass,AHint));
  657. end;
  658. FProc:=Result;
  659. AssertEquals('Correct calling convention for procedural type',cc,Result.CallingConvention);
  660. end;
  661. procedure TTestProcedureTypeParser.DoTestProcedureDecl(CC: TCallingConvention; Const AHint : String);
  662. begin
  663. ParseType('procedure',CC,TPasProcedureType,AHint);
  664. AssertEquals('Argument count',0,Proc.Args.Count);
  665. end;
  666. procedure TTestProcedureTypeParser.DoTestProcedureOneArgDecl(
  667. CC: TCallingConvention; const AHint: String);
  668. begin
  669. ParseType('procedure(A : Integer)',CC,TPasProcedureType,AHint);
  670. AssertEquals('Argument count',1,Proc.Args.Count);
  671. CheckArgument(0,'A','Integer',argDefault);
  672. end;
  673. procedure TTestProcedureTypeParser.DoTestProcedureOneVarArgDecl(
  674. CC: TCallingConvention; const AHint: String);
  675. begin
  676. ParseType('procedure(var A : Integer)',CC,TPasProcedureType,AHint);
  677. AssertEquals('Argument count',1,Proc.Args.Count);
  678. CheckArgument(0,'A','Integer',argVar);
  679. end;
  680. procedure TTestProcedureTypeParser.DoTestProcedureOneConstArgDecl(
  681. CC: TCallingConvention; const AHint: String);
  682. begin
  683. ParseType('procedure(const A : Integer)',CC,TPasProcedureType,AHint);
  684. AssertEquals('Argument count',1,Proc.Args.Count);
  685. CheckArgument(0,'A','Integer',argConst);
  686. end;
  687. procedure TTestProcedureTypeParser.DoTestProcedureOneOutArgDecl(
  688. CC: TCallingConvention; const AHint: String);
  689. begin
  690. ParseType('procedure(out A : Integer)',CC,TPasProcedureType,AHint);
  691. AssertEquals('Argument count',1,Proc.Args.Count);
  692. CheckArgument(0,'A','Integer',argOut);
  693. end;
  694. procedure TTestProcedureTypeParser.DoTestProcedureTwoArgsDecl(
  695. CC: TCallingConvention; const AHint: String);
  696. begin
  697. ParseType('procedure(A : Integer;B : String)',CC,TPasProcedureType,AHint);
  698. AssertEquals('Argument count',2,Proc.Args.Count);
  699. CheckArgument(0,'A','Integer',argDefault);
  700. CheckArgument(1,'B','[TPasAliasType]',argDefault);
  701. end;
  702. procedure TTestProcedureTypeParser.DoTestProcedureTwoVarArgsDecl(
  703. CC: TCallingConvention; const AHint: String);
  704. begin
  705. ParseType('procedure(Var A : Integer;Var B : String)',CC,TPasProcedureType,AHint);
  706. AssertEquals('Argument count',2,Proc.Args.Count);
  707. CheckArgument(0,'A','Integer',argVar);
  708. CheckArgument(1,'B','[TPasAliasType]',argVar);
  709. end;
  710. procedure TTestProcedureTypeParser.DoTestProcedureTwoConstArgsDecl(
  711. CC: TCallingConvention; const AHint: String);
  712. begin
  713. ParseType('procedure(const A : Integer;Const B : String)',CC,TPasProcedureType,AHint);
  714. AssertEquals('Argument count',2,Proc.Args.Count);
  715. CheckArgument(0,'A','Integer',argConst);
  716. CheckArgument(1,'B','[TPasAliasType]',argConst);
  717. end;
  718. procedure TTestProcedureTypeParser.DoTestProcedureTwoOutArgsDecl(
  719. CC: TCallingConvention; const AHint: String);
  720. begin
  721. ParseType('procedure(out A : Integer;Out B : String)',CC,TPasProcedureType,AHint);
  722. AssertEquals('Argument count',2,Proc.Args.Count);
  723. CheckArgument(0,'A','Integer',argOut);
  724. CheckArgument(1,'B','[TPasAliasType]',argOut);
  725. end;
  726. procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedArgsDecl(
  727. CC: TCallingConvention; const AHint: String);
  728. begin
  729. ParseType('procedure(A,B : Integer)',CC,TPasProcedureType,AHint);
  730. AssertEquals('Argument count',2,Proc.Args.Count);
  731. CheckArgument(0,'A','Integer',argDefault);
  732. CheckArgument(1,'B','Integer',argDefault);
  733. end;
  734. procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedVarArgsDecl(
  735. CC: TCallingConvention; const AHint: String);
  736. begin
  737. ParseType('procedure(Var A,B : Integer)',CC,TPasProcedureType,AHint);
  738. AssertEquals('Argument count',2,Proc.Args.Count);
  739. CheckArgument(0,'A','Integer',argVar);
  740. CheckArgument(1,'B','Integer',argVar);
  741. end;
  742. procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedConstArgsDecl(
  743. CC: TCallingConvention; const AHint: String);
  744. begin
  745. ParseType('procedure(Const A,B : Integer)',CC,TPasProcedureType,AHint);
  746. AssertEquals('Argument count',2,Proc.Args.Count);
  747. CheckArgument(0,'A','Integer',argConst);
  748. CheckArgument(1,'B','Integer',argConst);
  749. end;
  750. procedure TTestProcedureTypeParser.DoTestProcedureTwoCombinedOutArgsDecl(
  751. CC: TCallingConvention; const AHint: String);
  752. begin
  753. ParseType('procedure(Out A,B : Integer)',CC,TPasProcedureType,AHint);
  754. AssertEquals('Argument count',2,Proc.Args.Count);
  755. CheckArgument(0,'A','Integer',argOut);
  756. CheckArgument(1,'B','Integer',argOut);
  757. end;
  758. procedure TTestProcedureTypeParser.DoTestProcedureDefaultConstArgsDecl(
  759. CC: TCallingConvention; const AHint: String);
  760. begin
  761. ParseType('procedure(A : Integer; Const B : Integer)',CC,TPasProcedureType,AHint);
  762. AssertEquals('Argument count',2,Proc.Args.Count);
  763. CheckArgument(0,'A','Integer',argDefault);
  764. CheckArgument(1,'B','Integer',argConst);
  765. end;
  766. procedure TTestProcedureTypeParser.TestCallingConventions(
  767. Proc: TCallingConventionTest; Const AHint : String);
  768. Var
  769. CC : TCallingConvention;
  770. begin
  771. For cc:=ccDefault to High(TCallingConvention) do
  772. begin
  773. if CC<>ccDefault then
  774. Setup;
  775. try
  776. Proc(cc,AHint);
  777. finally
  778. tearDown;
  779. end;
  780. end;
  781. end;
  782. procedure TTestProcedureTypeParser.TestCallingConventions(
  783. Proc: TCallingConventionTest);
  784. begin
  785. TestCallingConventions(Proc,'');
  786. Setup;
  787. TestCallingConventions(Proc,'deprecated');
  788. Setup;
  789. TestCallingConventions(Proc,'platform');
  790. end;
  791. function TTestProcedureTypeParser.FuncProc: TPasFunctionType;
  792. begin
  793. Result:=Proc as TPasFunctionType;
  794. end;
  795. procedure TTestProcedureTypeParser.TestProcedure;
  796. begin
  797. TestCallingConventions(@DoTestProcedureDecl);
  798. end;
  799. procedure TTestProcedureTypeParser.TestProcedureOneArg;
  800. begin
  801. TestCallingConventions(@DoTestProcedureOneArgDecl);
  802. end;
  803. procedure TTestProcedureTypeParser.TestProcedureOneVarArg;
  804. begin
  805. TestCallingConventions(@DoTestProcedureOneVarArgDecl);
  806. end;
  807. procedure TTestProcedureTypeParser.TestProcedureOneConstArg;
  808. begin
  809. TestCallingConventions(@DoTestProcedureOneConstArgDecl);
  810. end;
  811. procedure TTestProcedureTypeParser.TestProcedureOneOutArg;
  812. begin
  813. TestCallingConventions(@DoTestProcedureOneOutArgDecl);
  814. end;
  815. procedure TTestProcedureTypeParser.TestProcedureTwoArgs;
  816. begin
  817. TestCallingConventions(@DoTestProcedureTwoArgsDecl);
  818. end;
  819. procedure TTestProcedureTypeParser.TestProcedureTwoVarArgs;
  820. begin
  821. TestCallingConventions(@DoTestProcedureTwoVarArgsDecl);
  822. end;
  823. procedure TTestProcedureTypeParser.TestProcedureTwoConstArgs;
  824. begin
  825. TestCallingConventions(@DoTestProcedureTwoConstArgsDecl);
  826. end;
  827. procedure TTestProcedureTypeParser.TestProcedureTwoOutArgs;
  828. begin
  829. TestCallingConventions(@DoTestProcedureTwoOutArgsDecl);
  830. end;
  831. procedure TTestProcedureTypeParser.TestProcedureTwoCombinedArgs;
  832. begin
  833. TestCallingConventions(@DoTestProcedureTwoCombinedArgsDecl);
  834. end;
  835. procedure TTestProcedureTypeParser.TestProcedureTwoCombinedVarArgs;
  836. begin
  837. TestCallingConventions(@DoTestProcedureTwoCombinedVarArgsDecl);
  838. end;
  839. procedure TTestProcedureTypeParser.TestProcedureTwoCombinedConstArgs;
  840. begin
  841. TestCallingConventions(@DoTestProcedureTwoCombinedConstArgsDecl);
  842. end;
  843. procedure TTestProcedureTypeParser.TestProcedureTwoCombinedOutArgs;
  844. begin
  845. TestCallingConventions(@DoTestProcedureTwoCombinedOutArgsDecl);
  846. end;
  847. procedure TTestProcedureTypeParser.TestProcedureDefaultConstArgs;
  848. begin
  849. TestCallingConventions(@DoTestProcedureDefaultConstArgsDecl);
  850. end;
  851. procedure TTestProcedureTypeParser.TestProcedureUntypedArg;
  852. begin
  853. TestCallingConventions(@DoTestProcedureUntypedArgDecl);
  854. end;
  855. procedure TTestProcedureTypeParser.TestProcedureUntypedConstArg;
  856. begin
  857. TestCallingConventions(@DoTestProcedureUntypedConstArgDecl);
  858. end;
  859. procedure TTestProcedureTypeParser.TestProcedureUntypedOutArg;
  860. begin
  861. TestCallingConventions(@DoTestProcedureUntypedOutArgDecl);
  862. end;
  863. procedure TTestProcedureTypeParser.TestProcedureUntypedDefArg;
  864. begin
  865. AssertException('No untyped arg by value',EParserError,@DoTestProcedureUntypedDefArg)
  866. end;
  867. procedure TTestProcedureTypeParser.TestProcedureOneArgDefault;
  868. begin
  869. TestCallingConventions(@DoTestProcedureOneArgDefault);
  870. end;
  871. procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultExpr;
  872. begin
  873. TestCallingConventions(@DoTestProcedureOneArgDefaultExpr);
  874. end;
  875. procedure TTestProcedureTypeParser.TestProcedureOneArgDefaultSet;
  876. begin
  877. TestCallingConventions(@DoTestProcedureOneArgDefaultSet);
  878. end;
  879. procedure TTestProcedureTypeParser.TestProcedureOneVarArgDefault;
  880. begin
  881. TestCallingConventions(@DoTestProcedureOneVarArgDefault);
  882. end;
  883. procedure TTestProcedureTypeParser.TestProcedureOneConstArgDefault;
  884. begin
  885. TestCallingConventions(@DoTestProcedureOneConstArgDefault);
  886. end;
  887. procedure TTestProcedureTypeParser.TestProcedureOneOutArgDefault;
  888. begin
  889. TestCallingConventions(@DoTestProcedureOneOutArgDefault);
  890. end;
  891. procedure TTestProcedureTypeParser.TestProcedureNoMultiArgDefaults;
  892. begin
  893. AssertParseTypeError('procedure (A,B : Integer = 1)');
  894. end;
  895. procedure TTestProcedureTypeParser.TestProcedureOpenArray;
  896. begin
  897. TestCallingConventions(@DoTestProcedureOpenArray);
  898. end;
  899. procedure TTestProcedureTypeParser.TestProcedureConstOpenArray;
  900. begin
  901. TestCallingConventions(@DoTestProcedureConstOpenArray);
  902. end;
  903. procedure TTestProcedureTypeParser.TestProcedureOutOpenArray;
  904. begin
  905. TestCallingConventions(@DoTestProcedureVarOpenArray);
  906. end;
  907. procedure TTestProcedureTypeParser.TestProcedureVarOpenArray;
  908. begin
  909. TestCallingConventions(@DoTestProcedureOutOpenArray);
  910. end;
  911. procedure TTestProcedureTypeParser.TestProcedureArrayOfConst;
  912. begin
  913. TestCallingConventions(@DoTestProcedureArrayOfConst);
  914. end;
  915. procedure TTestProcedureTypeParser.TestProcedureOfObject;
  916. begin
  917. TestCallingConventions(@DoTestProcedureOfObject);
  918. end;
  919. procedure TTestProcedureTypeParser.TestProcedureOfObjectOneArg;
  920. begin
  921. TestCallingConventions(@DoTestProcedureOfObjectOneArg);
  922. end;
  923. procedure TTestProcedureTypeParser.TestProcedureIsNested;
  924. begin
  925. TestCallingConventions(@DoTestProcedureIsNested);
  926. end;
  927. procedure TTestProcedureTypeParser.TestProcedureIsNesteOneArg;
  928. begin
  929. TestCallingConventions(@DoTestProcedureIsNestedOneArg);
  930. end;
  931. procedure TTestProcedureTypeParser.TestFunction;
  932. begin
  933. TestCallingConventions(@DoTestFunction);
  934. end;
  935. procedure TTestProcedureTypeParser.TestFunctionOneArg;
  936. begin
  937. TestCallingConventions(@DoTestFunctionOneArg);
  938. end;
  939. procedure TTestProcedureTypeParser.TestFunctionOfObject;
  940. begin
  941. TestCallingConventions(@DoTestFunctionOfObject);
  942. end;
  943. procedure TTestProcedureTypeParser.TestFunctionOneArgOfObject;
  944. begin
  945. TestCallingConventions(@DoTestFunctionOneArgOfObject);
  946. end;
  947. { TTestRecordTypeParser }
  948. function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasRecordType
  949. ): TPasVariable;
  950. begin
  951. AssertNotNull(R);
  952. AssertNotNull(R.Members);
  953. AssertTrue('Have AIndex elements',R.Members.Count>AIndex);
  954. AssertEquals('Correct class in member',TPasVariable,TObject(R.Members[AIndex]).ClassType);
  955. Result:=TPasVariable(R.Members[AIndex]);
  956. end;
  957. function TTestRecordTypeParser.GetField(AIndex: Integer; R: TPasVariant
  958. ): TPasVariable;
  959. begin
  960. AssertNotNull(R);
  961. AssertNotNull('Have variant members', R.Members);
  962. AssertNotNull('Have variant members member list',R.Members.Members);
  963. AssertTrue('Have AIndex elements',R.Members.Members.Count>AIndex);
  964. AssertEquals('Correct class in member',TPasVariable,TObject(R.Members.members[AIndex]).ClassType);
  965. Result:=TPasVariable(R.Members.Members[AIndex]);
  966. end;
  967. function TTestRecordTypeParser.GetF(AIndex: Integer): TPasVariable;
  968. begin
  969. Result:=GetField(AIndex,GetR);
  970. end;
  971. function TTestRecordTypeParser.GetR: TPasRecordType;
  972. begin
  973. Result:=TheType as TPasRecordType;
  974. end;
  975. function TTestRecordTypeParser.GetVariant(AIndex: Integer; R: TPasRecordType
  976. ): TPasVariant;
  977. begin
  978. AssertNotNull(R);
  979. AssertNotNull(R.Variants);
  980. AssertTrue('Have AIndex variant elements',R.Variants.Count>AIndex);
  981. AssertEquals('Correct class in variant',TPasVariant,TObject(R.Variants[AIndex]).ClassType);
  982. Result:=TPasVariant(R.Variants[AIndex]);
  983. end;
  984. function TTestRecordTypeParser.GetV(AIndex: Integer): TPasVariant;
  985. begin
  986. Result:=GetVariant(AIndex,GetR);
  987. end;
  988. procedure TTestRecordTypeParser.TestFields(const Fields: array of string;
  989. AHint: String; HaveVariant: Boolean);
  990. Var
  991. S : String;
  992. I : integer;
  993. begin
  994. S:='';
  995. For I:=Low(Fields) to High(Fields) do
  996. begin
  997. if (S<>'') then
  998. S:=S+sLineBreak;
  999. S:=S+' '+Fields[i];
  1000. end;
  1001. if (S<>'') then
  1002. S:=S+sLineBreak;
  1003. S:='record'+sLineBreak+s+' end';
  1004. ParseType(S,TPasRecordType,AHint);
  1005. if HaveVariant then
  1006. begin
  1007. AssertNotNull('Have variants',TheRecord.Variants);
  1008. AssertNotNull('Have variant type',TheRecord.VariantType);
  1009. end
  1010. else
  1011. begin
  1012. AssertNull('No variants',TheRecord.Variants);
  1013. AssertNull('No variant type',TheRecord.VariantType);
  1014. AssertEquals('No variant name','',TheRecord.VariantName);
  1015. end;
  1016. end;
  1017. procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);
  1018. begin
  1019. if (AType='') then
  1020. AType:='Integer';
  1021. AssertEquals('Have variant selector storage name',AName,TheRecord.VariantName);
  1022. AssertNotNull('Have variant selector type',TheRecord.VariantType);
  1023. AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantType.ClassType);
  1024. AssertEquals('Have variant selector type name',AType,TheRecord.VariantType.Name);
  1025. end;
  1026. procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
  1027. begin
  1028. TestFields([],AHint);
  1029. AssertNotNull('Have members array',TheRecord.Members);
  1030. AssertEquals('Zero members in array',0,TheRecord.Members.Count);
  1031. end;
  1032. procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints);
  1033. begin
  1034. AssertVariant1(Hints,['0']);
  1035. end;
  1036. procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
  1037. Var
  1038. I : Integer;
  1039. begin
  1040. AssertNotNull('Have variant 1',Variant1);
  1041. AssertNotNull('Variant 1 has Values ',Variant1.Values);
  1042. if Length(VariantLabels)=0 then
  1043. begin
  1044. AssertEquals('Have 1 value',1,Variant1.Values.Count);
  1045. AssertNotNull('Assigned value',Variant1.Values[0]);
  1046. AssertEquals('Expression',TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
  1047. AssertExpression('First value is 0',TPasExpr(Variant1.Values[0]),pekNumber,'0');
  1048. end
  1049. else
  1050. begin
  1051. AssertEquals('Have correct number of values',Length(VariantLabels),Variant1.Values.Count);
  1052. For I:=0 to Length(VariantLabels)-1 do
  1053. begin
  1054. AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[0]).CLassType);
  1055. AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
  1056. end;
  1057. end;
  1058. AssertNotNull('Have members',Variant1.Members);
  1059. AssertNotNull('Have member members',Variant1.Members.Members);
  1060. AssertNotNull('member 0 not null',Variant1.Members.Members[0]);
  1061. AssertEquals('Member 0 has correct name',TPasVariable,TObject(Variant1.Members.Members[0]).ClassType);
  1062. AssertEquals('Member 0 has correct name','y',TPasVariable(Variant1.Members.Members[0]).Name);
  1063. AssertNotNull('member 0 has not null type',TPasVariable(Variant1.Members.Members[0]).VarType);
  1064. AssertEquals('member 0 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant1.Members.Members[0]).VarType.ClassType);
  1065. AssertEquals('member 0 has correct type name','Integer',TPasVariable(Variant1.Members.Members[0]).VarType.Name);
  1066. AssertTrue('Field 1 hints match',TPasVariable(Variant1.Members.Members[0]).Hints=Hints)
  1067. end;
  1068. procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints);
  1069. begin
  1070. AssertVariant2(Hints,['1']);
  1071. end;
  1072. procedure TTestRecordTypeParser.AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
  1073. Var
  1074. I : Integer;
  1075. begin
  1076. AssertNotNull('Have variant 2',Variant2);
  1077. AssertNotNull('Variant 2 has Values ',Variant2.Values);
  1078. if Length(VariantLabels)=0 then
  1079. begin
  1080. AssertEquals('Variant 2 has 1 value',2,Variant2.Values.Count);
  1081. AssertEquals('Expression',TPrimitiveExpr,TObject(Variant2.Values[0]).CLassType);
  1082. AssertExpression('First value is 1',TPasExpr(Variant2.Values[0]),pekNumber,'1');
  1083. end
  1084. else
  1085. begin
  1086. AssertEquals('Variant 2 Has correct number of values',Length(VariantLabels),Variant2.Values.Count);
  1087. For I:=0 to Length(VariantLabels)-1 do
  1088. begin
  1089. AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant2.Values[I]).CLassType);
  1090. AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant2.Values[I]),pekNumber,VariantLabels[i]);
  1091. // AssertEquals(Format('Variant 2, Value %d is %s',[i,VariantLabels[i]]),VariantLabels[i],Variant2.Values[I]);
  1092. end;
  1093. end;
  1094. AssertNotNull('Have members',Variant2.Members);
  1095. AssertNotNull('Have member members',Variant2.Members.Members);
  1096. AssertNotNull('member 1 not null',Variant2.Members.Members[0]);
  1097. AssertEquals('Member 1 has correct name',TPasVariable,TObject(Variant2.Members.Members[0]).ClassType);
  1098. AssertEquals('Member 1 has correct name','z',TPasVariable(Variant2.Members.Members[0]).Name);
  1099. AssertNotNull('member 1 has not null type',TPasVariable(Variant2.Members.Members[0]).VarType);
  1100. AssertEquals('member 1 has correct type',TPasUnresolvedTypeRef,TPasVariable(Variant2.Members.Members[0]).VarType.ClassType);
  1101. AssertEquals('member 1 has correct type name','Integer',TPasVariable(Variant2.Members.Members[0]).VarType.Name);
  1102. AssertTrue('Field 1 hints match',TPasVariable(Variant2.Members.Members[0]).Hints=Hints)
  1103. end;
  1104. procedure TTestRecordTypeParser.DoTestVariantNoStorage(const AHint: string);
  1105. begin
  1106. TestFields(['x : integer;','case integer of','0 : (y : integer;)'],AHint,True);
  1107. AssertField1([]);
  1108. AssertVariantSelector('','');
  1109. AssertVariant1([]);
  1110. end;
  1111. procedure TTestRecordTypeParser.DoTestDeprecatedVariantNoStorage(
  1112. const AHint: string);
  1113. begin
  1114. TestFields(['x : integer;','case integer of','0 : (y : integer deprecated;)'],AHint,True);
  1115. AssertField1([]);
  1116. AssertVariantSelector('','');
  1117. AssertVariant1([hDeprecated]);
  1118. end;
  1119. procedure TTestRecordTypeParser.DoTestDeprecatedVariantStorage(
  1120. const AHint: string);
  1121. begin
  1122. TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;)'],AHint,True);
  1123. AssertField1([]);
  1124. AssertVariantSelector('s','');
  1125. AssertVariant1([hDeprecated]);
  1126. end;
  1127. procedure TTestRecordTypeParser.DoTestVariantStorage(const AHint: string);
  1128. begin
  1129. TestFields(['x : integer;','case s : integer of','0 : (y : integer;)'],AHint,True);
  1130. AssertField1([]);
  1131. AssertVariantSelector('s','');
  1132. AssertVariant1([]);
  1133. end;
  1134. procedure TTestRecordTypeParser.DoTestTwoVariantsNoStorage(const AHint: string
  1135. );
  1136. begin
  1137. TestFields(['x : integer;','case integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
  1138. AssertField1([]);
  1139. AssertVariantSelector('','');
  1140. AssertVariant1([]);
  1141. AssertVariant2([]);
  1142. end;
  1143. procedure TTestRecordTypeParser.DoTestTwoVariantsStorage(const AHint: string);
  1144. begin
  1145. TestFields(['x : integer;','case s : integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
  1146. AssertField1([]);
  1147. AssertVariantSelector('s','');
  1148. AssertVariant1([]);
  1149. AssertVariant2([]);
  1150. end;
  1151. procedure TTestRecordTypeParser.DoTestTwoVariantsFirstDeprecatedStorage(
  1152. const AHint: string);
  1153. begin
  1154. TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;);','1 : (z : integer;)'],AHint,True);
  1155. AssertField1([]);
  1156. AssertVariantSelector('s','');
  1157. AssertVariant1([hdeprecated]);
  1158. AssertVariant2([]);
  1159. end;
  1160. procedure TTestRecordTypeParser.DoTestTwoVariantsSecondDeprecatedStorage(
  1161. const AHint: string);
  1162. begin
  1163. TestFields(['x : integer;','case s : integer of','0 : (y : integer ;);','1 : (z : integer deprecated;)'],AHint,True);
  1164. AssertField1([]);
  1165. AssertVariantSelector('s','');
  1166. AssertVariant1([]);
  1167. AssertVariant2([hdeprecated]);
  1168. end;
  1169. procedure TTestRecordTypeParser.DoTestVariantTwoLabels(const AHint: string);
  1170. begin
  1171. TestFields(['x : integer;','case integer of','0,1 : (y : integer)'],AHint,True);
  1172. AssertField1([]);
  1173. AssertVariantSelector('','');
  1174. AssertVariant1([],['0','1']);
  1175. end;
  1176. procedure TTestRecordTypeParser.DoTestTwoVariantsTwoLabels(const AHint: string
  1177. );
  1178. begin
  1179. TestFields(['x : integer;','case integer of','0,1 : (y : integer);','2,3 : (z : integer);'],AHint,True);
  1180. AssertField1([]);
  1181. AssertVariantSelector('','');
  1182. AssertVariant1([],['0','1']);
  1183. AssertVariant2([],['2','3']);
  1184. end;
  1185. procedure TTestRecordTypeParser.DoTestVariantNestedRecord(const AHint: string);
  1186. begin
  1187. TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;','end)'],AHint,True);
  1188. AssertField1([]);
  1189. AssertVariantSelector('','');
  1190. AssertRecordVariant(0,[],['0']);
  1191. end;
  1192. procedure TTestRecordTypeParser.DoTestVariantNestedVariant(const AHint: string
  1193. );
  1194. begin
  1195. TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer);',' 2 : ( j : byte)', 'end)'],AHint,True);
  1196. AssertField1([]);
  1197. AssertVariantSelector('','');
  1198. AssertRecordVariant(0,[],['0']);
  1199. AssertRecordVariantVariant(0,'i','Integer',[],['1']);
  1200. AssertRecordVariantVariant(1,'j','Byte',[],['2'])
  1201. end;
  1202. procedure TTestRecordTypeParser.DoTestVariantNestedVariantFirstDeprecated(
  1203. const AHint: string);
  1204. begin
  1205. TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated);',' 2 : ( j : byte)', 'end)'],AHint,True);
  1206. AssertField1([]);
  1207. AssertVariantSelector('','');
  1208. AssertRecordVariant(0,[],['0']);
  1209. AssertRecordVariantVariant(0,'i','Integer',[hDeprecated],['1']);
  1210. AssertRecordVariantVariant(1,'j','Byte',[],['2'])
  1211. end;
  1212. procedure TTestRecordTypeParser.DoTestVariantNestedVariantSecondDeprecated(
  1213. const AHint: string);
  1214. begin
  1215. TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
  1216. AssertField1([]);
  1217. AssertVariantSelector('','');
  1218. AssertRecordVariant(0,[],['0']);
  1219. AssertRecordVariantVariant(0,'i','Integer',[],['1']);
  1220. AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])
  1221. end;
  1222. procedure TTestRecordTypeParser.DoTestVariantNestedVariantBothDeprecated(const AHint: string);
  1223. begin
  1224. TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
  1225. AssertField1([]);
  1226. AssertVariantSelector('','');
  1227. AssertRecordVariant(0,[],['0']);
  1228. AssertRecordVariantVariant(0,'i','Integer',[hdeprecated],['1']);
  1229. AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])
  1230. end;
  1231. procedure TTestRecordTypeParser.TestEmpty;
  1232. begin
  1233. DoTestEmpty('')
  1234. end;
  1235. procedure TTestRecordTypeParser.TestEmptyDeprecated;
  1236. begin
  1237. DoTestEmpty('Deprecated')
  1238. end;
  1239. procedure TTestRecordTypeParser.TestEmptyPlatform;
  1240. begin
  1241. DoTestEmpty('Platform')
  1242. end;
  1243. procedure TTestRecordTypeParser.AssertField1(Hints : TPasMemberHints);
  1244. begin
  1245. AssertEquals('Member 1 field type',TPasVariable,TObject(TheRecord.Members[0]).ClassType);
  1246. AssertEquals('Field 1 name','x',Field1.Name);
  1247. AssertNotNull('Have 1 Field type',Field1.VarType);
  1248. AssertEquals('Field 1 type',TPasUnresolvedTypeRef,Field1.VarType.ClassType);
  1249. AssertEquals('Field 1 type name','Integer',Field1.VarType.Name);
  1250. AssertTrue('Field 1 hints match',Field1.Hints=Hints)
  1251. end;
  1252. procedure TTestRecordTypeParser.AssertField2(Hints : TPasMemberHints);
  1253. begin
  1254. AssertEquals('Member 2 field type',TPasVariable,TObject(TheRecord.Members[1]).ClassType);
  1255. AssertEquals('Field 2 name','y',Field2.Name);
  1256. AssertNotNull('Have 2 Field type',Field2.VarType);
  1257. AssertEquals('Field 2 type',TPasUnresolvedTypeRef,Field2.VarType.ClassType);
  1258. AssertEquals('Field 2 type name','Integer',Field2.VarType.Name);
  1259. AssertTrue('Field 2 hints match',Field2.Hints=Hints)
  1260. end;
  1261. procedure TTestRecordTypeParser.AssertOneIntegerField(Hints : TPasMemberHints);
  1262. begin
  1263. AssertEquals('One field',1,TheRecord.Members.Count);
  1264. AssertField1(Hints);
  1265. end;
  1266. procedure TTestRecordTypeParser.AssertTwoIntegerFields(Hints1,Hints2: TPasMemberHints);
  1267. begin
  1268. AssertEquals('Two field',2,TheRecord.Members.Count);
  1269. AssertField1(Hints1);
  1270. AssertField2(Hints2);
  1271. end;
  1272. procedure TTestRecordTypeParser.AssertRecordField(AIndex: Integer;
  1273. Hints: TPasMemberHints);
  1274. Var
  1275. F : TPasVariable;
  1276. R : TPasRecordtype;
  1277. begin
  1278. AssertEquals('Member 2 field type',TPasVariable,TObject(TheRecord.Members[AIndex]).ClassType);
  1279. F:=GetF(AIndex);
  1280. if AIndex=1 then
  1281. AssertEquals('Field 2 name','y',F.Name)
  1282. else
  1283. AssertEquals('Field 1 name','x',F.Name);
  1284. AssertNotNull('Have 2 Field type',F.VarType);
  1285. AssertEquals('Field 2 type',TPasRecordType,F.VarType.ClassType);
  1286. R:=F.VarType as TPasRecordType;
  1287. AssertNotNull('Record field has members',R.Members);
  1288. AssertEquals('Record field has 1 member',1,R.Members.Count);
  1289. AssertTrue('Record field hints match',F.Hints=Hints)
  1290. end;
  1291. procedure TTestRecordTypeParser.AssertRecordVariant(AIndex: Integer;
  1292. Hints: TPasMemberHints; VariantLabels : Array of string);
  1293. Var
  1294. F : TPasVariant;
  1295. V : TPasVariable;
  1296. R : TPasRecordtype;
  1297. I : Integer;
  1298. MN : String;
  1299. begin
  1300. F:=GetV(AIndex);
  1301. MN:='Variant '+IntToStr(AIndex)+' ';
  1302. AssertNotNull('Have variant 1',F);
  1303. AssertEquals('Have correct number of values',Length(VariantLabels),F.Values.Count);
  1304. For I:=0 to Length(VariantLabels)-1 do
  1305. begin
  1306. AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(Variant1.Values[i]).CLassType);
  1307. AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(Variant1.Values[I]),pekNumber,VariantLabels[i]);
  1308. end;
  1309. V:=GetField(0,F);
  1310. AssertEquals(MN+'has correct name','y',V.Name);
  1311. AssertNotNull(MN+'has not null type',V.VarType);
  1312. AssertEquals(MN+'has correct type',TPasRecordType,V.VarType.ClassType);
  1313. AssertTrue(MN+'hints match',V.Hints=Hints);
  1314. R:=TPasVariable(F.Members.Members[0]).VarType as TPasRecordType;
  1315. V:=GetField(0,R);
  1316. AssertEquals('Field 1 has correct name','z',V.Name);
  1317. AssertNotNull('Record field has members',R.Members);
  1318. AssertEquals('Record field has 1 member',1,R.Members.Count);
  1319. end;
  1320. procedure TTestRecordTypeParser.AssertRecordVariantVariant(AIndex: Integer; Const AFieldName,ATypeName: string;
  1321. Hints: TPasMemberHints; VariantLabels: array of string);
  1322. Var
  1323. F : TPasVariant;
  1324. V : TPasVariable;
  1325. R : TPasRecordtype;
  1326. I : Integer;
  1327. MN : String;
  1328. begin
  1329. F:=GetV(0);
  1330. MN:='Nested Variant '+IntToStr(AIndex)+' ';
  1331. AssertNotNull('Have variant 1',F);
  1332. AssertEquals('Have correct number of values',1,F.Values.Count);
  1333. AssertEquals('Expression',TPrimitiveExpr,TObject(F.Values[0]).CLassType);
  1334. AssertExpression('First value is 0',TPasExpr(F.Values[0]),pekNumber,'0');
  1335. // First variant, Y, record
  1336. V:=GetField(0,F);
  1337. AssertEquals(MN+'has correct name','y',V.Name);
  1338. AssertNotNull(MN+'has not null type',V.VarType);
  1339. AssertEquals(MN+'has correct type',TPasRecordType,V.VarType.ClassType);
  1340. R:=TPasVariable(F.Members.Members[0]).VarType as TPasRecordType;
  1341. AssertNotNull('Record field has members',R.Members);
  1342. AssertEquals('Record field has 2 members',1,R.Members.Count);
  1343. // First variant
  1344. F:=GetVariant(Aindex,R);
  1345. // First field of first variant, i
  1346. AssertEquals('Have correct number of values',Length(VariantLabels),F.Values.Count);
  1347. For I:=0 to Length(VariantLabels)-1 do
  1348. begin
  1349. AssertEquals(Format('Expression for variant %d',[I]),TPrimitiveExpr,TObject(F.Values[i]).CLassType);
  1350. AssertExpression(Format('Value %d is %s',[i,VariantLabels[i]]),TPasExpr(F.Values[I]),pekNumber,VariantLabels[i]);
  1351. end;
  1352. V:=GetField(0,F);
  1353. AssertEquals('Nested Variant 0 has correct name',AFieldName,V.Name);
  1354. AssertEquals('Nested variant 0 has correct type',TPasUnresolvedTypeRef,V.VarType.ClassType);
  1355. AssertEquals('Nested variant 0 has correct type name',ATypeName,V.VarType.Name);
  1356. AssertTrue(MN+'hints match',V.Hints=Hints);
  1357. end;
  1358. procedure TTestRecordTypeParser.TestOneField;
  1359. begin
  1360. TestFields(['x : integer'],'',False);
  1361. AssertOneIntegerField([]);
  1362. end;
  1363. procedure TTestRecordTypeParser.TestOneFieldDeprecated;
  1364. begin
  1365. TestFields(['x : integer'],'deprecated',False);
  1366. AssertOneIntegerField([]);
  1367. end;
  1368. procedure TTestRecordTypeParser.TestOneFieldPlatform;
  1369. begin
  1370. TestFields(['x : integer'],'platform',False);
  1371. AssertOneIntegerField([]);
  1372. end;
  1373. procedure TTestRecordTypeParser.TestOneFieldSemicolon;
  1374. begin
  1375. TestFields(['x : integer;'],'',False);
  1376. AssertOneIntegerField([]);
  1377. end;
  1378. procedure TTestRecordTypeParser.TestOneFieldSemicolonDeprecated;
  1379. begin
  1380. TestFields(['x : integer;'],'deprecated',False);
  1381. AssertOneIntegerField([]);
  1382. end;
  1383. procedure TTestRecordTypeParser.TestOneFieldSemicolonPlatform;
  1384. begin
  1385. TestFields(['x : integer;'],'platform',False);
  1386. AssertOneIntegerField([]);
  1387. end;
  1388. procedure TTestRecordTypeParser.TestOneDeprecatedField;
  1389. begin
  1390. TestFields(['x : integer deprecated;'],'',False);
  1391. AssertOneIntegerField([hDeprecated]);
  1392. end;
  1393. procedure TTestRecordTypeParser.TestOneDeprecatedFieldDeprecated;
  1394. begin
  1395. TestFields(['x : integer deprecated;'],'deprecated',False);
  1396. AssertOneIntegerField([hDeprecated]);
  1397. end;
  1398. procedure TTestRecordTypeParser.TestOneDeprecatedFieldPlatform;
  1399. begin
  1400. TestFields(['x : integer deprecated;'],'platform',False);
  1401. AssertOneIntegerField([hDeprecated]);
  1402. end;
  1403. procedure TTestRecordTypeParser.TestOnePlatformField;
  1404. begin
  1405. TestFields(['x : integer platform;'],'',False);
  1406. AssertOneIntegerField([hplatform]);
  1407. end;
  1408. procedure TTestRecordTypeParser.TestOnePlatformFieldDeprecated;
  1409. begin
  1410. TestFields(['x : integer platform;'],'Deprecated',False);
  1411. AssertOneIntegerField([hplatform]);
  1412. end;
  1413. procedure TTestRecordTypeParser.TestOnePlatformFieldPlatform;
  1414. begin
  1415. TestFields(['x : integer platform;'],'Platform',False);
  1416. AssertOneIntegerField([hplatform]);
  1417. end;
  1418. procedure TTestRecordTypeParser.TestTwoFields;
  1419. begin
  1420. TestFields(['x : integer;','y : integer'],'',False);
  1421. AssertTwoIntegerFields([],[]);
  1422. end;
  1423. procedure TTestRecordTypeParser.TestTwoFieldDeprecated;
  1424. begin
  1425. TestFields(['x : integer;','y : integer'],'deprecated',False);
  1426. AssertTwoIntegerFields([],[]);
  1427. end;
  1428. procedure TTestRecordTypeParser.TestTwoFieldPlatform;
  1429. begin
  1430. TestFields(['x : integer;','y : integer'],'platform',False);
  1431. AssertTwoIntegerFields([],[]);
  1432. end;
  1433. procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecated;
  1434. begin
  1435. TestFields(['x : integer deprecated;','y : integer'],'',False);
  1436. AssertTwoIntegerFields([hdeprecated],[]);
  1437. end;
  1438. procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecatedDeprecated;
  1439. begin
  1440. TestFields(['x : integer deprecated;','y : integer'],'deprecated',False);
  1441. AssertTwoIntegerFields([hdeprecated],[]);
  1442. end;
  1443. procedure TTestRecordTypeParser.TestTwoFieldsFirstDeprecatedPlatform;
  1444. begin
  1445. TestFields(['x : integer deprecated;','y : integer'],'platform',False);
  1446. AssertTwoIntegerFields([hdeprecated],[]);
  1447. end;
  1448. procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecated;
  1449. begin
  1450. TestFields(['x : integer;','y : integer deprecated;'],'',False);
  1451. AssertTwoIntegerFields([],[hdeprecated]);
  1452. end;
  1453. procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecatedDeprecated;
  1454. begin
  1455. TestFields(['x : integer;','y : integer deprecated;'],'deprecated',False);
  1456. AssertTwoIntegerFields([],[hdeprecated]);
  1457. end;
  1458. procedure TTestRecordTypeParser.TestTwoFieldsSecondDeprecatedPlatform;
  1459. begin
  1460. TestFields(['x : integer;','y : integer deprecated;'],'platform',False);
  1461. AssertTwoIntegerFields([],[hdeprecated]);
  1462. end;
  1463. procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecated;
  1464. begin
  1465. TestFields(['x : integer deprecated;','y : integer deprecated;'],'',False);
  1466. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1467. end;
  1468. procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecatedDeprecated;
  1469. begin
  1470. TestFields(['x : integer deprecated;','y : integer deprecated;'],'deprecated',False);
  1471. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1472. end;
  1473. procedure TTestRecordTypeParser.TestTwoFieldsBothDeprecatedPlatform;
  1474. begin
  1475. TestFields(['x : integer deprecated;','y : integer deprecated;'],'platform',False);
  1476. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1477. end;
  1478. procedure TTestRecordTypeParser.TestTwoFieldsCombined;
  1479. begin
  1480. TestFields(['x,y : integer;'],'',False);
  1481. AssertTwoIntegerFields([],[]);
  1482. end;
  1483. procedure TTestRecordTypeParser.TestTwoFieldsCombinedDeprecated;
  1484. begin
  1485. TestFields(['x,y : integer;'],'deprecated',False);
  1486. AssertTwoIntegerFields([],[]);
  1487. end;
  1488. procedure TTestRecordTypeParser.TestTwoFieldsCombinedPlatform;
  1489. begin
  1490. TestFields(['x,y : integer;'],'platform',False);
  1491. AssertTwoIntegerFields([],[]);
  1492. end;
  1493. procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombined;
  1494. begin
  1495. TestFields(['x,y : integer deprecated;'],'',False);
  1496. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1497. end;
  1498. procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombinedDeprecated;
  1499. begin
  1500. TestFields(['x,y : integer deprecated;'],'deprecated',False);
  1501. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1502. end;
  1503. procedure TTestRecordTypeParser.TestTwoDeprecatedFieldsCombinedPlatform;
  1504. begin
  1505. TestFields(['x,y : integer deprecated;'],'platform',False);
  1506. AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
  1507. end;
  1508. procedure TTestRecordTypeParser.TestNested;
  1509. begin
  1510. TestFields(['x : integer;','y : record',' z : integer;','end'],'',False);
  1511. AssertField1([]);
  1512. AssertRecordField(1,[])
  1513. end;
  1514. procedure TTestRecordTypeParser.TestNestedSemicolon;
  1515. begin
  1516. TestFields(['x : integer;','y : record',' z : integer;','end;'],'',False);
  1517. AssertField1([]);
  1518. AssertRecordField(1,[])
  1519. end;
  1520. procedure TTestRecordTypeParser.TestNestedSemicolonDeprecated;
  1521. begin
  1522. TestFields(['x : integer;','y : record',' z : integer;','end;'],'deprecated',False);
  1523. AssertField1([]);
  1524. AssertRecordField(1,[])
  1525. end;
  1526. procedure TTestRecordTypeParser.TestNestedSemicolonPlatform;
  1527. begin
  1528. TestFields(['x : integer;','y : record',' z : integer;','end;'],'platform',False);
  1529. AssertField1([]);
  1530. AssertRecordField(1,[])
  1531. end;
  1532. procedure TTestRecordTypeParser.TestNestedDeprecated;
  1533. begin
  1534. TestFields(['x : integer;','y : record',' z : integer;','end'],'deprecated',False);
  1535. AssertField1([]);
  1536. AssertRecordField(1,[])
  1537. end;
  1538. procedure TTestRecordTypeParser.TestNestedPlatform;
  1539. begin
  1540. TestFields(['x : integer;','y : record',' z : integer;','end'],'platform',False);
  1541. AssertField1([]);
  1542. AssertRecordField(1,[])
  1543. end;
  1544. procedure TTestRecordTypeParser.TestNestedFirst;
  1545. begin
  1546. TestFields(['x : record',' z : integer;','end;','y : integer;'],'',False);
  1547. AssertField2([]);
  1548. AssertRecordField(0,[])
  1549. end;
  1550. procedure TTestRecordTypeParser.TestNestedFirstDeprecated;
  1551. begin
  1552. TestFields(['x : record',' z : integer;','end;','y : integer;'],'deprecated',False);
  1553. AssertField2([]);
  1554. AssertRecordField(0,[])
  1555. end;
  1556. procedure TTestRecordTypeParser.TestNestedFirstPlatform;
  1557. begin
  1558. TestFields(['x : record',' z : integer;','end;','y : integer;'],'platform',False);
  1559. AssertField2([]);
  1560. AssertRecordField(0,[])
  1561. end;
  1562. procedure TTestRecordTypeParser.TestDeprecatedNested;
  1563. begin
  1564. TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'',False);
  1565. AssertField1([]);
  1566. AssertRecordField(1,[hdeprecated])
  1567. end;
  1568. procedure TTestRecordTypeParser.TestDeprecatedNestedDeprecated;
  1569. begin
  1570. TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'deprecated',False);
  1571. AssertField1([]);
  1572. AssertRecordField(1,[hdeprecated])
  1573. end;
  1574. procedure TTestRecordTypeParser.TestDeprecatedNestedPlatform;
  1575. begin
  1576. TestFields(['x : integer;','y : record',' z : integer;','end deprecated;'],'platform',False);
  1577. AssertField1([]);
  1578. AssertRecordField(1,[hdeprecated])
  1579. end;
  1580. procedure TTestRecordTypeParser.TestDeprecatedNestedFirst;
  1581. begin
  1582. TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'',False);
  1583. AssertField2([]);
  1584. AssertRecordField(0,[hdeprecated])
  1585. end;
  1586. procedure TTestRecordTypeParser.TestDeprecatedNestedFirstDeprecated;
  1587. begin
  1588. TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'deprecated',False);
  1589. AssertField2([]);
  1590. AssertRecordField(0,[hdeprecated])
  1591. end;
  1592. procedure TTestRecordTypeParser.TestDeprecatedNestedFirstPlatform;
  1593. begin
  1594. TestFields(['x : record',' z : integer;','end deprecated;','y : integer;'],'platform',False);
  1595. AssertField2([]);
  1596. AssertRecordField(0,[hdeprecated])
  1597. end;
  1598. procedure TTestRecordTypeParser.TestVariantNoStorage;
  1599. begin
  1600. DoTestVariantNoStorage('');
  1601. end;
  1602. procedure TTestRecordTypeParser.TestVariantNoStorageDeprecated;
  1603. begin
  1604. DoTestVariantNoStorage('deprecated');
  1605. end;
  1606. procedure TTestRecordTypeParser.TestVariantNoStoragePlatform;
  1607. begin
  1608. DoTestVariantNoStorage('platform');
  1609. end;
  1610. procedure TTestRecordTypeParser.TestVariantStorage;
  1611. begin
  1612. DoTestVariantStorage('');
  1613. end;
  1614. procedure TTestRecordTypeParser.TestVariantStorageDeprecated;
  1615. begin
  1616. DoTestVariantStorage('deprecated');
  1617. end;
  1618. procedure TTestRecordTypeParser.TestVariantStoragePlatform;
  1619. begin
  1620. DoTestVariantStorage('platform');
  1621. end;
  1622. procedure TTestRecordTypeParser.TestDeprecatedVariantNoStorage;
  1623. begin
  1624. DoTestDeprecatedVariantNoStorage('');
  1625. end;
  1626. procedure TTestRecordTypeParser.TestDeprecatedVariantNoStorageDeprecated;
  1627. begin
  1628. DoTestDeprecatedVariantNoStorage('Deprecated');
  1629. end;
  1630. procedure TTestRecordTypeParser.TestDeprecatedVariantNoStoragePlatform;
  1631. begin
  1632. DoTestDeprecatedVariantNoStorage('Platform');
  1633. end;
  1634. procedure TTestRecordTypeParser.TestDeprecatedVariantStorage;
  1635. begin
  1636. DoTestDeprecatedVariantStorage('');
  1637. end;
  1638. procedure TTestRecordTypeParser.TestDeprecatedVariantStorageDeprecated;
  1639. begin
  1640. DoTestDeprecatedVariantStorage('Deprecated');
  1641. end;
  1642. procedure TTestRecordTypeParser.TestDeprecatedVariantStoragePlatform;
  1643. begin
  1644. DoTestDeprecatedVariantStorage('Platform');
  1645. end;
  1646. procedure TTestRecordTypeParser.TestTwoVariantsNoStorage;
  1647. begin
  1648. DoTestTwoVariantsNoStorage('');
  1649. end;
  1650. procedure TTestRecordTypeParser.TestTwoVariantsNoStorageDeprecated;
  1651. begin
  1652. DoTestTwoVariantsNoStorage('deprecated');
  1653. end;
  1654. procedure TTestRecordTypeParser.TestTwoVariantsNoStoragePlatform;
  1655. begin
  1656. DoTestTwoVariantsNoStorage('platform');
  1657. end;
  1658. procedure TTestRecordTypeParser.TestTwoVariantsStorage;
  1659. begin
  1660. DoTestTwoVariantsStorage('');
  1661. end;
  1662. procedure TTestRecordTypeParser.TestTwoVariantsStorageDeprecated;
  1663. begin
  1664. DoTestTwoVariantsStorage('deprecated');
  1665. end;
  1666. procedure TTestRecordTypeParser.TestTwoVariantsStoragePlatform;
  1667. begin
  1668. DoTestTwoVariantsStorage('platform');
  1669. end;
  1670. procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStorage;
  1671. begin
  1672. DoTestTwoVariantsFirstDeprecatedStorage('');
  1673. end;
  1674. procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStorageDeprecated;
  1675. begin
  1676. DoTestTwoVariantsFirstDeprecatedStorage('deprecated');
  1677. end;
  1678. procedure TTestRecordTypeParser.TestTwoVariantsFirstDeprecatedStoragePlatform;
  1679. begin
  1680. DoTestTwoVariantsFirstDeprecatedStorage('platform');
  1681. end;
  1682. procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStorage;
  1683. begin
  1684. DoTestTwoVariantsSecondDeprecatedStorage('');
  1685. end;
  1686. procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStorageDeprecated;
  1687. begin
  1688. DoTestTwoVariantsSecondDeprecatedStorage('deprecated');
  1689. end;
  1690. procedure TTestRecordTypeParser.TestTwoVariantsSecondDeprecatedStoragePlatform;
  1691. begin
  1692. DoTestTwoVariantsSecondDeprecatedStorage('platform');
  1693. end;
  1694. procedure TTestRecordTypeParser.TestVariantTwoLabels;
  1695. begin
  1696. DoTestVariantTwoLabels('');
  1697. end;
  1698. procedure TTestRecordTypeParser.TestVariantTwoLabelsDeprecated;
  1699. begin
  1700. DoTestVariantTwoLabels('Deprecated');
  1701. end;
  1702. procedure TTestRecordTypeParser.TestVariantTwoLabelsPlatform;
  1703. begin
  1704. DoTestVariantTwoLabels('Platform');
  1705. end;
  1706. procedure TTestRecordTypeParser.TestTwoVariantsTwoLabels;
  1707. begin
  1708. DoTestTwoVariantsTwoLabels('');
  1709. end;
  1710. procedure TTestRecordTypeParser.TestTwoVariantsTwoLabelsDeprecated;
  1711. begin
  1712. DoTestTwoVariantsTwoLabels('Deprecated');
  1713. end;
  1714. procedure TTestRecordTypeParser.TestTwoVariantsTwoLabelsPlatform;
  1715. begin
  1716. DoTestTwoVariantsTwoLabels('Platform');
  1717. end;
  1718. procedure TTestRecordTypeParser.TestVariantNestedRecord;
  1719. begin
  1720. DoTestVariantNestedRecord('');
  1721. end;
  1722. procedure TTestRecordTypeParser.TestVariantNestedRecordDeprecated;
  1723. begin
  1724. DoTestVariantNestedRecord('Deprecated');
  1725. end;
  1726. procedure TTestRecordTypeParser.TestVariantNestedRecordPlatform;
  1727. begin
  1728. DoTestVariantNestedRecord('Platform');
  1729. end;
  1730. procedure TTestRecordTypeParser.TestVariantNestedVariant;
  1731. begin
  1732. DoTestVariantNestedVariant('');
  1733. end;
  1734. procedure TTestRecordTypeParser.TestVariantNestedVariantDeprecated;
  1735. begin
  1736. DoTestVariantNestedVariant('deprecated');
  1737. end;
  1738. procedure TTestRecordTypeParser.TestVariantNestedVariantPlatForm;
  1739. begin
  1740. DoTestVariantNestedVariant('Platform');
  1741. end;
  1742. procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecated;
  1743. begin
  1744. DoTestVariantNestedVariantFirstDeprecated('');
  1745. end;
  1746. procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecatedDeprecated;
  1747. begin
  1748. DoTestVariantNestedVariantFirstDeprecated('deprecated');
  1749. end;
  1750. procedure TTestRecordTypeParser.TestVariantNestedVariantFirstDeprecatedPlatform;
  1751. begin
  1752. DoTestVariantNestedVariantFirstDeprecated('platform');
  1753. end;
  1754. procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecated;
  1755. begin
  1756. DoTestVariantNestedVariantSecondDeprecated('');
  1757. end;
  1758. procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecatedDeprecated;
  1759. begin
  1760. DoTestVariantNestedVariantSecondDeprecated('deprecated');
  1761. end;
  1762. procedure TTestRecordTypeParser.TestVariantNestedVariantSecondDeprecatedPlatform;
  1763. begin
  1764. DoTestVariantNestedVariantSecondDeprecated('platform');
  1765. end;
  1766. procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecated;
  1767. begin
  1768. DoTestVariantNestedVariantBothDeprecated('');
  1769. end;
  1770. procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecatedDeprecated;
  1771. begin
  1772. DoTestVariantNestedVariantBothDeprecated('deprecated');
  1773. end;
  1774. procedure TTestRecordTypeParser.TestVariantNestedVariantBothDeprecatedPlatform;
  1775. begin
  1776. DoTestVariantNestedVariantBothDeprecated('platform');
  1777. end;
  1778. { TBaseTestTypeParser }
  1779. function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;Const AHint : String = ''): TPasType;
  1780. Var
  1781. D : String;
  1782. begin
  1783. Hint:=AHint;
  1784. Add('Type');
  1785. D:='A = '+ASource;
  1786. If Hint<>'' then
  1787. D:=D+' '+Hint;
  1788. Add(' '+D+';');
  1789. // Writeln(source.text);
  1790. ParseDeclarations;
  1791. AssertEquals('One type definition',1,Declarations.Types.Count);
  1792. If (AtypeClass<>Nil) then
  1793. AssertEquals('First declaration is type definition.',ATypeClass,TObject(Declarations.Types[0]).ClassType);
  1794. AssertEquals('First declaration has correct name.','A',TPasType(Declarations.Types[0]).Name);
  1795. Result:=TPasType(Declarations.Types[0]);
  1796. FType:=Result;
  1797. Definition:=Result;
  1798. if (Hint<>'') then
  1799. CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'h'+Hint)));
  1800. end;
  1801. procedure TBaseTestTypeParser.AssertParseTypeError(ASource: String);
  1802. begin
  1803. try
  1804. ParseType(ASource,Nil,'');
  1805. Fail('Expected parser error');
  1806. except
  1807. // all OK.
  1808. end;
  1809. end;
  1810. procedure TBaseTestTypeParser.SetUp;
  1811. begin
  1812. Inherited;
  1813. FErrorSource:='';
  1814. FHint:='';
  1815. FType:=Nil;
  1816. end;
  1817. procedure TBaseTestTypeParser.TearDown;
  1818. begin
  1819. inherited TearDown;
  1820. FType:=Nil;
  1821. end;
  1822. { TTestTypeParser }
  1823. procedure TTestTypeParser.DoTestAliasType(const AnAliasType: String;
  1824. const AHint: String);
  1825. begin
  1826. ParseType(AnAliasType,TPasAliasType,AHint);
  1827. AssertEquals('Unresolved type',TPasUnresolvedTypeRef,TPasAliasType(TheType).DestType.ClassType);
  1828. end;
  1829. procedure TTestTypeParser.DoTestStringType(const AnAliasType: String;
  1830. const AHint: String);
  1831. begin
  1832. ParseType(AnAliasType,TPasAliasType,AHint);
  1833. AssertEquals('String type',TPasStringType,TPasAliasType(TheType).DestType.ClassType);
  1834. end;
  1835. procedure TTestTypeParser.DoTypeError(Const AMsg,ASource : string);
  1836. begin
  1837. FErrorSource:=ASource;
  1838. AssertException(AMsg,EParserError,@DoParseError);
  1839. end;
  1840. procedure TTestTypeParser.DoParseError;
  1841. begin
  1842. ParseType(FErrorSource,Nil);
  1843. end;
  1844. procedure TTestTypeParser.DoParsePointer(const ASource: String;
  1845. const AHint: String; ADestType: TClass);
  1846. begin
  1847. ParseType('^'+ASource,TPasPointerType,AHint);
  1848. if ADestType = Nil then
  1849. ADestType:=TPasUnresolvedTypeRef;
  1850. AssertEquals('Destination type '+ADestType.ClassName,ADestType,TPasPointerType(TheType).DestType.ClassType);
  1851. end;
  1852. procedure TTestTypeParser.DoParseArray(const ASource: String;
  1853. const AHint: String; ADestType: TClass);
  1854. begin
  1855. ParseType(ASource,TPasArrayType,AHint);
  1856. if ADestType = Nil then
  1857. ADestType:=TPasUnresolvedTypeRef;
  1858. AssertEquals('Destination type '+ADestType.ClassName,ADestType,TPasArrayType(TheType).ElType.ClassType);
  1859. end;
  1860. procedure TTestTypeParser.DoParseEnumerated(const ASource: String;
  1861. const AHint: String; ACount: integer);
  1862. Var
  1863. I : Integer;
  1864. begin
  1865. ParseType(ASource,TPasEnumType,AHint);
  1866. AssertNotNull('Have values',TPasEnumType(TheType).Values);
  1867. AssertEquals('Value count',ACount,TPasEnumType(TheType).Values.Count);
  1868. For I:=0 to TPasEnumType(TheType).Values.Count-1 do
  1869. AssertEquals('Enum value typed element '+IntToStr(I),TPasEnumValue,TObject(TPasEnumType(TheType).Values[i]).ClassType);
  1870. end;
  1871. procedure TTestTypeParser.DoTestFileType(const AType: String;
  1872. const AHint: String; ADestType: TClass);
  1873. begin
  1874. ParseType('File of '+AType,TPasFileType,AHint);
  1875. AssertNotNull('Have element type',TPasFileType(TheType).ElType);
  1876. if ADestType = Nil then
  1877. ADestType:=TPasUnresolvedTypeRef;
  1878. AssertEquals('Element type '+ADestType.ClassName,ADestType,TPasFileType(TheType).ElType.ClassType);
  1879. end;
  1880. procedure TTestTypeParser.DoTestRangeType(const AStart, AStop, AHint: String);
  1881. begin
  1882. ParseType(AStart+'..'+AStop,TPasRangeType,AHint);
  1883. AssertEquals('Range start',AStart,TPasRangeType(TheType).RangeStart);
  1884. AssertEquals('Range start',AStop,TPasRangeType(TheType).RangeEnd);
  1885. end;
  1886. procedure TTestTypeParser.DoParseSimpleSet(const ASource: String;
  1887. const AHint: String);
  1888. begin
  1889. ParseType('Set of '+ASource,TPasSetType,AHint);
  1890. AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
  1891. AssertEquals('Element type ',TPasUnresolvedTypeRef,TPasSetType(TheType).EnumType.ClassType);
  1892. end;
  1893. procedure TTestTypeParser.DoParseComplexSet(const ASource: String;
  1894. const AHint: String);
  1895. begin
  1896. ParseType('Set of '+ASource,TPasSetType,AHint);
  1897. AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
  1898. AssertEquals('Element type ',TPasEnumType,TPasSetType(TheType).EnumType.ClassType);
  1899. end;
  1900. procedure TTestTypeParser.DoParseRangeSet(const ASource: String;
  1901. const AHint: String);
  1902. begin
  1903. ParseType('Set of '+ASource,TPasSetType,AHint);
  1904. AssertNotNull('Have enumtype',TPasSetType(TheType).EnumType);
  1905. AssertEquals('Element type ',TPasRangeType,TPasSetType(TheType).EnumType.ClassType);
  1906. end;
  1907. procedure TTestTypeParser.DoTestComplexSet;
  1908. Var
  1909. I : integer;
  1910. begin
  1911. AssertNotNull('Have values',TPasEnumType(TPasSetType(TheType).EnumType).Values);
  1912. AssertEquals('Have 3 values',3, TPasEnumType(TPasSetType(TheType).EnumType).Values.Count);
  1913. For I:=0 to TPasEnumType(TPasSetType(TheType).EnumType).Values.Count-1 do
  1914. AssertEquals('Enum value typed element '+IntToStr(I),TPasEnumValue,TObject(TPasEnumType(TPasSetType(TheType).EnumType).Values[i]).ClassType);
  1915. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[0]).Name);
  1916. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[1]).Name);
  1917. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[2]).Name);
  1918. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[0]).AssignedValue);
  1919. AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[1]).AssignedValue);
  1920. AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TPasSetType(TheType).EnumType).Values[2]).AssignedValue);
  1921. end;
  1922. procedure TTestTypeParser.DoTestClassOf(const AHint: string);
  1923. begin
  1924. ParseType('Class of TSomeClass',TPasClassOfType,AHint);
  1925. AssertNotNull('Have class type',TPasClassOfType(TheType).DestType);
  1926. AssertEquals('Element type ',TPasUnresolvedTypeRef,TPasClassOfType(TheType).DestType.ClassType);
  1927. end;
  1928. procedure TTestTypeParser.TestAliasType;
  1929. begin
  1930. DoTestAliasType('othertype','');
  1931. AssertEquals('Unresolved type name ','othertype',TPasUnresolvedTypeRef(TPasAliasType(TheType).DestType).name);
  1932. end;
  1933. procedure TTestTypeParser.TestCrossUnitAliasType;
  1934. begin
  1935. DoTestAliasType('otherunit.othertype','');
  1936. end;
  1937. procedure TTestTypeParser.TestAliasTypeDeprecated;
  1938. begin
  1939. DoTestALiasType('othertype','deprecated');
  1940. end;
  1941. procedure TTestTypeParser.TestAliasTypePlatform;
  1942. begin
  1943. DoTestALiasType('othertype','platform');
  1944. end;
  1945. procedure TTestTypeParser.TestSimpleTypeByte;
  1946. begin
  1947. DoTestAliasType('BYTE','');
  1948. end;
  1949. procedure TTestTypeParser.TestSimpleTypeByteDeprecated;
  1950. begin
  1951. DoTestAliasType('BYTE','deprecated');
  1952. end;
  1953. procedure TTestTypeParser.TestSimpleTypeBytePlatform;
  1954. begin
  1955. DoTestAliasType('BYTE','platform');
  1956. end;
  1957. procedure TTestTypeParser.TestSimpleTypeBoolean;
  1958. begin
  1959. DoTestAliasType('BOOLEAN','');
  1960. end;
  1961. procedure TTestTypeParser.TestSimpleTypeBooleanDeprecated;
  1962. begin
  1963. DoTestAliasType('BOOLEAN','deprecated');
  1964. end;
  1965. procedure TTestTypeParser.TestSimpleTypeBooleanPlatform;
  1966. begin
  1967. DoTestAliasType('BOOLEAN','platform');
  1968. end;
  1969. procedure TTestTypeParser.TestSimpleTypeChar;
  1970. begin
  1971. DoTestAliasType('CHAR','');
  1972. end;
  1973. procedure TTestTypeParser.TestSimpleTypeCharDeprecated;
  1974. begin
  1975. DoTestAliasType('CHAR','deprecated');
  1976. end;
  1977. procedure TTestTypeParser.TestSimpleTypeCharPlatform;
  1978. begin
  1979. DoTestAliasType('CHAR','platform');
  1980. end;
  1981. procedure TTestTypeParser.TestSimpleTypeInteger;
  1982. begin
  1983. DoTestAliasType('INTEGER','');
  1984. end;
  1985. procedure TTestTypeParser.TestSimpleTypeIntegerDeprecated;
  1986. begin
  1987. DoTestAliasType('INTEGER','deprecated');
  1988. end;
  1989. procedure TTestTypeParser.TestSimpleTypeIntegerPlatform;
  1990. begin
  1991. DoTestAliasType('INTEGER','platform');
  1992. end;
  1993. procedure TTestTypeParser.TestSimpleTypeInt64;
  1994. begin
  1995. DoTestAliasType('INT64','');
  1996. end;
  1997. procedure TTestTypeParser.TestSimpleTypeInt64Deprecated;
  1998. begin
  1999. DoTestAliasType('INT64','deprecated');
  2000. end;
  2001. procedure TTestTypeParser.TestSimpleTypeInt64Platform;
  2002. begin
  2003. DoTestAliasType('INT64','platform');
  2004. end;
  2005. procedure TTestTypeParser.TestSimpleTypeLongInt;
  2006. begin
  2007. DoTestAliasType('LONGINT','');
  2008. end;
  2009. procedure TTestTypeParser.TestSimpleTypeLongIntDeprecated;
  2010. begin
  2011. DoTestAliasType('LONGINT','deprecated');
  2012. end;
  2013. procedure TTestTypeParser.TestSimpleTypeLongIntPlatform;
  2014. begin
  2015. DoTestAliasType('LONGINT','platform');
  2016. end;
  2017. procedure TTestTypeParser.TestSimpleTypeLongWord;
  2018. begin
  2019. DoTestAliasType('LONGWORD','');
  2020. end;
  2021. procedure TTestTypeParser.TestSimpleTypeLongWordDeprecated;
  2022. begin
  2023. DoTestAliasType('LONGWORD','deprecated');
  2024. end;
  2025. procedure TTestTypeParser.TestSimpleTypeLongWordPlatform;
  2026. begin
  2027. DoTestAliasType('LONGWORD','platform');
  2028. end;
  2029. procedure TTestTypeParser.TestSimpleTypeDouble;
  2030. begin
  2031. DoTestAliasType('Double','');
  2032. end;
  2033. procedure TTestTypeParser.TestSimpleTypeDoubleDeprecated;
  2034. begin
  2035. DoTestAliasType('Double','deprecated');
  2036. end;
  2037. procedure TTestTypeParser.TestSimpleTypeDoublePlatform;
  2038. begin
  2039. DoTestAliasType('Double','platform');
  2040. end;
  2041. procedure TTestTypeParser.TestSimpleTypeShortInt;
  2042. begin
  2043. DoTestAliasType('SHORTINT','');
  2044. end;
  2045. procedure TTestTypeParser.TestSimpleTypeShortIntDeprecated;
  2046. begin
  2047. DoTestAliasType('SHORTINT','deprecated');
  2048. end;
  2049. procedure TTestTypeParser.TestSimpleTypeShortIntPlatform;
  2050. begin
  2051. DoTestAliasType('SHORTINT','platform');
  2052. end;
  2053. procedure TTestTypeParser.TestSimpleTypeSmallInt;
  2054. begin
  2055. DoTestAliasType('SMALLINT','');
  2056. end;
  2057. procedure TTestTypeParser.TestSimpleTypeSmallIntDeprecated;
  2058. begin
  2059. DoTestAliasType('SMALLINT','deprecated');
  2060. end;
  2061. procedure TTestTypeParser.TestSimpleTypeSmallIntPlatform;
  2062. begin
  2063. DoTestAliasType('SMALLINT','platform');
  2064. end;
  2065. procedure TTestTypeParser.TestSimpleTypeString;
  2066. begin
  2067. DoTestAliasType('STRING','');
  2068. end;
  2069. procedure TTestTypeParser.TestSimpleTypeStringDeprecated;
  2070. begin
  2071. DoTestAliasType('STRING','deprecated');
  2072. end;
  2073. procedure TTestTypeParser.TestSimpleTypeStringPlatform;
  2074. begin
  2075. DoTestAliasType('STRING','platform');
  2076. end;
  2077. procedure TTestTypeParser.TestSimpleTypeStringSize;
  2078. begin
  2079. DoTestStringType('String[10]','');
  2080. end;
  2081. procedure TTestTypeParser.TestSimpleTypeStringSizeIncomplete;
  2082. begin
  2083. DoTypeError('Incomplete string: missing ]','string[10');
  2084. end;
  2085. procedure TTestTypeParser.TestSimpleTypeStringSizeWrong;
  2086. begin
  2087. DoTypeError('Incomplete string, ) instead of ]','string[10)');
  2088. end;
  2089. procedure TTestTypeParser.TestSimpleTypeStringSizeDeprecated;
  2090. begin
  2091. DoTestStringType('String[10]','deprecated');
  2092. end;
  2093. procedure TTestTypeParser.TestSimpleTypeStringSizePlatform;
  2094. begin
  2095. DoTestStringType('String[10]','Platform');
  2096. end;
  2097. procedure TTestTypeParser.TestSimpleTypeWord;
  2098. BEGIN
  2099. DoTestAliasType('WORD','');
  2100. end;
  2101. procedure TTestTypeParser.TestSimpleTypeWordDeprecated;
  2102. begin
  2103. DoTestAliasType('WORD','deprecated');
  2104. end;
  2105. procedure TTestTypeParser.TestSimpleTypeWordPlatform;
  2106. begin
  2107. DoTestAliasType('WORD','platform');
  2108. end;
  2109. procedure TTestTypeParser.TestSimpleTypeQWord;
  2110. BEGIN
  2111. DoTestAliasType('QWORD','');
  2112. end;
  2113. procedure TTestTypeParser.TestSimpleTypeQWordDeprecated;
  2114. begin
  2115. DoTestAliasType('QWORD','deprecated');
  2116. end;
  2117. procedure TTestTypeParser.TestSimpleTypeQWordPlatform;
  2118. begin
  2119. DoTestAliasType('QWORD','platform');
  2120. end;
  2121. procedure TTestTypeParser.TestSimpleTypeCardinal;
  2122. begin
  2123. DoTestAliasType('CARDINAL','');
  2124. end;
  2125. procedure TTestTypeParser.TestSimpleTypeCardinalDeprecated;
  2126. begin
  2127. DoTestAliasType('CARDINAL','deprecated');
  2128. end;
  2129. procedure TTestTypeParser.TestSimpleTypeCardinalPlatform;
  2130. begin
  2131. DoTestAliasType('CARDINAL','platform');
  2132. end;
  2133. procedure TTestTypeParser.TestSimpleTypeWideChar;
  2134. begin
  2135. DoTestAliasType('WIDECHAR','');
  2136. end;
  2137. procedure TTestTypeParser.TestSimpleTypeWideCharDeprecated;
  2138. begin
  2139. DoTestAliasType('WIDECHAR','deprecated');
  2140. end;
  2141. procedure TTestTypeParser.TestSimpleTypeWideCharPlatform;
  2142. begin
  2143. DoTestAliasType('WIDECHAR','platform');
  2144. end;
  2145. procedure TTestTypeParser.TestPointerSimple;
  2146. begin
  2147. DoParsePointer('integer','');
  2148. end;
  2149. procedure TTestTypeParser.TestPointerSimpleDeprecated;
  2150. begin
  2151. DoParsePointer('integer','deprecated');
  2152. end;
  2153. procedure TTestTypeParser.TestPointerSimplePlatform;
  2154. begin
  2155. DoParsePointer('integer','platform');
  2156. end;
  2157. procedure TTestTypeParser.TestStaticArray;
  2158. begin
  2159. DoParseArray('array [0..2] of integer','',Nil);
  2160. AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
  2161. end;
  2162. procedure TTestTypeParser.TestStaticArrayDeprecated;
  2163. begin
  2164. DoParseArray('array [0..2] of integer','deprecated',Nil);
  2165. AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
  2166. end;
  2167. procedure TTestTypeParser.TestStaticArrayPlatform;
  2168. begin
  2169. DoParseArray('array [0..2] of integer','platform',Nil);
  2170. AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
  2171. end;
  2172. procedure TTestTypeParser.TestStaticArrayPacked;
  2173. begin
  2174. DoParseArray('packed array [0..2] of integer','',Nil);
  2175. AssertEquals('Array type','0..2',TPasArrayType(TheType).IndexRange);
  2176. AssertEquals('Packed',True,TPasArrayType(TheType).IsPacked);
  2177. end;
  2178. procedure TTestTypeParser.TestStaticArrayTypedIndex;
  2179. begin
  2180. DoParseArray('array [Boolean] of integer','',Nil);
  2181. AssertEquals('Array type','Boolean',TPasArrayType(TheType).IndexRange);
  2182. end;
  2183. procedure TTestTypeParser.TestDynamicArray;
  2184. begin
  2185. DoParseArray('array of integer','',Nil);
  2186. AssertEquals('Array type','',TPasArrayType(TheType).IndexRange);
  2187. end;
  2188. procedure TTestTypeParser.TestSimpleEnumerated;
  2189. begin
  2190. DoParseEnumerated('(one,two,three)','',3);
  2191. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2192. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2193. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2194. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2195. AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2196. AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2197. end;
  2198. procedure TTestTypeParser.TestSimpleEnumeratedDeprecated;
  2199. begin
  2200. DoParseEnumerated('(one,two,three)','deprecated',3);
  2201. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2202. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2203. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2204. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2205. AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2206. AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2207. end;
  2208. procedure TTestTypeParser.TestSimpleEnumeratedPlatform;
  2209. begin
  2210. DoParseEnumerated('(one,two,three)','platform',3);
  2211. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2212. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2213. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2214. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2215. AssertEquals('Assigned value second enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2216. AssertEquals('Assigned value third enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2217. end;
  2218. procedure TTestTypeParser.TestAssignedEnumerated;
  2219. begin
  2220. DoParseEnumerated('(one,two:=2,three)','',3);
  2221. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2222. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2223. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2224. AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2225. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2226. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2227. end;
  2228. procedure TTestTypeParser.TestAssignedEnumeratedDeprecated;
  2229. begin
  2230. DoParseEnumerated('(one,two:=2,three)','',3);
  2231. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2232. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2233. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2234. AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2235. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2236. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2237. end;
  2238. procedure TTestTypeParser.TestAssignedEnumeratedPlatform;
  2239. begin
  2240. DoParseEnumerated('(one,two:=2,three)','',3);
  2241. AssertEquals('First enumerated value','one',TPasEnumValue(TPasEnumType(TheType).Values[0]).Name);
  2242. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[0]).AssignedValue);
  2243. AssertEquals('Second enumerated value','two',TPasEnumValue(TPasEnumType(TheType).Values[1]).Name);
  2244. AssertEquals('Assigned value enumerated','2',TPasEnumValue(TPasEnumType(TheType).Values[1]).AssignedValue);
  2245. AssertEquals('Third enumerated value','three',TPasEnumValue(TPasEnumType(TheType).Values[2]).Name);
  2246. AssertEquals('Assigned value first enumerated empty','',TPasEnumValue(TPasEnumType(TheType).Values[2]).AssignedValue);
  2247. end;
  2248. procedure TTestTypeParser.TestFileType;
  2249. begin
  2250. DoTestFileType('integer','');
  2251. end;
  2252. procedure TTestTypeParser.TestFileTypeDeprecated;
  2253. begin
  2254. DoTestFileType('integer','deprecated');
  2255. end;
  2256. procedure TTestTypeParser.TestFileTypePlatform;
  2257. begin
  2258. DoTestFileType('integer','platform');
  2259. end;
  2260. procedure TTestTypeParser.TestRangeType;
  2261. begin
  2262. DoTestRangeType('1','4','');
  2263. end;
  2264. procedure TTestTypeParser.TestRangeTypeDeprecated;
  2265. begin
  2266. DoTestRangeType('1','4','deprecated');
  2267. end;
  2268. procedure TTestTypeParser.TestRangeTypePlatform;
  2269. begin
  2270. DoTestRangeType('1','4','platform');
  2271. end;
  2272. procedure TTestTypeParser.TestIdentifierRangeType;
  2273. begin
  2274. DoTestRangeType('tkFirst','tkLast','');
  2275. end;
  2276. procedure TTestTypeParser.TestIdentifierRangeTypeDeprecated;
  2277. begin
  2278. DoTestRangeType('tkFirst','tkLast','deprecated');
  2279. end;
  2280. procedure TTestTypeParser.TestIdentifierRangeTypePlatform;
  2281. begin
  2282. DoTestRangeType('tkFirst','tkLast','platform');
  2283. end;
  2284. procedure TTestTypeParser.TestNegativeIdentifierRangeType;
  2285. begin
  2286. DoTestRangeType('-tkLast','tkLast','');
  2287. end;
  2288. procedure TTestTypeParser.TestSimpleSet;
  2289. begin
  2290. DoParseSimpleSet('Byte','');
  2291. end;
  2292. procedure TTestTypeParser.TestSimpleSetDeprecated;
  2293. begin
  2294. DoParseSimpleSet('Byte','deprecated');
  2295. end;
  2296. procedure TTestTypeParser.TestSimpleSetPlatform;
  2297. begin
  2298. DoParseSimpleSet('Byte','platform');
  2299. end;
  2300. procedure TTestTypeParser.TestComplexSet;
  2301. begin
  2302. DoParseComplexSet('(one, two, three)','');
  2303. DoTestComplexSet;
  2304. end;
  2305. procedure TTestTypeParser.TestComplexSetDeprecated;
  2306. begin
  2307. DoParseComplexSet('(one, two, three)','deprecated');
  2308. DoTestComplexSet;
  2309. end;
  2310. procedure TTestTypeParser.TestComplexSetPlatform;
  2311. begin
  2312. DoParseComplexSet('(one, two, three)','platform');
  2313. DoTestComplexSet;
  2314. end;
  2315. procedure TTestTypeParser.TestRangeSet;
  2316. begin
  2317. DoParseRangeSet('0..SizeOf(Integer)*8-1','');
  2318. end;
  2319. procedure TTestTypeParser.TestRangeSetDeprecated;
  2320. begin
  2321. DoParseRangeSet('0..SizeOf(Integer)*8-1','deprecated');
  2322. end;
  2323. procedure TTestTypeParser.TestRangeSetPlatform;
  2324. begin
  2325. DoParseRangeSet('0..SizeOf(Integer)*8-1','platform');
  2326. end;
  2327. procedure TTestTypeParser.TestClassOf;
  2328. begin
  2329. DoTestClassOf('');
  2330. end;
  2331. procedure TTestTypeParser.TestClassOfDeprecated;
  2332. begin
  2333. DoTestClassOf('deprecated');
  2334. end;
  2335. procedure TTestTypeParser.TestClassOfPlatform;
  2336. begin
  2337. DoTestClassOf('Platform');
  2338. end;
  2339. procedure TTestTypeParser.TestReferenceAlias;
  2340. begin
  2341. Add('Type');
  2342. Add(' Type1 = Integer;');
  2343. Add(' Type2 = Type1;');
  2344. Add('end.');
  2345. ParseDeclarations;
  2346. AssertEquals('Two type definitions',2,Declarations.Types.Count);
  2347. AssertEquals('First declaration is type definition.',TPasAliasType,TObject(Declarations.Types[0]).ClassType);
  2348. AssertEquals('Second declaration is type definition.',TPasAliasType,TObject(Declarations.Types[1]).ClassType);
  2349. AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
  2350. AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
  2351. AssertSame('Second declaration references first.',Declarations.Types[0],TPasAliasType(Declarations.Types[1]).DestType);
  2352. end;
  2353. procedure TTestTypeParser.TestReferenceSet;
  2354. begin
  2355. Add('Type');
  2356. Add(' Type1 = (a,b,c);');
  2357. Add(' Type2 = set of Type1;');
  2358. Add('end.');
  2359. ParseDeclarations;
  2360. AssertEquals('Two type definitions',2,Declarations.Types.Count);
  2361. AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
  2362. AssertEquals('Second declaration is type definition.',TPasSetType,TObject(Declarations.Types[1]).ClassType);
  2363. AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
  2364. AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
  2365. AssertSame('Second declaration references first.',Declarations.Types[0],TPasSetType(Declarations.Types[1]).EnumType);
  2366. end;
  2367. procedure TTestTypeParser.TestReferenceClassOf;
  2368. begin
  2369. Add('Type');
  2370. Add(' Type1 = Class(TObject);');
  2371. Add(' Type2 = Class of Type1;');
  2372. Add('end.');
  2373. ParseDeclarations;
  2374. AssertEquals('1 type definitions',1,Declarations.Types.Count);
  2375. AssertEquals('1 class definitions',1,Declarations.Classes.Count);
  2376. AssertEquals('First declaration is class definition.',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
  2377. AssertEquals('Second declaration is type definition.',TPasClassOfType,TObject(Declarations.Types[0]).ClassType);
  2378. AssertEquals('First declaration has correct name.','Type2',TPasType(Declarations.Types[0]).Name);
  2379. AssertEquals('Second declaration has correct name.','Type1',TPasType(Declarations.Classes[0]).Name);
  2380. AssertSame('Second declaration references first.',Declarations.Classes[0],TPasClassOfType(Declarations.Types[0]).DestType);
  2381. end;
  2382. procedure TTestTypeParser.TestReferenceFile;
  2383. begin
  2384. Add('Type');
  2385. Add(' Type1 = (a,b,c);');
  2386. Add(' Type2 = File of Type1;');
  2387. Add('end.');
  2388. ParseDeclarations;
  2389. AssertEquals('Two type definitions',2,Declarations.Types.Count);
  2390. AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
  2391. AssertEquals('Second declaration is type definition.',TPasFileType,TObject(Declarations.Types[1]).ClassType);
  2392. AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
  2393. AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
  2394. AssertSame('Second declaration references first.',Declarations.Types[0],TPasFileType(Declarations.Types[1]).elType);
  2395. end;
  2396. procedure TTestTypeParser.TestReferenceArray;
  2397. begin
  2398. Add('Type');
  2399. Add(' Type1 = (a,b,c);');
  2400. Add(' Type2 = Array of Type1;');
  2401. Add('end.');
  2402. ParseDeclarations;
  2403. AssertEquals('Two type definitions',2,Declarations.Types.Count);
  2404. AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
  2405. AssertEquals('Second declaration is type definition.',TPasArrayType,TObject(Declarations.Types[1]).ClassType);
  2406. AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
  2407. AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
  2408. AssertSame('Second declaration references first.',Declarations.Types[0],TPasArrayType(Declarations.Types[1]).elType);
  2409. end;
  2410. procedure TTestTypeParser.TestReferencePointer;
  2411. begin
  2412. Add('Type');
  2413. Add(' Type1 = (a,b,c);');
  2414. Add(' Type2 = ^Type1;');
  2415. Add('end.');
  2416. ParseDeclarations;
  2417. AssertEquals('Two type definitions',2,Declarations.Types.Count);
  2418. AssertEquals('First declaration is type definition.',TPasEnumType,TObject(Declarations.Types[0]).ClassType);
  2419. AssertEquals('Second declaration is type definition.',TPasPointerType,TObject(Declarations.Types[1]).ClassType);
  2420. AssertEquals('First declaration has correct name.','Type1',TPasType(Declarations.Types[0]).Name);
  2421. AssertEquals('Second declaration has correct name.','Type2',TPasType(Declarations.Types[1]).Name);
  2422. AssertSame('Second declaration references first.',Declarations.Types[0],TPasPointerType(Declarations.Types[1]).DestType);
  2423. end;
  2424. initialization
  2425. RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);
  2426. end.