1 unit TestJitClass;
2
3 {$mode objfpc}{$H+}
4 {$ModeSwitch typehelpers}
5 {$inline off}
6 {$WARN 4055 off : Conversion between ordinals and pointers is not portable}
7 interface
8
9 uses
10 Classes, SysUtils, TypInfo, Math, fpcunit, testutils, testregistry,
11 JitClass, JitTypes, LazLogger, Rtti;
12
13 type
14
15 TInitProcedure = procedure of object;
16
17 { TPropListTest }
18
19 TPropListTest = class
20 private
21 FOwner: TTestCase;
22 FObject: TObject;
23 FPropCount: Integer;
24 FPropList: PPropList;
25 protected
GetPPropInfonull26 function GetPPropInfo(APropName: String): PPropInfo;
27 public
28 constructor Create(AnOwner: TTestCase; AnObject: TObject);
29 destructor Destroy; override;
30
31 procedure AssertPropCount(AName: String; AExpCount: Integer);
32 procedure AssertPropOffsets(AName: String='');
33 procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind);
34 procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: Int64);
35 procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: String);
36 end;
37
38 { TJitClassTest }
39
40 TJitClassTest = class(TTestCase)
41 private
42 FFreedObjList, FFreedMemList: TList;
43
44 procedure DoObjFreed(Sender: TObject);
45 procedure AssertWasObjFreed(AName: String; AnObj: TObject);
46 procedure AssertWasNotObjFreed(AName: String; AnObj: TObject);
47
48 procedure StartMemMonitor;
49 procedure StartAndClearMemMonitor;
50 procedure StopMemMonitor;
51 procedure ClearMemMonitor;
52 procedure AssertWasMemFreed(AName: String; AMem: Pointer);
53 procedure AssertWasNotMemFreed(AName: String; AMem: Pointer);
54
55 procedure DumpPropInfo(AClass: TClass);
56 private
57 // Methods for circle ref testing
58 FJitTypeLib: TJitTypeLibrary;
59 FJitCreator: array [1..3] of TJitClassCreator;
60
GetCreatornull61 function GetCreator(ABase: TClass; AName: String; PropClass: String = '';
62 ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator;
GetCreatornull63 function GetCreator(ABase: TJitClassCreator; AName: String; PropClass: String = '';
64 ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator;
65 procedure InitTwoClasses;
66 procedure InitTwoClassesWithOneSelfRef;
67 procedure InitTwoClassesWithDoubleLink;
68 procedure InitTwoClassesAnchestor;
69 procedure InitTwoClassesAnchestorWithAnchestorProp;
70 procedure InitTwoClassesAnchestorWithAnchestorPropOneWay; // not for auto ref count tests // NOT a circle
71 procedure InitThreeClasses;
72 procedure InitThreeClassesWithOneSelfRef;
73 procedure InitThreeClassesWithOneDoubleLink;
74 procedure InitThreeClassesWithSubLoop;
75 procedure InitThreeClassesWithSubLoopAndOneSelfRef;
76 procedure InitThreeClassesWithTwoSubLoop;
77 procedure InitThreeClassesChained;
78 procedure InitThreeClassesChainedIndirect;
79 procedure InitThreeClassesOneAnchestor;
80 procedure InitThreeClassesOneAnchestorIndirect;
81 procedure InitThreeClassesAnchestorParallel;
82 procedure InitThreeClassesAnchestorParallelIndirect; // 5 classes
83 procedure InitThreeClassesAnchestorParallelAndChildRef;
84 procedure InitThreeClassesAnchestorParallelAndChildRefIndirect;
85 procedure InitThreeClassesAnchestorParallelAndChildRefIndirect_2;
86 procedure InitThreeClassesAnchestorParallelAndChildLoop;
87 procedure InitThreeClassesAnchestorParallelAndChildLoopIndirect;
88 procedure InitThreeClassesAnchestorParallelAndChildLoopIndirect_2;
89 procedure InitThreeClassesTwoAnchestor;
90 procedure InitThreeClassesTwoAnchestorIndirect;
91
92 procedure TestTwoClassRefCount(AnInitProc: TInitProcedure);
93 procedure TestThreeClassRefCount(AnInitProc: TInitProcedure);
94
95 protected
96 procedure DoStreamCopy(AJitSource, AJitDest: TComponent);
97 procedure DoTestSimpleClass(AJitClass, AnExpParentClass: TComponentClass);
98
99 procedure TearDown; override;
100 published
101 procedure TestSimpleClass; // Test unmodified Jit
102 procedure TestSimpleClassNested; // Test unmodified Jit, with Jit as base
103 procedure TestJitPropSimple;
104 procedure TestJitParseClass;
105 procedure TestJitPropCircularClassDef;
106 procedure TestManagedJitProp;
107 procedure TestRefCount;
108 procedure TestRefCountProp;
109 procedure TestRefCountClassCircle;
110 procedure TestRefCountMethodCircle;
111 procedure TestParseJitType; // Parser errors / also run with valgrind
112 procedure TestSetEnum;
113 procedure TestMethods;
114 end;
115
116 implementation
117
118 var
119 MMgr: TMemoryManager;
120 HeapState: TFPCHeapStatus;
121 GlobFreedMemList: TList;
122 InMyFreeMem: Integer;
123
GetMemUsednull124 function GetMemUsed: integer;
125 begin
126 GetMemoryManager(MMgr);
127 HeapState := MMgr.GetFPCHeapStatus();
128 Result := HeapState.CurrHeapUsed;
129 end;
130
131 var
132 TestVirt: Integer;
133 OrigFreemem : Function(p:pointer):ptruint;
134 OrigFreememSize : Function(p:pointer;Size:ptruint):ptruint;
135
MyFreememnull136 Function MyFreemem(p:pointer):ptruint;
137 begin
138 inc(InMyFreeMem);
139 Result := OrigFreemem(p);
140 if (InMyFreeMem = 1) and (GlobFreedMemList <> nil) then begin
141 GlobFreedMemList.Add(p);
142 end;
143 dec(InMyFreeMem);
144 end;
MyFreememSizenull145 Function MyFreememSize(p:pointer;Size:ptruint):ptruint;
146 begin
147 inc(InMyFreeMem);
148 Result := OrigFreememSize(p,Size);
149 if (InMyFreeMem = 1) and (GlobFreedMemList <> nil) then begin
150 GlobFreedMemList.Add(p);
151 end;
152 dec(InMyFreeMem);
153 end;
154
155
156 type
157
158 { TMyBaseClass }
159
160 TMyBaseClass = class(TComponent)
161 private
162 FMyBaseInt: Integer;
163 public
164 procedure MyVirt; virtual;
165 published
166 property MyBaseInt: Integer read FMyBaseInt write FMyBaseInt;
167 end;
168
169 { TMyClass }
170
171 TMyClass = class(TMyBaseClass)
172 private
173 FMyLines: TStringList;
174 FMyEvent: TNotifyEvent;
175 FMyText: AnsiString;
176 procedure SetMyLines(AValue: TStringList);
177 protected
178 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
179 public
180 FMyDynArray: Array of integer;
181 constructor Create(AOwner: TComponent); override;
182 destructor Destroy; override;
183 procedure MyVirt; override;
184 published
185 MyField: TMyBaseClass;
186 procedure MyFoo(Sender: TObject);
187 property MyLines: TStringList read FMyLines write SetMyLines;
188 property MyText: AnsiString read FMyText write FMyText;
189 property MyEvent: TNotifyEvent read FMyEvent write FMyEvent;
190 end;
191
192 const
193 MYCLASS_PROP_COUNT = 6;
194
195 { TMyBaseClass }
196
197 procedure TMyBaseClass.MyVirt;
198 begin
199 TestVirt := 1;
200 end;
201
202 { TMyClass }
203
204 procedure TMyClass.SetMyLines(AValue: TStringList);
205 begin
206 if FMyLines = AValue then Exit;
207 FMyLines.Assign(AValue);
208 end;
209
210 procedure TMyClass.GetChildren(Proc: TGetChildProc; Root: TComponent);
211 begin
212 inherited GetChildren(Proc, Root);
213 if MyField <> nil then
214 Proc(MyField);
215 end;
216
217 constructor TMyClass.Create(AOwner: TComponent);
218 begin
219 inherited Create(AOwner);
220 FMyLines := TStringList.Create;
221 end;
222
223 destructor TMyClass.Destroy;
224 begin
225 FMyLines.Free;
226 MyField.Free;
227 inherited Destroy;
228 end;
229
230 procedure TMyClass.MyVirt;
231 begin
232 TestVirt := 2;
233 end;
234
235 procedure TMyClass.MyFoo(Sender: TObject);
236 begin
237 //
238 end;
239
240 { TPropListTest }
241
TPropListTest.GetPPropInfonull242 function TPropListTest.GetPPropInfo(APropName: String): PPropInfo;
243 var
244 i: Integer;
245 begin
246 Result := nil;
247 for i := 0 to FPropCount-1 do
248 if FPropList^[i]^.Name = APropName then
249 exit(FPropList^[i]);
250 end;
251
252 constructor TPropListTest.Create(AnOwner: TTestCase; AnObject: TObject);
253 begin
254 FOwner := AnOwner;
255 FObject := AnObject;
256 FPropCount := GetPropList(AnObject, FPropList);
257 end;
258
259 destructor TPropListTest.Destroy;
260 begin
261 if FPropCount > 0 then
262 Freemem(FPropList);
263 inherited Destroy;
264 end;
265
266 procedure TPropListTest.AssertPropCount(AName: String; AExpCount: Integer);
267 begin
268 FOwner.AssertEquals(AName+' (PropCount)', AExpCount, FPropCount);
269 end;
270
271 procedure TPropListTest.AssertPropOffsets(AName: String);
272 var
273 CurPvmt, ParPvmt: pvmt;
274 PropInf: PPropInfo;
275 MaxOffs, MinOffs: SizeInt;
276 ParMaxOffs: SmallInt;
277 PropCount, i: Integer;
278 begin
279 CurPvmt := PPVmt(FObject)^;
280 PropCount := FPropCount;
281 ParPvmt := CurPvmt^.vParent;
282 MaxOffs := CurPvmt^.vInstanceSize;
283 if ParPvmt <> nil then begin
284 MinOffs := ParPvmt^.vInstanceSize;
285 ParMaxOffs := GetTypeData(ParPvmt^.vTypeInfo)^.Propcount;
286 end
287 else begin
288 ParMaxOffs := -1;
289 MinOffs := 0
290 end;
291
292 FOwner.AssertTrue('', PropCount > 0);
293 FOwner.AssertTrue('', PropCount >= ParMaxOffs);
294 for i := 0 to PropCount-1 do begin
295 PropInf := FPropList^[i];
296 if i >= ParMaxOffs then
297 FOwner.AssertTrue('', PropInf^.PropProcs = (ptConst shl 4));
298
299 if PropInf^.PropProcs = 0 then begin
300 //if PtrUInt(PropInf^.GetProc) <> 0 then
301 FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) <> 0));
302 FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) < MaxOffs));
303 if PtrUInt(PropInf^.SetProc) <> 0 then
304 FOwner.AssertTrue(AName+' (SetProc))', (PtrUInt(PropInf^.SetProc) < MaxOffs));
305
306 if i >= ParMaxOffs then begin // belong to CurPvmt / must be bigger than MinOffs;
307 //if PtrUInt(PropInf^.GetProc) <> 0 then
308 FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) >= MinOffs));
309 if PtrUInt(PropInf^.SetProc) <> 0 then
310 FOwner.AssertTrue(AName+' (SetProc))', (PtrUInt(PropInf^.SetProc) >= MinOffs));
311 end;
312 end;
313 end;
314 end;
315
316 procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind);
317 var
318 PropInfo: PPropInfo;
319 begin
320 PropInfo := GetPPropInfo(APropName);
321 FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil);
322 FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil);
323 FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind));
324 end;
325
326 procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: Int64);
327 var
328 PropInfo: PPropInfo;
329 begin
330 PropInfo := GetPPropInfo(APropName);
331 FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil);
332 FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil);
333 FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind));
334
335 FOwner.AssertEquals(AName+' (Val for '+APropName+')', AValue, GetOrdProp(FObject, PropInfo));
336 end;
337
338 procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: String);
339 var
340 PropInfo: PPropInfo;
341 begin
342 PropInfo := GetPPropInfo(APropName);
343 FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil);
344 FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil);
345 FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind));
346
347 FOwner.AssertEquals(AName+' (Val for '+APropName+')', AValue, GetStrProp(FObject, PropInfo));
348 end;
349
350 { TJitClassTest }
351
352 procedure TJitClassTest.DoObjFreed(Sender: TObject);
353 begin
354 if FFreedObjList = nil then
355 FFreedObjList := TList.Create;
356 FFreedObjList.Add(Pointer(Sender));
357 end;
358
359 procedure TJitClassTest.AssertWasObjFreed(AName: String; AnObj: TObject);
360 begin
361 AssertTrue(AName, (FFreedObjList <> nil) and (FFreedObjList.IndexOf(Pointer(AnObj)) >= 0));
362 end;
363
364 procedure TJitClassTest.AssertWasNotObjFreed(AName: String; AnObj: TObject);
365 begin
366 AssertFalse(AName, (FFreedObjList <> nil) and (FFreedObjList.IndexOf(Pointer(AnObj)) >= 0));
367 end;
368
369 procedure TJitClassTest.StartMemMonitor;
370 begin
371 if FFreedMemList = nil then
372 FFreedMemList := TList.Create;
373
374 GlobFreedMemList := FFreedMemList;
375 end;
376
377 procedure TJitClassTest.StartAndClearMemMonitor;
378 begin
379 ClearMemMonitor;
380 StartMemMonitor;
381 end;
382
383 procedure TJitClassTest.StopMemMonitor;
384 begin
385 GlobFreedMemList := nil;
386 end;
387
388 procedure TJitClassTest.ClearMemMonitor;
389 begin
390 inc(InMyFreeMem);
391 if FFreedMemList <> nil then
392 FFreedMemList.Clear;
393 dec(InMyFreeMem);
394 end;
395
396 procedure TJitClassTest.AssertWasMemFreed(AName: String; AMem: Pointer);
397 begin
398 AssertTrue(AName, (FFreedMemList <> nil) and (FFreedMemList.IndexOf(AMem) >= 0));
399 end;
400
401 procedure TJitClassTest.AssertWasNotMemFreed(AName: String; AMem: Pointer);
402 begin
403 AssertFalse(AName, (FFreedMemList <> nil) and (FFreedMemList.IndexOf(AMem) >= 0));
404 end;
405
406 procedure TJitClassTest.DumpPropInfo(AClass: TClass);
407 var
408 PropCount, i: Integer;
409 PropList: PPropList;
410 begin
411 PropCount := GetPropList(AClass, PropList);
412 if PropCount>0 then begin
413 try
414 DebugLn(['--- ', PropCount, ' InstSize ', PVmt(AClass)^.vInstanceSize]);
415 for i := 0 to PropCount-1 do
416 DebugLn('## %25s %2d // %2d %2d // %10d %d %d %d ', [
417 PropList^[i]^.Name, PropList^[i]^.NameIndex,
418 PropList^[i]^.Index, PropList^[i]^.Default,
419 ptruint(PropList^[i]^.PropType),
420 ptruint(PropList^[i]^.GetProc),
421 ptruint(PropList^[i]^.SetProc),
422 ptruint(PropList^[i]^.StoredProc)
423 ]);
424 finally
425 Freemem(PropList);
426 end;
427 end;
428 end;
429
430 procedure TJitClassTest.DoStreamCopy(AJitSource, AJitDest: TComponent);
431 var
432 strm: TMemoryStream;
433 Driver: TAbstractObjectWriter;
434 Writer: TWriter;
435 Reader: TReader;
436 begin
437 strm := TMemoryStream.Create;
438 Driver := TBinaryObjectWriter.Create(strm,4096);
439 Writer := TWriter.Create(Driver);
440 Writer.WriteRootComponent(AJitSource);
441 Driver.Free;
442 Writer.Free;
443
444 strm.Position := 0;
445 Reader := TReader.Create(strm, 4096);
446 Reader.ReadRootComponent(AJitDest);
447 Reader.Free;
448
449 strm.Free;
450 end;
451
452 procedure TJitClassTest.DoTestSimpleClass(AJitClass,
453 AnExpParentClass: TComponentClass);
454 var
455 JitObject, JitObject2: TMyClass;
456 MemUsed, MemUsed2, PropCount, i: Integer;
457 PropList: PPropList;
458 TestProps: TPropListTest;
459 begin
460 AssertEquals('Got class-name', 'TJitTestSimpleClass', AJitClass.ClassName);
461 AssertEquals('Got unit-name', 'foo.pas', AJitClass.UnitName);
462 AssertEquals('Got class-parent', AnExpParentClass, AJitClass.ClassParent);
463 AssertEquals('Got instance-size', TMyClass.InstanceSize, AJitClass.InstanceSize);
464
465 MemUsed := GetMemUsed;
466
467 // Call the virtual method
468 JitObject := TMyClass(AJitClass.Create(nil));
469 TMyBaseClass(JitObject).MyVirt;
470 AssertEquals('virt meth call', 2, TestVirt);
471
472 // check all memory is freed
473 JitObject.Free;
474 MemUsed2 := GetMemUsed;
475 AssertEquals('Memory freed', MemUsed, MemUsed2);
476
477 // check all memory is freed / including managed types
478 JitObject := TMyClass(AJitClass.Create(nil));
479 SetLength(JitObject.FMyDynArray, 100);
480 JitObject.Free;
481 MemUsed2 := GetMemUsed;
482 AssertEquals('Memory freed (dyn array)', MemUsed, MemUsed2);
483
484 // check RTTI properties
485 JitObject := TMyClass(AJitClass.Create(nil));
486 SetLength(JitObject.FMyDynArray, 1);
487 JitObject.MyBaseInt := 88123;
488 JitObject.MyText := 'SomeText';
489 JitObject.MyLines.Text := 'Line123';
490 JitObject.MyEvent := @JitObject.MyFoo;
491 JitObject.MyField := TMyBaseClass.Create(JitObject);
492 JitObject.MyField.Name := 'MyField';
493
494 TestProps := TPropListTest.Create(Self, JitObject);
495 try
496 TestProps.AssertPropCount('', 6);
497 TestProps.AssertPropOffsets;
498 TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123);
499 TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText');
500 TestProps.AssertHasProp('', 'MyLines', tkClass);
501 TestProps.AssertHasProp('', 'MyEvent', tkMethod);
502 finally
503 TestProps.Free;
504 end;
505
506 // stream and copy
507 JitObject2 := TMyClass(AJitClass.Create(nil));
508 DoStreamCopy(JitObject, JitObject2);
509
510 AssertEquals('Stream-copied BaseInt', 88123, JitObject2.MyBaseInt);
511 AssertEquals('Stream-copied MyText', 'SomeText', JitObject2.MyText);
512 AssertEquals('Stream-copied MyLines', 'Line123', JitObject2.MyLines[0]);
513 AssertTrue ('Stream-copied MyEvent', @JitObject.MyFoo = JitObject2.MyEvent);
514 AssertTrue ('Stream-copied MyField', JitObject2.MyField <> nil);
515 AssertEquals('Stream-copied MyField', 'MyField', JitObject2.MyField.Name);
516
517 TestProps := TPropListTest.Create(Self, JitObject2);
518 try
519 TestProps.AssertPropCount('', 6);
520 TestProps.AssertPropOffsets;
521 TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123);
522 TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText');
523 TestProps.AssertHasProp('', 'MyLines', tkClass);
524 TestProps.AssertHasProp('', 'MyEvent', tkMethod);
525 finally
526 TestProps.Free;
527 end;
528
529 JitObject2.Free;
530
531
532
533 PropCount := GetPropList(JitObject, PropList);
534 if PropCount>0 then begin
535 try
536 for i := 0 to PropCount-1 do
537 WriteLn('## ',
538 ' / ', PropList^[i]^.Name,
539 ' / ', PropList^[i]^.NameIndex,
540 ' / ', PropList^[i]^.Index,
541 ' / ', PropList^[i]^.Default,
542 ' / ', ptruint(PropList^[i]^.PropType),
543 ' / ', ptruint(PropList^[i]^.GetProc),
544 ' / ', ptruint(PropList^[i]^.SetProc),
545 ' / ', ptruint(PropList^[i]^.StoredProc)
546
547 );
548 finally
549 Freemem(PropList);
550 end;
551 end;
552
553 // RTTI methods
554 AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(AJitClass.MethodAddress('MyFoo')));
555 AssertEquals('Addr of Func', 'MyFoo', AJitClass.MethodName(@TMyClass.MyFoo));
556
557 AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(JitObject.MethodAddress('MyFoo')));
558 AssertEquals('Addr of Func', 'MyFoo', JitObject.MethodName(@TMyClass.MyFoo));
559
560 AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(JitObject.ClassType.MethodAddress('MyFoo')));
561 AssertEquals('Addr of Func', 'MyFoo', JitObject.ClassType.MethodName(@TMyClass.MyFoo));
562
563 AssertEquals('Func of none Addr', 0, PtrUint(AJitClass.MethodAddress('NotHere')));
564 AssertEquals('Addr of none Func', '', AJitClass.MethodName(codepointer($11002233)));
565
566 // RTTI fields
567
568 AssertEquals('Addr of Field', PtrUint(@JitObject.MyField), PtrUint(JitObject.FieldAddress('MyField')));
569 AssertEquals('Addr of none Field', 0, PtrUint(JitObject.FieldAddress('NotHere')));
570
571 JitObject.Free;
572 end;
573
574 procedure TJitClassTest.TearDown;
575 begin
576 inherited TearDown;
577 GlobFreedMemList := nil;
578 FreeAndNil(FFreedObjList);
579 FreeAndNil(FFreedMemList);
580 end;
581
582 procedure TJitClassTest.TestSimpleClass;
583 var
584 JitCreator: TJitClassCreator;
585 type
586 TTa= array of record a,b,c: cardinal; end; // vartype -1 // elSize 12
587 TTb= array of record a,b,c: string; end; // vartype -1 // elSize 24
588 TTc= array of byte; // vartype 17 // elSize 1
589 var a,b,c: PTypeInfo;
590 begin
591 a := PTypeInfo(TypeInfo(tta));
592 b := PTypeInfo(TypeInfo(ttb));
593 c := PTypeInfo(TypeInfo(ttc));
594 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleClass', 'foo.pas');
595 DoTestSimpleClass(TComponentClass(JitCreator.JitClass), TMyClass);
596 JitCreator.Free;
597 end;
598
599 procedure TJitClassTest.TestSimpleClassNested;
600 var
601 JitCreator, JitCreatorNested: TJitClassCreator;
602 begin
603 (* Include an empty JitClass as parent
604 Test that a JitClass can be used as parent
605 *)
606 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas');
607 JitCreatorNested := TJitClassCreator.Create(JitCreator.JitClass, 'TJitTestSimpleClass', 'foo.pas');
608 DoTestSimpleClass(TComponentClass(JitCreatorNested.JitClass), TComponentClass(JitCreator.JitClass));
609 JitCreator.Free;
610 JitCreatorNested.Free;
611 end;
612
613 procedure TJitClassTest.TestJitPropSimple;
614 var
615 JitCreator: TJitClassCreator;
616 JitClass: TComponentClass;
617 JitObject, JitObject2: TComponent;
618 TestProps: TPropListTest;
619 PropList: PPropList;
620 PropCount, i: Integer;
621 begin
622 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas');
623
624 JitCreator.JitProperties.Add('JitInt32', 'longint');
625 JitCreator.JitProperties.Add('JitInt64', 'int64');
626 JitCreator.JitProperties.Add('JitWord1', 'word');
627 JitCreator.JitProperties.Add('JitWord2', 'Word');
628 JitCreator.JitProperties.Add('JitString', 'AnsiString');
629
630 JitClass := TComponentClass(JitCreator.JitClass);
631 JitObject := JitClass.Create(nil);
632
633
634 PropCount := GetPropList(JitObject, PropList);
635 if PropCount>0 then begin
636 try
637 for i := 0 to PropCount-1 do
638 WriteLn(format('## %15s %2d / %2d %10d / %x %d %d %d', [
639 AnsiString(PropList^[i]^.Name),
640 PropList^[i]^.NameIndex,
641 PropList^[i]^.Index,
642 PropList^[i]^.Default,
643 ptruint(PropList^[i]^.PropType),
644 ptruint(PropList^[i]^.GetProc),
645 ptruint(PropList^[i]^.SetProc),
646 ptruint(PropList^[i]^.StoredProc)
647 ]));
648 finally
649 Freemem(PropList);
650 end;
651 end;
652
653 TestProps := TPropListTest.Create(Self, JitObject);
654 try
655 TestProps.AssertPropCount('', 11);
656 TestProps.AssertPropOffsets;
657 //TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123);
658 //TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText');
659 TestProps.AssertHasProp('', 'MyLines', tkClass);
660 TestProps.AssertHasProp('', 'MyEvent', tkMethod);
661
662 TestProps.AssertHasProp('', 'JitInt32', tkInteger);
663 TestProps.AssertHasProp('', 'JitInt64', tkInt64);
664 TestProps.AssertHasProp('', 'JitWord1', tkInteger);
665 TestProps.AssertHasProp('', 'JitWord2', tkInteger);
666 TestProps.AssertHasProp('', 'JitString', tkAString);
667 finally
668 TestProps.Free;
669 end;
670
671 SetOrdProp(JitObject, 'JitInt32', $66771122);
672 SetOrdProp(JitObject, 'JitInt64', $7557444475574444);
673 SetOrdProp(JitObject, 'JitWord1', $2332);
674 SetOrdProp(JitObject, 'JitWord2', $4334);
675 SetStrProp(JitObject, 'JitString', 'Hello World');
676
677 AssertEquals(GetOrdProp(JitObject, 'JitInt32'), $66771122);
678 AssertEquals(GetOrdProp(JitObject, 'JitInt64'), $7557444475574444);
679 AssertEquals(GetOrdProp(JitObject, 'JitWord1'), $2332);
680 AssertEquals(GetOrdProp(JitObject, 'JitWord2'), $4334);
681 AssertEquals(GetStrProp(JitObject, 'JitString'), 'Hello World');
682
683 // set in reverse order
684 SetStrProp(JitObject, 'JitString', 'Hello World');
685 SetOrdProp(JitObject, 'JitWord2', $4334);
686 SetOrdProp(JitObject, 'JitWord1', $2332);
687 SetOrdProp(JitObject, 'JitInt64', $7557444475574444);
688 SetOrdProp(JitObject, 'JitInt32', $66771122);
689
690 AssertEquals(GetOrdProp(JitObject, 'JitInt32'), $66771122);
691 AssertEquals(GetOrdProp(JitObject, 'JitInt64'), $7557444475574444);
692 AssertEquals(GetOrdProp(JitObject, 'JitWord1'), $2332);
693 AssertEquals(GetOrdProp(JitObject, 'JitWord2'), $4334);
694 AssertEquals(GetStrProp(JitObject, 'JitString'), 'Hello World');
695
696 JitObject2 := JitClass.Create(nil);
697 DoStreamCopy(JitObject, JitObject2);
698 AssertEquals(GetOrdProp(JitObject2, 'JitInt32'), $66771122);
699 AssertEquals(GetOrdProp(JitObject2, 'JitInt64'), $7557444475574444);
700 AssertEquals(GetOrdProp(JitObject2, 'JitWord1'), $2332);
701 AssertEquals(GetOrdProp(JitObject2, 'JitWord2'), $4334);
702 AssertEquals(GetStrProp(JitObject2, 'JitString'), 'Hello World');
703
704 JitObject2.Free;
705 JitObject.Free;
706 JitCreator.Free;
707 end;
708
709 procedure TJitClassTest.TestJitParseClass;
710 var
711 JitCreator: TJitClassCreator;
712 begin
713 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo');
714 JitCreator.JitProperties.ParseFromClassDeclaration(
715 'class(foo)' +
716 'published' +
717 ' property TestProp1: int64 read foo write foo;' +
718 ' property TestProp2: int64 read foo;' +
719 'a: word;' +
720 'function foo: boolean;' +
721 ' property TestProp3: int64 read foo;' +
722 'end'
723 );
724
725 AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0);
726 AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0);
727 AssertTrue(JitCreator.JitProperties.IndexOf('TestProp3') >= 0);
728 AssertTrue(JitCreator.JitProperties.IndexOf('TestFoo') < 0);
729
730 JitCreator.Free;
731 end;
732
733 procedure TJitClassTest.TestJitPropCircularClassDef;
734 procedure DoTestProps(AClass: TClass);
735 var
736 Obj: TComponent;
737 TestProps: TPropListTest;
738 begin
739 Obj := TComponentClass(AClass).Create(nil);
740 TestProps := TPropListTest.Create(Self, Obj);
741 try
742 //TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4);
743 TestProps.AssertPropOffsets;
744 finally
745 TestProps.Free;
746 Obj.Free;
747 end;
748 end;
749 procedure TestTwoClassProps(AnInitProc: TInitProcedure; NotACircle: Boolean = False);
750 var
751 i, MemUsed: Integer;
752 cl: TClass;
753 pi: PPropInfo;
754 ti: PTypeInfo;
755 begin
756 for i := 1 to 2 do begin
757 AnInitProc();
758
759 case i of // which class to access first
760 1: FJitCreator[1].JitClass;
761 2: FJitCreator[2].JitClass;
762 end;
763 MemUsed := GetMemUsed;
764 DoTestProps(FJitCreator[1].JitClass);
765 DoTestProps(FJitCreator[2].JitClass);
766 if not NotACircle then
767 AssertEquals('No more Memory alloc', MemUsed, GetMemUsed);
768
769 FJitTypeLib.Free;
770 FJitCreator[1].Free;
771 FJitCreator[2].Free;
772 end;
773 // only access one class
774 for i := 1 to 2 do begin
775 AnInitProc();
776
777 case i of // which class to access first
778 1: cl := FJitCreator[1].JitClass;
779 2: cl := FJitCreator[2].JitClass;
780 end;
781 DoTestProps(cl);
782 if cl.ClassParent.ClassName <> 'TMyClass' then
783 DoTestProps(cl.ClassParent);
784 pi := GetPropInfo(cl, 'a');
785 if pi <> nil then begin
786 ti := pi^.PropType;
787 AssertTrue(ti <> nil);
788 if ti^.Kind = tkClass then
789 DoTestProps(GetTypeData(ti)^.ClassType);
790 end;
791 pi := GetPropInfo(cl, 'b');
792 if pi <> nil then begin
793 ti := pi^.PropType;
794 AssertTrue(ti <> nil);
795 if ti^.Kind = tkClass then
796 DoTestProps(GetTypeData(ti)^.ClassType);
797 end;
798 pi := GetPropInfo(cl, 'par');
799 if pi <> nil then begin
800 ti := pi^.PropType;
801 AssertTrue(ti <> nil);
802 if ti^.Kind = tkClass then
803 DoTestProps(GetTypeData(ti)^.ClassType);
804 end;
805
806 FJitTypeLib.Free;
807 FJitCreator[1].Free;
808 FJitCreator[2].Free;
809 end;
810 end;
811 procedure TestThreeClassProps(AnInitProc: TInitProcedure);
812 var
813 i, MemUsed: Integer;
814 cl: TClass;
815 pi: PPropInfo;
816 ti: PTypeInfo;
817 begin
818 for i := 1 to 3 do begin
819 AnInitProc();
820
821 case i of // which class to access first
822 1: FJitCreator[1].JitClass;
823 2: FJitCreator[2].JitClass;
824 3: FJitCreator[3].JitClass;
825 end;
826 MemUsed := GetMemUsed;
827 DoTestProps(FJitCreator[1].JitClass);
828 DoTestProps(FJitCreator[2].JitClass);
829 DoTestProps(FJitCreator[3].JitClass);
830 AssertEquals('No more Memory alloc', MemUsed, GetMemUsed);
831
832 FJitTypeLib.Free;
833 FJitCreator[1].Free;
834 FJitCreator[2].Free;
835 FJitCreator[3].Free;
836 end;
837 // only access one class
838 for i := 1 to 3 do begin
839 AnInitProc();
840
841 case i of // which class to access first
842 1: cl := FJitCreator[1].JitClass;
843 2: cl := FJitCreator[2].JitClass;
844 3: cl := FJitCreator[3].JitClass;
845 end;
846 DoTestProps(cl);
847 if cl.ClassParent.ClassName <> 'TMyClass' then
848 DoTestProps(cl.ClassParent);
849 pi := GetPropInfo(cl, 'a');
850 if pi <> nil then begin
851 ti := pi^.PropType;
852 AssertTrue(ti <> nil);
853 if ti^.Kind = tkClass then
854 DoTestProps(GetTypeData(ti)^.ClassType);
855 end;
856 pi := GetPropInfo(cl, 'b');
857 if pi <> nil then begin
858 ti := pi^.PropType;
859 AssertTrue(ti <> nil);
860 if ti^.Kind = tkClass then
861 DoTestProps(GetTypeData(ti)^.ClassType);
862 end;
863 pi := GetPropInfo(cl, 'par');
864 if pi <> nil then begin
865 ti := pi^.PropType;
866 AssertTrue(ti <> nil);
867 if ti^.Kind = tkClass then
868 DoTestProps(GetTypeData(ti)^.ClassType);
869 end;
870
871 FJitTypeLib.Free;
872 FJitCreator[1].Free;
873 FJitCreator[2].Free;
874 FJitCreator[3].Free;
875 end;
876 end;
877
878 var
879 JitObject1, JitObject2: TComponent;
880 TestProps: TPropListTest;
881 begin
882 (* set up different circular scenarios *)
883
884 //////////////////////////////////
885 // 1 classes circle
886 FJitTypeLib := TJitTypeLibrary.Create;
887 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassOne');
888
889 JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil);
890 TestProps := TPropListTest.Create(Self, JitObject1);
891 try
892 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4);
893 TestProps.AssertPropOffsets;
894 TestProps.AssertHasProp('', 'a', tkClass);
895 TestProps.AssertHasProp('', 'prop1', tkInt64);
896 TestProps.AssertHasProp('', 'prop2', tkInteger);
897 TestProps.AssertHasProp('', 'prop3', tkInt64);
898 finally
899 TestProps.Free;
900 end;
901
902 JitObject1.Free;
903 FJitCreator[1].Free;
904 FJitTypeLib.Free;
905
906
907 // 2 class Property Circle
908 InitTwoClasses;
909 JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil);
910 JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil);
911
912 TestProps := TPropListTest.Create(Self, JitObject1);
913 try
914 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4);
915 TestProps.AssertPropOffsets;
916 TestProps.AssertHasProp('', 'a', tkClass);
917 TestProps.AssertHasProp('', 'prop1', tkInt64);
918 TestProps.AssertHasProp('', 'prop2', tkInteger);
919 TestProps.AssertHasProp('', 'prop3', tkInt64);
920 finally
921 TestProps.Free;
922 end;
923
924 TestProps := TPropListTest.Create(Self, JitObject2);
925 try
926 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4);
927 TestProps.AssertPropOffsets;
928 TestProps.AssertHasProp('', 'a', tkClass);
929 TestProps.AssertHasProp('', 'prop1', tkInt64);
930 TestProps.AssertHasProp('', 'prop2', tkInteger);
931 TestProps.AssertHasProp('', 'prop3', tkInt64);
932 finally
933 TestProps.Free;
934 end;
935
936 JitObject1.Free;
937 JitObject2.Free;
938 FJitCreator[1].Free;
939 FJitCreator[2].Free;
940 FJitTypeLib.Free;
941
942
943 // Anchestor Class, has child-class as property
944 InitTwoClassesAnchestor;
945 JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil);
946 JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil);
947
948 TestProps := TPropListTest.Create(Self, JitObject1);
949 try
950 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4);
951 TestProps.AssertPropOffsets;
952 TestProps.AssertHasProp('', 'a', tkClass);
953 TestProps.AssertHasProp('', 'prop1', tkInt64);
954 TestProps.AssertHasProp('', 'prop2', tkInteger);
955 TestProps.AssertHasProp('', 'prop3', tkInt64);
956 finally
957 TestProps.Free;
958 end;
959
960 TestProps := TPropListTest.Create(Self, JitObject2);
961 try
962 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 6);
963 TestProps.AssertPropOffsets;
964 TestProps.AssertHasProp('', 'a', tkClass);
965 TestProps.AssertHasProp('', 'prop1', tkBool);
966 TestProps.AssertHasProp('', 'prop2', tkInteger);
967 TestProps.AssertHasProp('', 'prop3', tkInt64);
968 TestProps.AssertHasProp('', 'bprop1', tkInt64);
969 TestProps.AssertHasProp('', 'bprop2', tkInt64);
970 finally
971 TestProps.Free;
972 end;
973
974 JitObject1.Free;
975 JitObject2.Free;
976 FJitCreator[1].Free;
977 FJitCreator[2].Free;
978 FJitTypeLib.Free;
979
980
981 // Child Class, has anchestor-class as property / not a circle
982 InitTwoClassesAnchestorWithAnchestorPropOneWay;
983 JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil);
984 JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil);
985
986 TestProps := TPropListTest.Create(Self, JitObject1);
987 try
988 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 3);
989 TestProps.AssertPropOffsets;
990 TestProps.AssertHasProp('', 'prop1', tkInt64);
991 TestProps.AssertHasProp('', 'prop2', tkInteger);
992 TestProps.AssertHasProp('', 'prop3', tkInt64);
993 finally
994 TestProps.Free;
995 end;
996
997 TestProps := TPropListTest.Create(Self, JitObject2);
998 try
999 TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 6);
1000 TestProps.AssertPropOffsets;
1001 TestProps.AssertHasProp('', 'prop1', tkBool);
1002 TestProps.AssertHasProp('', 'prop2', tkInteger);
1003 TestProps.AssertHasProp('', 'prop3', tkInt64);
1004 TestProps.AssertHasProp('', 'par', tkClass);
1005 TestProps.AssertHasProp('', 'bprop1', tkInt64);
1006 TestProps.AssertHasProp('', 'bprop2', tkInt64);
1007 finally
1008 TestProps.Free;
1009 end;
1010
1011 JitObject1.Free;
1012 JitObject2.Free;
1013 FJitCreator[1].Free;
1014 FJitCreator[2].Free;
1015 FJitTypeLib.Free;
1016
1017 /////////////////////
1018
1019 TestTwoClassProps(@InitTwoClasses);
1020 TestTwoClassProps(@InitTwoClassesWithOneSelfRef);
1021 TestTwoClassProps(@InitTwoClassesWithDoubleLink);
1022 TestTwoClassProps(@InitTwoClassesAnchestor);
1023 TestTwoClassProps(@InitTwoClassesAnchestorWithAnchestorProp);
1024 TestTwoClassProps(@InitTwoClassesAnchestorWithAnchestorPropOneWay, True);
1025
1026 TestThreeClassProps(@InitThreeClasses);
1027 TestThreeClassProps(@InitThreeClassesWithOneSelfRef);
1028 TestThreeClassProps(@InitThreeClassesWithOneDoubleLink);
1029 TestThreeClassProps(@InitThreeClassesWithSubLoop);
1030 TestThreeClassProps(@InitThreeClassesWithSubLoopAndOneSelfRef);
1031 TestThreeClassProps(@InitThreeClassesWithTwoSubLoop);
1032 TestThreeClassProps(@InitThreeClassesChained);
1033 TestThreeClassProps(@InitThreeClassesChainedIndirect);
1034 TestThreeClassProps(@InitThreeClassesOneAnchestor);
1035 TestThreeClassProps(@InitThreeClassesOneAnchestorIndirect);
1036 TestThreeClassProps(@InitThreeClassesAnchestorParallel);
1037 TestThreeClassProps(@InitThreeClassesAnchestorParallelIndirect); // 5 classes
1038 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRef);
1039 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRefIndirect);
1040 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRefIndirect_2);
1041 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoop);
1042 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoopIndirect);
1043 TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoopIndirect_2);
1044 TestThreeClassProps(@InitThreeClassesTwoAnchestor);
1045 TestThreeClassProps(@InitThreeClassesTwoAnchestorIndirect);
1046 end;
1047
1048 procedure TJitClassTest.TestManagedJitProp;
1049 var
1050 JitCreator: TJitClassCreator;
1051 JitClass: TComponentClass;
1052 JitObject: TComponent;
1053 a: ansistring;
1054 MemUsedBeforeCreate, MemUsedAfterCreate, MemUsedTmp: Integer;
1055 begin
1056 a := '';
1057 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitClass', 'foo');
1058 JitCreator.JitProperties.Add('JitString', 'AnsiString');
1059 JitClass := TComponentClass(JitCreator.JitClass);
1060
1061 MemUsedBeforeCreate := GetMemUsed;
1062 JitObject := JitClass.Create(nil);
1063 JitObject.Destroy;
1064 AssertEquals('Memory for object released', MemUsedBeforeCreate, GetMemUsed);
1065
1066
1067 MemUsedBeforeCreate := GetMemUsed;
1068 JitObject := JitClass.Create(nil);
1069 MemUsedAfterCreate := GetMemUsed;
1070
1071 MemUsedTmp := GetMemUsed;
1072 SetStrProp(JitObject, 'JitString', a);
1073 AssertEquals('No Memory used by setting empty string', MemUsedTmp, GetMemUsed);
1074
1075 SetLength(a, 100);
1076
1077 MemUsedTmp := GetMemUsed;
1078 SetStrProp(JitObject, 'JitString', a);
1079 AssertEquals('No Memory used by setting string with data', MemUsedTmp, GetMemUsed);
1080
1081 MemUsedTmp := GetMemUsed;
1082 a := '';
1083 AssertEquals('Memory for string hold by jitprop', MemUsedTmp, GetMemUsed);
1084
1085 SetStrProp(JitObject, 'JitString', a); // empty again
1086 AssertEquals('Memory for string hold by jitprop freed (set to empty)', MemUsedAfterCreate, GetMemUsed);
1087
1088
1089 SetLength(a, 100);
1090 MemUsedTmp := GetMemUsed;
1091 SetStrProp(JitObject, 'JitString', a);
1092 a := '';
1093 AssertEquals('Memory for string hold by jitprop (2)', MemUsedTmp, GetMemUsed);
1094
1095
1096 JitObject.Destroy;
1097 AssertEquals('Memory for string released', MemUsedBeforeCreate, GetMemUsed);
1098
1099 JitCreator.Free;
1100 end;
1101
1102 procedure TJitClassTest.TestRefCount;
1103 var
1104 JitTypeLib: TJitTypeLibrary;
1105 MyEnLock, OthEnLock, MySetLock: TRefCountedJitReference;
1106 MyEn, OthEn, MySet: TJitType;
1107 MyEnInfo, OthEnInfo, MySetInfo: PTypeInfo;
1108 begin
1109 JitTypeLib := TJitTypeLibrary.Create;
1110 MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)');
1111 OthEn := JitTypeLib.AddType('OtherEnum', '(o1, o2, o3, o4, o5)');
1112
1113 // Get Locks
1114 MyEnLock := MyEn.LockReference;
1115 OthEnLock := OthEn.LockReference;
1116 AssertEquals('LockCount for MyEnum (used by set)', 2, MyEnLock.RefCount);
1117 AssertEquals('LockCount for OtherEnum', 2, OthEnLock.RefCount);
1118
1119 // Get Lock for MySet => No TypeInfo call yet => no lock to nested MyEnum
1120 MySet := JitTypeLib.AddType('MySet', 'set of MyEnum');
1121 MySetLock := MySet.LockReference;
1122 AssertEquals('LockCount for MySet', 2, MySetLock.RefCount);
1123 AssertEquals('LockCount for MyEnum 2', 2, MyEnLock.RefCount);
1124 AssertEquals('LockCount for OtherEnum 2', 2, OthEnLock.RefCount);
1125
1126 // Watch when Objects are freed
1127 MyEn.AddFreeNotification(@DoObjFreed);
1128 OthEn.AddFreeNotification(@DoObjFreed);
1129 MySet.AddFreeNotification(@DoObjFreed);
1130
1131 // Access MySet TypeInfo => MySet will need MyEnum
1132 MySetInfo := MySet.TypeInfo;
1133 AssertEquals('LockCount for MyEn used', 3, MyEnLock.RefCount);
1134 AssertEquals('LockCount for OthEn not parsed', 2, OthEnLock.RefCount);
1135 AssertEquals('LockCount for MySet parsed', 2, MySetLock.RefCount);
1136
1137 // Get all TypeInfo => start monitoring FreeMem calls
1138 MyEnInfo := MyEn.TypeInfo;
1139 OthEnInfo := OthEn.TypeInfo;
1140
1141 StartMemMonitor;
1142 AssertEquals('LockCount for MyEn parsed', 3, MyEnLock.RefCount);
1143 AssertEquals('LockCount for OthEn parsed', 2, OthEnLock.RefCount);
1144
1145 // Still the same ref object? The increase by LockReference, should be visible in the earlier ref
1146 MyEn.LockReference;
1147 AssertEquals('LockCount for MyEn locked 2', 4, MyEnLock.RefCount);
1148 OthEn.LockReference;
1149 AssertEquals('LockCount for OthEn locked 2', 3, OthEnLock.RefCount);
1150 MySet.LockReference;
1151 AssertEquals('LockCount for MySet locked 2', 3, MySetLock.RefCount);
1152
1153 // Free the lib => JitType objects should be freed too
1154 AssertWasNotObjFreed('', MySet);
1155 AssertWasNotObjFreed('', MyEn);
1156 AssertWasNotObjFreed('', OthEn);
1157
1158 JitTypeLib.Free;
1159 AssertWasObjFreed('', MySet);
1160 AssertWasObjFreed('', MyEn);
1161 AssertWasObjFreed('', OthEn);
1162 // LockCounts went down by one (no longer locked by the JitType object
1163 AssertEquals('LockCount for MyEn kept', 3, MyEnLock.RefCount);
1164 AssertEquals('LockCount for OthEn kept', 2, OthEnLock.RefCount);
1165 AssertEquals('LockCount for MySet kept', 2, MySetLock.RefCount);
1166
1167 // Release MySet, which gives up one ref to MyEnum
1168 MySetLock.ReleaseLock;
1169 AssertWasNotMemFreed('', MySetInfo);
1170 // Check FreeMem(TypeInfo) for MySet
1171 MySetLock.ReleaseLock;
1172 AssertWasMemFreed('', MySetInfo);
1173
1174 AssertEquals('LockCount for MyEn kept', 2, MyEnLock.RefCount);
1175 AssertEquals('LockCount for OthEn kept', 2, OthEnLock.RefCount);
1176
1177 MyEnLock.ReleaseLock;
1178 OthEnLock.ReleaseLock;
1179 AssertWasNotMemFreed('', MyEnInfo);
1180 AssertWasNotMemFreed('', OthEnInfo);
1181
1182 // Check FreeMem(TypeInfo)
1183 MyEnLock.ReleaseLock;
1184 OthEnLock.ReleaseLock;
1185 AssertWasMemFreed('', MyEnInfo);
1186 AssertWasMemFreed('', OthEnInfo);
1187
1188 ////////////////////////
1189 // Test Mem without external lock
1190 StartAndClearMemMonitor;
1191 JitTypeLib := TJitTypeLibrary.Create;
1192 MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)');
1193 MyEnInfo := MyEn.TypeInfo;
1194 StartAndClearMemMonitor;
1195
1196 AssertWasNotMemFreed('', MyEnInfo);
1197 JitTypeLib.Free;
1198 AssertWasMemFreed('', MyEnInfo);
1199
1200
1201 StopMemMonitor;
1202 StartAndClearMemMonitor;
1203 end;
1204
1205 procedure TJitClassTest.TestRefCountProp;
1206 var
1207 JitCreator: TJitClassCreator;
1208 JitTypeLib: TJitTypeLibrary;
1209 MyEnLock, ClassLock: TRefCountedJitReference;
1210 MyEn: TJitType;
1211 MyEnInfo: PTypeInfo;
1212 begin
1213 JitTypeLib := TJitTypeLibrary.Create;
1214 MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)');
1215 MyEnInfo := MyEn.TypeInfo;
1216 StartMemMonitor;
1217
1218 MyEnLock := MyEn.LockReference;
1219 AssertEquals('LockCount for MyEnum after typeinfo', 2, MyEnLock.RefCount);
1220
1221
1222 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas');
1223 JitCreator.TypeLibrary := JitTypeLib;
1224 JitCreator.JitProperties.Add('a', 'MyEnum');
1225 JitCreator.JitClass;
1226
1227 AssertEquals('LockCount for MyEnum after jitclass', 3, MyEnLock.RefCount);
1228
1229 JitTypeLib.Free;
1230 AssertEquals('LockCount for MyEnum after typelib free', 2, MyEnLock.RefCount);
1231
1232 JitCreator.Free;
1233 AssertEquals('LockCount for MyEnum after creator free', 1, MyEnLock.RefCount);
1234
1235 AssertWasNotMemFreed('', MyEnInfo);
1236 MyEnLock.ReleaseLock;
1237 AssertWasMemFreed('', MyEnInfo);
1238
1239
1240 ///////////////
1241 // Add as property
1242 // hold creator by lock
1243 JitTypeLib := TJitTypeLibrary.Create;
1244 MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)');
1245 MyEnInfo := MyEn.TypeInfo;
1246 StartAndClearMemMonitor;
1247
1248 MyEnLock := MyEn.LockReference;
1249 AssertEquals('LockCount for MyEnum after typeinfo', 2, MyEnLock.RefCount);
1250
1251
1252 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas');
1253 JitCreator.TypeLibrary := JitTypeLib;
1254 JitCreator.JitProperties.Add('a', 'MyEnum');
1255 ClassLock := JitCreator.LockReference;
1256 AssertEquals('LockCount for class ', 2, ClassLock.RefCount);
1257
1258 JitCreator.JitClass;
1259 AssertEquals('LockCount for MyEnum after jitclass', 3, MyEnLock.RefCount);
1260
1261 JitTypeLib.Free;
1262 AssertEquals('LockCount for MyEnum after typelib free', 2, MyEnLock.RefCount);
1263
1264 JitCreator.Free;
1265 AssertEquals('LockCount for MyEnum after creator free (locked)', 2, MyEnLock.RefCount);
1266 AssertEquals('LockCount for class after creator free', 1, ClassLock.RefCount);
1267
1268 ClassLock.ReleaseLock;
1269 AssertEquals('LockCount for MyEnum after creator free (unlocked)', 1, MyEnLock.RefCount);
1270
1271 AssertWasNotMemFreed('', MyEnInfo);
1272 MyEnLock.ReleaseLock;
1273 AssertWasMemFreed('', MyEnInfo);
1274 end;
1275
TJitClassTest.GetCreatornull1276 function TJitClassTest.GetCreator(ABase: TClass; AName: String; PropClass: String = ''; ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator;
1277 begin
1278 Result := TJitClassCreator.Create(ABase, AName, 'foo');
1279 Result.TypeLibrary := FJitTypeLib;
1280 if PropClass <> '' then
1281 Result.JitProperties.Add('a', PropClass);
1282 FJitTypeLib.AddJitClass(Result.JitClassName, Result, ATakeCreatorOwnerShip);
1283
1284 Result.JitProperties.Add('prop1', 'Int64');
1285 Result.JitProperties.Add('prop2', 'word');
1286 Result.JitProperties.Add('prop3', 'Int64');
1287 end;
1288
TJitClassTest.GetCreatornull1289 function TJitClassTest.GetCreator(ABase: TJitClassCreator; AName: String;
1290 PropClass: String; ATakeCreatorOwnerShip: Boolean): TJitClassCreator;
1291 begin
1292 Result := TJitClassCreator.Create(ABase, AName, 'foo');
1293 Result.TypeLibrary := FJitTypeLib;
1294 if PropClass <> '' then
1295 Result.JitProperties.Add('b', PropClass);
1296 FJitTypeLib.AddJitClass(Result.JitClassName, Result, ATakeCreatorOwnerShip);
1297
1298 Result.JitProperties.Add('bprop1', 'Int64');
1299 Result.JitProperties.Add('bprop2', 'Int64');
1300 Result.JitProperties.Add('prop1', 'boolean'); // replace prop
1301 end;
1302
1303 procedure TJitClassTest.InitTwoClasses;
1304 begin
1305 FJitTypeLib := TJitTypeLibrary.Create;
1306 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1307 FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne');
1308 end;
1309
1310 procedure TJitClassTest.InitTwoClassesWithOneSelfRef;
1311 begin
1312 (* One -> Two
1313 One -> One
1314 Two -> One
1315 *)
1316 InitTwoClasses;
1317 FJitCreator[1].JitProperties.Add('b', 'TMyClassOne'); // self ref
1318 end;
1319
1320 procedure TJitClassTest.InitTwoClassesWithDoubleLink;
1321 begin
1322 (* One -> Two
1323 One -> Two (2nd property)
1324 Two -> One
1325 *)
1326 InitTwoClasses;
1327 FJitCreator[1].JitProperties.Add('b', 'TMyClassTwo'); // 2nd prop to TMyClassTwo;
1328 end;
1329
1330 procedure TJitClassTest.InitTwoClassesAnchestor;
1331 begin
1332 (* One -> Two
1333 Two >> One (inherits)
1334 *)
1335 (* Anchestor Class, has child-class as property *)
1336 FJitTypeLib := TJitTypeLibrary.Create;
1337 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1338 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1339 end;
1340
1341 procedure TJitClassTest.InitTwoClassesAnchestorWithAnchestorProp;
1342 begin
1343 (* One -> Two
1344 Two >> One (inherits)
1345 Two -> One (prop)
1346 *)
1347 (* Anchestor Class, has child-class as property
1348 AND Child has anchestor as prop
1349 *)
1350 FJitTypeLib := TJitTypeLibrary.Create;
1351 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1352 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1353 FJitCreator[2].JitProperties.Add('par', 'TMyClassOne');
1354 end;
1355 procedure TJitClassTest.InitTwoClassesAnchestorWithAnchestorPropOneWay;
1356 begin
1357 // NOT a circle
1358 (* Two >> One (inherits)
1359 Two -> One (prop)
1360 *)
1361 (* Child Class, has anchestor-class as property / not a circle *)
1362 FJitTypeLib := TJitTypeLibrary.Create;
1363 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne'); // anchestor does NOT refer to the child
1364 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1365 FJitCreator[2].JitProperties.Add('par', 'TMyClassOne');
1366 end;
1367 procedure TJitClassTest.InitThreeClasses;
1368 begin
1369 (* One -> Two
1370 Two -> Three
1371 Three -> One
1372 *)
1373 FJitTypeLib := TJitTypeLibrary.Create;
1374 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1375 FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassThree');
1376 FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne');
1377 end;
1378
1379 procedure TJitClassTest.InitThreeClassesWithOneSelfRef;
1380 begin
1381 (* One -> Two
1382 One -> One
1383 Two -> Three
1384 Three -> One
1385 *)
1386 InitThreeClasses;
1387 FJitCreator[1].JitProperties.Add('c', 'TMyClassOne');
1388 end;
1389
1390 procedure TJitClassTest.InitThreeClassesWithOneDoubleLink;
1391 begin
1392 (* One -> Two
1393 One -> Two (2nd prop)
1394 Two -> Three
1395 Three -> One
1396 *)
1397 InitThreeClasses;
1398 FJitCreator[1].JitProperties.Add('c', 'TMyClassTwo');
1399 end;
1400
1401 procedure TJitClassTest.InitThreeClassesWithSubLoop;
1402 begin
1403 (* One -> Two
1404 One -> Three
1405 Two -> Three
1406 Three -> One
1407 *)
1408 InitThreeClasses;
1409 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1410 end;
1411
1412 procedure TJitClassTest.InitThreeClassesWithSubLoopAndOneSelfRef;
1413 begin
1414 (* One -> Two
1415 One -> One
1416 One -> Three
1417 Two -> Three
1418 Three -> One
1419 *)
1420 InitThreeClasses;
1421 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1422 FJitCreator[1].JitProperties.Add('c', 'TMyClassOne');
1423 end;
1424
1425 procedure TJitClassTest.InitThreeClassesWithTwoSubLoop;
1426 begin
1427 (* One -> Two
1428 One -> Three
1429 Two -> Three
1430 Three -> One
1431 Three -> One (2nd prop)
1432 *)
1433 InitThreeClasses;
1434 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1435 FJitCreator[3].JitProperties.Add('c', 'TMyClassOne');
1436 end;
1437
1438 procedure TJitClassTest.InitThreeClassesChained;
1439 begin
1440 // 2 separate loops / only ONE is in both loops
1441 (* One -> Two
1442 One -> Three
1443 Two -> One
1444 Three -> One
1445 *)
1446 // FJitCreator[1] will be in 2 circles: One with FJitCreator[2] / the other one with FJitCreator[3]
1447 // FJitCreator[2] and FJitCreator[3] are anly connected to FJitCreator[1]
1448 FJitTypeLib := TJitTypeLibrary.Create;
1449 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1450 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1451 FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne');
1452 FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne');
1453 end;
1454
1455 procedure TJitClassTest.InitThreeClassesChainedIndirect;
1456 begin
1457 // 2 separate loops / only ONE is in both loops
1458 (* One -> TwoHolder -> Two
1459 One -> ThreeHolder -> Three
1460 Two -> One
1461 Three -> One
1462 *)
1463 // FJitCreator[1] will be in 2 circles: One with FJitCreator[2] / the other one with FJitCreator[3]
1464 // FJitCreator[2] and FJitCreator[3] are anly connected to FJitCreator[1]
1465 FJitTypeLib := TJitTypeLibrary.Create;
1466 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1467 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1468
1469 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1470 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1471
1472 FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne');
1473 FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne');
1474
1475 end;
1476
1477 procedure TJitClassTest.InitThreeClassesOneAnchestor;
1478 begin
1479 (* One -> Three
1480 Three -> Two
1481 Two >> One (inherits)
1482 *)
1483 (* Anchestor Class, has child-class via 3rd obj as property *)
1484 FJitTypeLib := TJitTypeLibrary.Create;
1485 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThree');
1486 FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassTwo');
1487 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1488 end;
1489
1490 procedure TJitClassTest.InitThreeClassesOneAnchestorIndirect;
1491 begin
1492 (* One -> ThreeHolder -> Three
1493 Three -> TwoHolder -> Two
1494 Two >> One (inherits)
1495 *)
1496 (* Anchestor Class, has child-class via 3rd obj as property *)
1497 FJitTypeLib := TJitTypeLibrary.Create;
1498 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThreeHolder');
1499
1500 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1501 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1502
1503 FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassTwoHolder');
1504 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1505 end;
1506
1507 procedure TJitClassTest.InitThreeClassesAnchestorParallel;
1508 begin
1509 // 2 separate loops / only ONE is in both loops
1510 (* One -> Two
1511 One -> Three
1512 Two >> One (inherits)
1513 Three >> One (inherits)
1514 *)
1515 (* Anchestor Class, has TWO child-classes, BOTH as property *)
1516 FJitTypeLib := TJitTypeLibrary.Create;
1517 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1518 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1519
1520 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1521 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree');
1522 end;
1523
1524 procedure TJitClassTest.InitThreeClassesAnchestorParallelIndirect;
1525 begin
1526 // 2 separate loops / only ONE is in both loops
1527 (* One -> TwoHolder -> Two
1528 One -> ThreeHolder -> Three
1529 Two >> One (inherits)
1530 Three >> One (inherits)
1531 *)
1532 (* Anchestor Class, has TWO child-classes,
1533 BOTH as property via indirection
1534 *)
1535 FJitTypeLib := TJitTypeLibrary.Create;
1536 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1537 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1538
1539 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1540 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1541
1542 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo');
1543 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree');
1544 end;
1545
1546 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRef;
1547 begin
1548 (* One -> Two
1549 One -> Three
1550 Two >> One (inherits)
1551 Two -> Three
1552 Three >> One (inherits)
1553 *)
1554 (* Anchestor Class, has TWO child-classes, BOTH as property
1555 One child has the other child as prop
1556 *)
1557 FJitTypeLib := TJitTypeLibrary.Create;
1558 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1559 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1560
1561 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThree');
1562 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree');
1563 end;
1564
1565 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRefIndirect;
1566 begin
1567 (* One -> TwoHolder -> Two
1568 One -> ThreeHolder -> Three
1569 Two >> One (inherits)
1570 Two -> ThreeHolder -> Three
1571 Three >> One (inherits)
1572 *)
1573 (* Anchestor Class, has TWO child-classes, BOTH as property
1574 One child has the other child as prop
1575 *)
1576 FJitTypeLib := TJitTypeLibrary.Create;
1577 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1578 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1579
1580 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1581 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1582
1583 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder');
1584 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree');
1585 end;
1586
1587 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRefIndirect_2;
1588 begin
1589 (* One -> TwoHolder -> Two
1590 One -> ThreeHolder -> Three
1591 Two >> One (inherits)
1592 Two -> ThreeHolder_2 -> Three // use different holder
1593 Three >> One (inherits)
1594 *)
1595 (* Anchestor Class, has TWO child-classes, BOTH as property
1596 One child has the other child as prop
1597 *)
1598 FJitTypeLib := TJitTypeLibrary.Create;
1599 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1600 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1601
1602 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1603 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1604 GetCreator(TMyClass, 'TMyClassThreeHolder_2', 'TMyClassThree', True);
1605
1606 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder_2');
1607 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree');
1608 end;
1609
1610 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoop;
1611 begin
1612 // 3 circles
1613 (* One -> Two
1614 One -> Three
1615 Two >> One (inherits)
1616 Two -> Three
1617 Three >> One (inherits)
1618 Three -> Two
1619 *)
1620 (* Anchestor Class, has TWO child-classes, BOTH as property
1621 Bothe children has the other child as prop (loop)
1622 *)
1623 FJitTypeLib := TJitTypeLibrary.Create;
1624 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo');
1625 FJitCreator[1].JitProperties.Add('b', 'TMyClassThree');
1626
1627 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThree');
1628 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwo');
1629 end;
1630
1631 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoopIndirect;
1632 begin
1633 // 3 circles
1634 (* One -> TwoHolder -> Two
1635 One -> ThreeHolder -> Three
1636 Two >> One (inherits)
1637 Two -> ThreeHolder -> Three
1638 Three >> One (inherits)
1639 Three -> TwoHolder -> Two
1640 *)
1641 (* Anchestor Class, has TWO child-classes, BOTH as property
1642 Bothe children has the other child as prop (loop)
1643 *)
1644 FJitTypeLib := TJitTypeLibrary.Create;
1645 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1646 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1647
1648 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1649 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1650
1651 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder');
1652 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwoHolder');
1653 end;
1654
1655 procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoopIndirect_2;
1656 begin
1657 // 3 circles
1658 (* One -> TwoHolder -> Two
1659 One -> ThreeHolder -> Three
1660 Two >> One (inherits)
1661 Two -> ThreeHolder_2 -> Three
1662 Three >> One (inherits)
1663 Three -> TwoHolder_2 -> Two
1664 *)
1665 (* Anchestor Class, has TWO child-classes, BOTH as property
1666 Bothe children has the other child as prop (loop)
1667 *)
1668 FJitTypeLib := TJitTypeLibrary.Create;
1669 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder');
1670 FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder');
1671
1672 GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True);
1673 GetCreator(TMyClass, 'TMyClassTwoHolder_2', 'TMyClassTwo', True);
1674 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1675 GetCreator(TMyClass, 'TMyClassThreeHolder_2', 'TMyClassThree', True);
1676
1677 FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder_2');
1678 FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwoHolder_2');
1679 end;
1680
1681 procedure TJitClassTest.InitThreeClassesTwoAnchestor;
1682 begin
1683 (* One -> Three
1684 Two >> One (inherits)
1685 Three >> Two (inherits)
1686 *)
1687 (* Class, has grand child-class that has property to orig class *)
1688 FJitTypeLib := TJitTypeLibrary.Create;
1689 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThree');
1690
1691 // inherit TMyClassOne
1692 FJitCreator[2] := TJitClassCreator.Create(FJitCreator[1], 'TMyClassTwo', 'foo');
1693 FJitCreator[2].TypeLibrary := FJitTypeLib;
1694 FJitTypeLib.AddJitClass(FJitCreator[2].JitClassName, FJitCreator[2]);
1695
1696 // inherit TMyClassTwo;
1697 FJitCreator[3] := GetCreator(FJitCreator[2], 'TMyClassThree');
1698 end;
1699
1700 procedure TJitClassTest.InitThreeClassesTwoAnchestorIndirect;
1701 begin
1702 (* One -> ThreeHolder -> Three
1703 Two >> One (inherits)
1704 Three >> Two (inherits)
1705 *)
1706 (* Class, has grand child-class that has property to orig class *)
1707 FJitTypeLib := TJitTypeLibrary.Create;
1708 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThreeHolder');
1709
1710 GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True);
1711
1712 // inherit TMyClassOne
1713 FJitCreator[2] := TJitClassCreator.Create(FJitCreator[1], 'TMyClassTwo', 'foo');
1714 FJitCreator[2].TypeLibrary := FJitTypeLib;
1715 FJitTypeLib.AddJitClass(FJitCreator[2].JitClassName, FJitCreator[2]);
1716
1717 // inherit TMyClassTwo;
1718 FJitCreator[3] := GetCreator(FJitCreator[2], 'TMyClassThree');
1719 end;
1720
1721 procedure TJitClassTest.TestTwoClassRefCount(
1722 AnInitProc: TInitProcedure);
1723 var
1724 i, j, MemUsed: Integer;
1725 JitClassOneInfo, JitClassTwoInfo: PTypeInfo;
1726 jc: TJitClassCreator;
1727 begin
1728 for i := 1 to 2 do for j := 1 to 2 do begin
1729 AnInitProc();
1730
1731 case i of // which class to access first
1732 1: JitClassOneInfo := FJitCreator[1].TypeInfo;
1733 2: JitClassTwoInfo := FJitCreator[2].TypeInfo;
1734 end;
1735 JitClassOneInfo := FJitCreator[1].TypeInfo; // access the other / double access to the first does not matter
1736 JitClassTwoInfo := FJitCreator[2].TypeInfo;
1737 StartAndClearMemMonitor;
1738
1739 FJitTypeLib.Free;
1740 case j of // which class to destroy first
1741 1: FreeAndNil(FJitCreator[1]);
1742 2: FreeAndNil(FJitCreator[2]);
1743 end;
1744
1745 AssertWasNotMemFreed('', JitClassOneInfo);
1746 AssertWasNotMemFreed('', JitClassTwoInfo);
1747 FreeAndNil(FJitCreator[1]);
1748 FreeAndNil(FJitCreator[2]);
1749 AssertWasMemFreed('', JitClassOneInfo);
1750 AssertWasMemFreed('', JitClassTwoInfo);
1751 end;
1752
1753 // only access one typeinfo
1754 StopMemMonitor;
1755 for i := 1 to 2 do for j := 1 to 2 do begin
1756 MemUsed := GetMemUsed;
1757
1758 AnInitProc();
1759 case i of // which class to access first
1760 1: jc := FJitCreator[1];
1761 2: jc := FJitCreator[2];
1762 end;
1763 JitClassOneInfo := jc.TypeInfo;
1764
1765 FJitTypeLib.Free;
1766 case j of // which class to destroy first
1767 1: FreeAndNil(FJitCreator[1]);
1768 2: FreeAndNil(FJitCreator[2]);
1769 end;
1770 FreeAndNil(FJitCreator[1]);
1771 FreeAndNil(FJitCreator[2]);
1772
1773 AssertEquals('mem used ', MemUsed, GetMemUsed);
1774 end;
1775
1776 end;
1777
1778 procedure TJitClassTest.TestThreeClassRefCount(AnInitProc: TInitProcedure);
1779 var
1780 i, j, k, MemUsed: Integer;
1781 JitClassOneInfo, JitClassTwoInfo, JitClassThreeInfo: PTypeInfo;
1782 LastToFree, jc: TJitClassCreator;
1783 begin
1784 for i := 1 to 3 do for j := 1 to 3 do for k := 1 to 3 do begin
1785 AnInitProc();
1786 case i of // which class to access first
1787 1: JitClassOneInfo := FJitCreator[1].TypeInfo;
1788 2: JitClassTwoInfo := FJitCreator[2].TypeInfo;
1789 3: JitClassThreeInfo := FJitCreator[3].TypeInfo;
1790 end;
1791 JitClassOneInfo := FJitCreator[1].TypeInfo;
1792 JitClassTwoInfo := FJitCreator[2].TypeInfo;
1793 JitClassThreeInfo := FJitCreator[3].TypeInfo;
1794 StartAndClearMemMonitor;
1795 FJitTypeLib.Free;
1796 case j of // which class to destroy last
1797 1: begin LastToFree := FJitCreator[1]; FJitCreator[1] := nil; end;
1798 2: begin LastToFree := FJitCreator[2]; FJitCreator[2] := nil; end;
1799 3: begin LastToFree := FJitCreator[3]; FJitCreator[3] := nil; end;
1800 end;
1801 case k of // which class to destroy first
1802 1: FreeAndNil(FJitCreator[1]);
1803 2: FreeAndNil(FJitCreator[2]);
1804 3: FreeAndNil(FJitCreator[3]);
1805 end;
1806 FJitCreator[1].Free;
1807 FJitCreator[2].Free;
1808 FJitCreator[3].Free;
1809
1810 AssertWasNotMemFreed('', JitClassOneInfo);
1811 AssertWasNotMemFreed('', JitClassTwoInfo);
1812 AssertWasNotMemFreed('', JitClassThreeInfo);
1813 LastToFree.Free;
1814 AssertWasMemFreed('', JitClassOneInfo);
1815 AssertWasMemFreed('', JitClassTwoInfo);
1816 AssertWasMemFreed('', JitClassThreeInfo);
1817 end;
1818
1819
1820 // only access one typeinfo
1821 StopMemMonitor;
1822 for i := 1 to 3 do for j := 1 to 3 do for k := 1 to 3 do begin
1823 MemUsed := GetMemUsed;
1824
1825 AnInitProc();
1826 case i of // which class to access first
1827 1: jc := FJitCreator[1];
1828 2: jc := FJitCreator[2];
1829 3: jc := FJitCreator[3];
1830 end;
1831 JitClassOneInfo := jc.TypeInfo;
1832
1833 FJitTypeLib.Free;
1834 case j of // which class to destroy last
1835 1: FreeAndNil(FJitCreator[1]);
1836 2: FreeAndNil(FJitCreator[2]);
1837 3: FreeAndNil(FJitCreator[3]);
1838 end;
1839 case k of // which class to destroy first
1840 1: FreeAndNil(FJitCreator[1]);
1841 2: FreeAndNil(FJitCreator[2]);
1842 3: FreeAndNil(FJitCreator[3]);
1843 end;
1844 FJitCreator[1].Free;
1845 FJitCreator[2].Free;
1846 FJitCreator[3].Free;
1847
1848 AssertEquals('mem used ', MemUsed, GetMemUsed);
1849 end;
1850 end;
1851
1852
1853 procedure TJitClassTest.TestRefCountClassCircle;
1854 var
1855 JitClassOneInfo, JitClassTwoInfo, JitClassThreeInfo: PTypeInfo;
1856 begin
1857 //////////////////////////////////
1858 // 1 classes circle
1859 FJitTypeLib := TJitTypeLibrary.Create;
1860 FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassOne');
1861 JitClassOneInfo := FJitCreator[1].TypeInfo;
1862 StartMemMonitor;
1863
1864 FJitTypeLib.Free;
1865
1866 AssertWasNotMemFreed('', JitClassOneInfo);
1867 FJitCreator[1].Free;
1868 AssertWasMemFreed('', JitClassOneInfo);
1869
1870 TestTwoClassRefCount(@InitTwoClasses);
1871 TestTwoClassRefCount(@InitTwoClassesWithOneSelfRef);
1872 TestTwoClassRefCount(@InitTwoClassesWithDoubleLink);
1873 TestTwoClassRefCount(@InitTwoClassesAnchestor);
1874 TestTwoClassRefCount(@InitTwoClassesAnchestorWithAnchestorProp);
1875
1876 TestThreeClassRefCount(@InitThreeClasses);
1877 TestThreeClassRefCount(@InitThreeClassesWithOneSelfRef);
1878 TestThreeClassRefCount(@InitThreeClassesWithOneDoubleLink);
1879 TestThreeClassRefCount(@InitThreeClassesWithSubLoop);
1880 TestThreeClassRefCount(@InitThreeClassesWithSubLoopAndOneSelfRef);
1881 TestThreeClassRefCount(@InitThreeClassesWithTwoSubLoop);
1882 TestThreeClassRefCount(@InitThreeClassesChained);
1883 TestThreeClassRefCount(@InitThreeClassesChainedIndirect);
1884 TestThreeClassRefCount(@InitThreeClassesOneAnchestor);
1885 TestThreeClassRefCount(@InitThreeClassesOneAnchestorIndirect);
1886 TestThreeClassRefCount(@InitThreeClassesAnchestorParallel);
1887 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelIndirect); // 5 classes
1888 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRef);
1889 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRefIndirect);
1890 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRefIndirect_2);
1891 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoop);
1892 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoopIndirect);
1893 TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoopIndirect_2);
1894 TestThreeClassRefCount(@InitThreeClassesTwoAnchestor);
1895 TestThreeClassRefCount(@InitThreeClassesTwoAnchestorIndirect);
1896
1897 end;
1898
1899 procedure TJitClassTest.TestRefCountMethodCircle;
1900 var
1901 JitTypeLib: TJitTypeLibrary;
1902 MyProc: TJitType;
1903 MyProcInfo: PTypeInfo;
1904 begin
1905 JitTypeLib := TJitTypeLibrary.Create;
1906 MyProc := JitTypeLib.AddType('TMyProc', 'procedure (a: TMyProc)');
1907 MyProcInfo := MyProc.TypeInfo;
1908 StartMemMonitor;
1909
1910 AssertWasNotMemFreed('', MyProcInfo);
1911 JitTypeLib.Free;
1912 AssertWasMemFreed('', MyProcInfo);
1913
1914
1915 end;
1916
1917 procedure TJitClassTest.TestParseJitType;
1918 var
1919 JitCreator: TJitClassCreator;
1920 Cnt: Integer;
1921 JitTypeLib: TJitTypeLibrary;
1922 t: PTypeInfo;
1923
DoParseNoErrornull1924 function DoParseNoError(AName: String; ADecl: String): PTypeInfo;
1925 var
1926 jp: TJitProperty;
1927 begin
1928 AName := AName + ' ' + ADecl + ' ';
1929 inc(Cnt);
1930 try
1931 jp := JitCreator.JitProperties.Add('a'+IntToStr(Cnt), ADecl);
1932 Result := jp.TypeInfo;
1933 //AssertTrue(AName, jp.TypeInfo <> nil);
1934 except
1935 AssertTrue(AName + 'no except', False);
1936 end;
1937 end;
1938
ParseNoErrornull1939 function ParseNoError(AName: String; ADecl: String): PTypeInfo;
1940 var
1941 s: String;
1942 begin
1943 Result := DoParseNoError(AName, ADecl);
1944 DoParseNoError(AName+' IN record', 'record a: '+ADecl+' end');
1945 s := Trim(ADecl);
1946 if (s <> '') and (s[Length(s)] <> ';') then
1947 DoParseNoError(AName+' IN record ;', 'record a: '+ADecl+'; end');
1948 end;
1949
1950 procedure ParseExpectError(AName: String; ADecl: String);
1951 var
1952 jp: TJitProperty;
1953 t: Boolean;
1954 begin
1955 AName := AName + ' ' + ADecl + ' ';
1956 inc(Cnt);
1957 t := True;
1958 try
1959 jp := JitCreator.JitProperties.Add('a'+IntToStr(Cnt), ADecl);
1960 jp.TypeInfo;
1961 t := False; // should skipped by exception
1962 except
1963 on E: Exception do
1964 if not (e is JitTypeParserException) then
1965 t := False; // wrong exception type
1966 end;
1967 AssertTrue(AName, t); // should not reach if above fails
1968 end;
1969
1970
1971 begin
1972 Cnt := 0;
1973 JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'unitfoo');
1974 JitTypeLib := TJitTypeLibrary.Create;
1975 JitCreator.TypeLibrary := JitTypeLib;
1976
1977 JitTypeLib.AddAlias('integer', 'longint');
1978 JitTypeLib.AddAlias('int32', 'integer');
1979 JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)', 'unitfoo');
1980 JitTypeLib.AddType('OtherEnum', '(zo1, o2, zo3, o4, zo5)', 'abc');
1981 JitTypeLib.AddType('OtherEnum', '(o1, o2, o3, o4, o5)', 'unitfoo');
1982 JitTypeLib.AddType('OtherEnumX', '(xo1, o2, xo3, o4, xo5)', 'unitbar');
1983
1984 ParseExpectError('', 'string');
1985 ParseNoError('', 'string[1]');
1986
1987 JitTypeLib.AddAlias('string', 'AnsiString');
1988 ParseNoError('', 'longint');
1989 ParseNoError('', 'integer');
1990 ParseNoError('', 'int32');
1991 ParseNoError('', 'string');
1992 ParseNoError('', 'string[1]');
1993 ParseNoError('', 'string[255]');
1994 ParseNoError('', 'string[$FF]');
1995 ParseNoError('', 'string[%10]');
1996 ParseNoError('', 'string[&10]');
1997
1998 ParseNoError('', 'procedure');
1999 ParseNoError('', 'procedure()');
2000 ParseNoError('', 'procedure of object');
2001 ParseNoError('', 'procedure () of object');
2002
2003 ParseNoError('', 'function: int64 ');
2004 ParseNoError('', 'function(): int64');
2005 ParseNoError('', 'function: int64 of object');
2006 ParseNoError('', 'function(): int64 of object');
2007 ParseNoError('', 'function(): OtherEnum of object');
2008 ParseNoError('', 'function(): unitfoo.OtherEnum of object');
2009 ParseNoError('', 'function(): abc.OtherEnum of object');
2010
2011 ParseNoError('', 'function(a,b: MyEnum): int64 ');
2012 ParseNoError('', 'function(a,b: unitfoo.MyEnum): int64 ');
2013 ParseNoError('', 'function(a,b: word; c: boolean=true; const x): int64 ');
2014 ParseNoError('', 'function(a,b: word; c: boolean=true; const x; d,e: array of int64): int64 ');
2015
2016 ParseNoError('', 'record end;');
2017 ParseNoError('', 'record a,b: word end;');
2018 ParseNoError('', 'record a,b: word; end;');
2019 ParseNoError('', 'record a,b: word; c: procedure() end;');
2020 ParseNoError('', 'record a,b: word; c: procedure(); end;');
2021 ParseNoError('', 'record a,b: word; c: procedure(); x: record xx: boolean end; end;');
2022 ParseNoError('', 'record a,b: word; c: procedure(); x: record xx: boolean end end;');
2023 ParseNoError('', 'record b: MyEnum end;');
2024 ParseNoError('', 'record b: MyEnum; end;');
2025 ParseNoError('', 'record b: unitfoo.MyEnum end;');
2026 ParseNoError('', 'record b: unitfoo.MyEnum; end;');
2027
2028 ParseNoError('', '1..3');
2029 ParseNoError('', '''a''..''c''');
2030 ParseNoError('', 'e2..e3');
2031 ParseNoError('', 'MyEnum.e2..e3');
2032 ParseNoError('', 'e2..MyEnum.e3');
2033 ParseNoError('', 'MyEnum.e2..MyEnum.e3');
2034 ParseNoError('', 'MyEnum(e2)..MyEnum.e3');
2035 ParseNoError('', 'MyEnum.e2..MyEnum(e3)');
2036
2037 t := ParseNoError('', 'o2..o4');
2038 AssertEquals('has o3', GetEnumValue(t, 'o3'), 2);
2039 AssertEquals('has not xo3', GetEnumValue(t, 'xo3'), -1);
2040 AssertEquals('has not zo3', GetEnumValue(t, 'zo3'), -1);
2041
2042 ParseNoError('', 'unitbar.OtherEnumX.o2..unitbar.OtherEnumX(o4)');
2043 ParseNoError('', 'OtherEnumX.o2..OtherEnumX(o4)');
2044 ParseNoError('', 'OtherEnumX(o2)..OtherEnumX(o4)');
2045 ParseNoError('', 'OtherEnumX.o2..OtherEnumX.o4');
2046 t := ParseNoError('', 'OtherEnumX.o2..o4');
2047 AssertEquals('has xo3', GetEnumValue(t, 'xo3'), 2);
2048 AssertEquals('has not o3', GetEnumValue(t, 'o3'), -1);
2049 AssertEquals('has not zo3', GetEnumValue(t, 'zo3'), -1);
2050
2051 t := ParseNoError('', 'abc.OtherEnum.o2..o4');
2052 AssertEquals('has zo3', GetEnumValue(t, 'zo3'), 2);
2053 AssertEquals('has not o3', GetEnumValue(t, 'o3'), -1);
2054 AssertEquals('has not xo3', GetEnumValue(t, 'xo3'), -1);
2055
2056
2057 ParseNoError('', 'set of (a,b,c)');
2058 ParseNoError('', 'set of byte');
2059 ParseNoError('', 'set of 1..3');
2060 ParseNoError('', 'set of Byte(1)..Byte(3)');
2061 ParseNoError('', 'set of MyEnum');
2062 ParseNoError('', 'set of unitfoo.MyEnum');
2063 ParseNoError('', 'set of MyEnum(1)..e3');
2064 ParseNoError('', 'set of unitfoo.MyEnum(1)..e3');
2065 ParseNoError('', 'set of e2..e5'); // typelibrary with enum (en1..en7)
2066
2067 ParseNoError('', 'array of int64');
2068 ParseNoError('', 'array of array of int64');
2069 ParseNoError('', 'array of string');
2070 ParseNoError('', 'array of string[2]');
2071 ParseNoError('', 'array of record a: word; end;');
2072 ParseNoError('', 'array of record a: (b,c) end;');
2073 ParseNoError('', 'record a: array of string[2]; b: word; end;');
2074
2075
2076
2077 ParseExpectError('', 'foo');
2078 ParseExpectError('', 'procedure foo');
2079 ParseExpectError('', 'procedure: foo');
2080 ParseExpectError('', 'procedure of ');
2081 ParseExpectError('', 'procedure(a: foo)');
2082 ParseExpectError('', 'function:');
2083 ParseExpectError('', 'function: foo');
2084 ParseExpectError('', 'function(): unitbar.OtherEnum');
2085 ParseExpectError('', 'function: array of int64');
2086 ParseExpectError('', 'string[256]');
2087 ParseExpectError('', 'string[0]');
2088 ParseExpectError('', 'string[-1]');
2089 ParseExpectError('', 'OtherEnumX.o2..OtherEnum.o4');
2090 ParseExpectError('', 'abc.OtherEnumX.o2..unitfoo.OtherEnum.o4');
2091 ParseExpectError('', 'record b: unitbar.MyEnum; end;');
2092 ParseExpectError('', 'record b: what.MyEnum; end;');
2093
2094 //ParseExpectError('', 'set of o2..e5'); // typelibrary with enum (en1..en7)
2095
2096
2097 // TEST & escaping
2098 JitTypeLib.AddAlias('&function', 'integer');
2099
2100 ParseNoError('', '&Function');
2101 ParseNoError('', '&integer');
2102 ParseNoError('', '&longint');
2103 ParseExpectError('', 'Function');
2104 ParseExpectError('', '&foo');
2105
2106 JitCreator.Free;
2107 JitTypeLib.Free;
2108 end;
2109
2110 procedure TJitClassTest.TestSetEnum;
2111 procedure CheckEnum(TpInf: PTypeInfo; Names: array of string; UnitName: string; ExpMinVal: Integer = 0);
2112 var
2113 i: Integer;
2114 TpDat: PTypeData;
2115 MinVal: LongInt;
2116 begin
2117 AssertTrue('kind', TpInf^.Kind = tkEnumeration);
2118 TpDat := GetTypeData(TpInf);
2119 MinVal := TpDat^.MinValue;
2120 AssertEquals('minval', ExpMinVal, TpDat^.MinValue);
2121 AssertEquals('elem count', Length(Names), GetEnumNameCount(TpInf));
2122 AssertEquals('unitname', UnitName, GetEnumName(TpInf, Length(Names) + MinVal)); // unitname
2123 for i := 0 to length(Names) - 1 do begin
2124 AssertEquals('elem', Names[i], GetEnumName(TpInf, i+MinVal));
2125 AssertEquals('', i+MinVal, GetEnumValue(TpInf, Names[i]));
2126 end;
2127 //AssertEquals('bad val', -1, GetEnumValue(TpInf, UnitName));
2128 AssertEquals('bad val', -1, GetEnumValue(TpInf, 'nevereverusethis'));
2129 end;
2130 procedure CheckSet(TpInf: PTypeInfo; Names: array of string);
2131 var
2132 i: Integer;
2133 CT: PTypeInfo;
2134 MinVal: LongInt;
2135 begin
2136 AssertTrue('kind', TpInf^.Kind = tkSet);
2137 CT := GetTypeData(TpInf)^.CompType;
2138 MinVal := GetTypeData(CT)^.MinValue;
2139 for i := 0 to length(Names) - 1 do begin
2140 AssertEquals('elem', Names[i], SetToString(TpInf, 1 << (i+MinVal), False));
2141 end;
2142 end;
2143 var
2144 JitTypeLib: TJitTypeLibrary;
2145 jp, en1, en2: TJitType;
2146 ti, ti2: PTypeInfo;
2147 begin
2148 JitTypeLib := TJitTypeLibrary.Create;
2149
2150 jp := TJitTypeInfo.Create('x','(a,b,c)', 'unitfoo');
2151 ti := jp.TypeInfo;
2152 CheckEnum(ti, ['a', 'b', 'c'], 'unitfoo');
2153 jp.Free;
2154
2155 en1 := JitTypeLib.AddType('En1','(a,b,c,d,e)', 'unitfoo');
2156 ti := en1.TypeInfo;
2157 CheckEnum(ti, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2158
2159 en2 := JitTypeLib.AddType('En2','b..d', 'unitbar');
2160 ti := en2.TypeInfo;
2161 CheckEnum(ti, ['b', 'c', 'd'], 'unitbar', 1);
2162 ti2 := GetTypeData(ti)^.BaseType;
2163 AssertTrue('', ti2 = en1.TypeInfo);
2164 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2165
2166 jp := TJitTypeInfo.Create('x','en1.b..d', 'unitabc', JitTypeLib);
2167 ti := jp.TypeInfo;
2168 CheckEnum(ti, ['b', 'c', 'd'], 'unitabc', 1);
2169 ti2 := GetTypeData(ti)^.BaseType;
2170 AssertTrue('', ti2 = en1.TypeInfo);
2171 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2172 jp.Free;
2173
2174
2175
2176 jp := TJitTypeInfo.Create('x','set of (a,b,c)', 'unitfoo');
2177 ti := jp.TypeInfo;
2178 CheckSet(ti, ['a', 'b', 'c']);
2179 ti2 := GetTypeData(ti)^.CompType;
2180 CheckEnum(ti2, ['a', 'b', 'c'], 'unitfoo');
2181 jp.Free;
2182
2183 jp := TJitTypeInfo.Create('x','set of En1', 'unitsome', JitTypeLib);
2184 ti := jp.TypeInfo;
2185 CheckSet(ti, ['a', 'b', 'c', 'd', 'e']);
2186 ti2 := GetTypeData(ti)^.CompType;
2187 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2188 jp.Free;
2189
2190 jp := TJitTypeInfo.Create('x','set of En2', 'unitsome', JitTypeLib);
2191 ti := jp.TypeInfo;
2192 CheckSet(ti, ['b', 'c', 'd']);
2193 ti2 := GetTypeData(ti)^.CompType;
2194 CheckEnum(ti2, ['b', 'c', 'd'], 'unitbar', 1);
2195 ti2 := GetTypeData(ti2)^.BaseType;
2196 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2197 jp.Free;
2198
2199 jp := TJitTypeInfo.Create('x','set of EN1(b)..d', 'unitsome', JitTypeLib);
2200 ti := jp.TypeInfo;
2201 CheckSet(ti, ['b', 'c', 'd']);
2202 ti2 := GetTypeData(ti)^.CompType;
2203 CheckEnum(ti2, ['b', 'c', 'd'], 'unitsome', 1);
2204 ti2 := GetTypeData(ti2)^.BaseType;
2205 AssertTrue('', ti2 = en1.TypeInfo);
2206 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2207 jp.Free;
2208
2209 jp := TJitTypeInfo.Create('x','set of EN2(b)..d', 'unitother', JitTypeLib);
2210 ti := jp.TypeInfo;
2211 CheckSet(ti, ['b', 'c', 'd']);
2212 ti2 := GetTypeData(ti)^.CompType;
2213 CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1);
2214 ti2 := GetTypeData(ti2)^.BaseType;
2215 AssertTrue('', ti2 = en2.TypeInfo);
2216 jp.Free;
2217
2218
2219 jp := TJitTypeInfo.Create('x','set of EN1.b..d', 'unitsome', JitTypeLib);
2220 ti := jp.TypeInfo;
2221 CheckSet(ti, ['b', 'c', 'd']);
2222 ti2 := GetTypeData(ti)^.CompType;
2223 CheckEnum(ti2, ['b', 'c', 'd'], 'unitsome', 1);
2224 ti2 := GetTypeData(ti2)^.BaseType;
2225 AssertTrue('', ti2 = en1.TypeInfo);
2226 CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo');
2227 jp.Free;
2228
2229 jp := TJitTypeInfo.Create('x','set of EN2.b..d', 'unitother', JitTypeLib);
2230 ti := jp.TypeInfo;
2231 CheckSet(ti, ['b', 'c', 'd']);
2232 ti2 := GetTypeData(ti)^.CompType;
2233 CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1);
2234 ti2 := GetTypeData(ti2)^.BaseType;
2235 AssertTrue('', ti2 = en2.TypeInfo);
2236 jp.Free;
2237
2238 jp := TJitTypeInfo.Create('x','set of EN2.b..EN2.d', 'unitother', JitTypeLib);
2239 ti := jp.TypeInfo;
2240 CheckSet(ti, ['b', 'c', 'd']);
2241 ti2 := GetTypeData(ti)^.CompType;
2242 CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1);
2243 ti2 := GetTypeData(ti2)^.BaseType;
2244 AssertTrue('', ti2 = en2.TypeInfo);
2245 jp.Free;
2246
2247
2248
2249 JitTypeLib.Free;
2250 end;
2251
2252 procedure TJitClassTest.TestMethods;
2253 var
2254 JitTypeLib: TJitTypeLibrary;
2255
2256 procedure DoTest(Decl: String; ExpParam: array of string);
2257 var
2258 context: TRttiContext;
2259 jp: TJitTypeInfo;
2260 t: TRttiType;
2261 params: specialize TArray<TRttiParameter>;
2262 i: Integer;
2263 begin
2264 context := TRttiContext.Create;
2265 jp := TJitTypeInfo.Create('x', Decl, JitTypeLib);
2266 t := context.GetType(jp.TypeInfo);
2267
2268 AssertTrue(t <> nil);
2269 AssertTrue(t is TRttiInvokableType);
2270
2271 params := TRttiInvokableType(t).GetParameters;
2272 AssertEquals(Length(ExpParam), Length(params));
2273
2274 for i := 0 to Length(ExpParam) - 1 do begin
2275 //debugln(params[i].tostring);
2276 AssertEquals(LowerCase(ExpParam[i]), LowerCase(params[i].ToString));
2277 end;
2278 jp.Free;
2279 context.Free;
2280 end;
2281
2282 begin
2283 JitTypeLib := TJitTypeLibrary.Create;
2284 JitTypeLib.AddType('TEnum1', '(a,b,c)');
2285
2286 DoTest('function (const a: byte; b,c: word): boolean',
2287 ['const a: byte', 'b: word', 'c: word']
2288 );
2289 DoTest('function (const a: byte; var b,c: word): boolean of object',
2290 ['const a: byte', 'var b: word', 'var c: word']
2291 );
2292 DoTest('procedure (var a: TEnum1; b: array of Int64) of object',
2293 ['var a: TEnum1', {$IFDEF FooFIxed}'b: '+{$ENDIF}'array of Int64']
2294 );
2295
2296 JitTypeLib.Free;
2297 end;
2298
2299
2300
2301 initialization
2302
2303 RegisterTest(TJitClassTest);
2304
2305 GetMemoryManager(MMgr);
2306 OrigFreemem := MMgr.Freemem;
2307 OrigFreememSize := MMgr.FreememSize;
2308 MMgr.Freemem := @MyFreemem;
2309 MMgr.FreememSize := @MyFreememSize;
2310 SetMemoryManager(MMgr);
2311 end.
2312
2313