diff options
Diffstat (limited to 'packages/pastojs/tests')
| -rw-r--r-- | packages/pastojs/tests/tcgenerics.pas | 150 | ||||
| -rw-r--r-- | packages/pastojs/tests/tcmodules.pas | 75 |
2 files changed, 178 insertions, 47 deletions
diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index 1f486d4d9f..ff46fbe342 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -20,7 +20,7 @@ type Procedure TestGen_Record_ClassVarRecord_Program; Procedure TestGen_Record_ClassVarRecord_UnitImpl; Procedure TestGen_Record_RTTI_UnitImpl; - // ToDo: delay RTTI with anonymous array a:array of T, array[1..2] of T + procedure TestGen_Record_Delay_UsedByImplUses; // ToDo: type alias type as parameter, TBird = type word; // generic class @@ -62,6 +62,7 @@ type Procedure TestGen_CallUnitImplProc; Procedure TestGen_IntAssignTemplVar; Procedure TestGen_TypeCastDotField; + Procedure TestGen_Except; // generic helper procedure TestGen_HelperForArray; @@ -288,7 +289,9 @@ begin '}, []);'])); CheckSource('TestGen_Record_ClassVarRecord_UnitImpl', LinesToStr([ // statements - 'pas.UnitA.TAnt$G1.$initSpec();', + '$mod.$implcode = function () {', + ' pas.UnitA.TAnt$G1.$initSpec();', + '};', '']), LinesToStr([ // $mod.$main ''])); @@ -355,6 +358,53 @@ begin ''])); end; +procedure TTestGenerics.TestGen_Record_Delay_UsedByImplUses; +begin + WithTypeInfo:=true; + StartProgram(true,[supTObject]); + AddModuleWithIntfImplSrc('UnitA.pas', + LinesToStr([ + '{$modeswitch AdvancedRecords}', + 'type', + ' generic TBird<T> = record', + ' class var a: T;', + ' end;', + '']), + LinesToStr([ + ''])); + AddModuleWithIntfImplSrc('UnitB.pas', + LinesToStr([ + 'procedure Fly;', + '']), + LinesToStr([ + 'uses UnitA;', + 'type', + ' TFox = record', + ' B: word;', + ' end;', + 'procedure Fly;', + 'var Bird: specialize TBird<TFox>;', + 'begin', + ' if typeinfo(Bird)<>nil then ;', + ' Bird.a:=Bird.a;', + 'end;', + ''])); + Add([ + 'uses UnitB;', + 'begin', + ' Fly;']); + ConvertProgram; + CheckSource('TestGen_Record_Delay_UsedByImplUses', + LinesToStr([ // statements + '$mod.$implcode = function () {', + ' pas.UnitA.TBird$G1.$initSpec();', + '};', + '']), + LinesToStr([ // $mod.$main + 'pas.UnitB.Fly();' + ])); +end; + procedure TTestGenerics.TestGen_ClassEmpty; begin StartProgram(false); @@ -1201,7 +1251,9 @@ begin ''])); CheckSource('TestGen_Class_ClassVarRecord_UnitImpl', LinesToStr([ // statements - 'pas.UnitA.TAnt$G1.$initSpec();', + '$mod.$implcode = function () {', + ' pas.UnitA.TAnt$G1.$initSpec();', + '};', '']), LinesToStr([ // $mod.$main ''])); @@ -1453,7 +1505,6 @@ begin '}, []);'])); CheckSource('TestGen_Class_ClassVarRecord_UnitImpl', LinesToStr([ // statements - //'pas.UnitA.TAnt$G1.$initSpec();', '']), LinesToStr([ // $mod.$main ''])); @@ -1706,7 +1757,9 @@ begin ' rtl.addIntf(this, pas.system.IUnknown);', '});', 'this.i = null;', - 'pas.UnitA.TAnt$G1.$initSpec();', + '$mod.$implcode = function () {', + ' pas.UnitA.TAnt$G1.$initSpec();', + '};', '']), LinesToStr([ // $mod.$main 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.TBird.$create("Create"), pas.UnitA.TAnt$G1), true);', @@ -1898,6 +1951,77 @@ begin ''])); end; +procedure TTestGenerics.TestGen_Except; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' generic TBird<T> = class', + ' Field: T;', + ' procedure Fly;', + ' end;', + ' Exception = class', + ' end;', + ' generic EBird<T> = class(Exception)', + ' Id: T;', + ' end;', + 'var', + ' b: specialize TBird<word>;', + 'procedure TBird.Fly;', + 'begin', + ' try', + ' except', + ' on E: Exception do Fly;', + ' on EBird: specialize EBird<word> do EBird.Id:=3;', + ' else', + ' Fly;', + ' end;', + 'end;', + 'begin', + '']); + ConvertProgram; + CheckSource('TestGen_Except', + LinesToStr([ // statements + 'rtl.createClass(this, "TObject", null, function () {', + ' this.$init = function () {', + ' };', + ' this.$final = function () {', + ' };', + '});', + 'rtl.createClass(this, "Exception", this.TObject, function () {', + '});', + 'rtl.createClass(this, "TBird$G1", this.TObject, function () {', + ' this.$init = function () {', + ' $mod.TObject.$init.call(this);', + ' this.Field = 0;', + ' };', + ' this.Fly = function () {', + ' try {} catch ($e) {', + ' if ($mod.Exception.isPrototypeOf($e)) {', + ' var E = $e;', + ' this.Fly();', + ' } else if ($mod.EBird$G1.isPrototypeOf($e)) {', + ' var EBird = $e;', + ' EBird.Id = 3;', + ' } else {', + ' this.Fly();', + ' }', + ' };', + ' };', + '}, "TBird<System.Word>");', + 'this.b = null;', + 'rtl.createClass(this, "EBird$G1", this.Exception, function () {', + ' this.$init = function () {', + ' $mod.Exception.$init.call(this);', + ' this.Id = 0;', + ' };', + '}, "EBird<System.Word>");', + '']), + LinesToStr([ // $mod.$main + ''])); +end; + procedure TTestGenerics.TestGen_HelperForArray; begin StartProgram(false); @@ -2424,7 +2548,9 @@ begin '});'])); CheckSource('TestGen_Array_OtherUnit', LinesToStr([ // statements - 'pas.UnitA.$rtti["TDyn<UnitB.TAnt>"].eltype = pas.UnitB.$rtti["TAnt"];', + '$mod.$implcode = function () {', + ' pas.UnitA.$rtti["TDyn<UnitB.TAnt>"].eltype = pas.UnitB.$rtti["TAnt"];', + '};', '']), LinesToStr([ // $mod.$main ' pas.UnitB.Run();', @@ -2504,9 +2630,11 @@ begin '}, []);'])); CheckSource('TestGen_ArrayOfUnitImplRec', LinesToStr([ // statements - 'pas.UnitA.$rtti["TDyn<UnitA.TAnt>"].eltype = pas.UnitA.$rtti["TAnt"];', - 'pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];', - 'pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];', + '$mod.$implcode = function () {', + ' pas.UnitA.$rtti["TDyn<UnitA.TAnt>"].eltype = pas.UnitA.$rtti["TAnt"];', + ' pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];', + ' pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];', + '};', '']), LinesToStr([ // $mod.$main ''])); @@ -2673,7 +2801,9 @@ begin '}, []);'])); CheckSource('TestGen_Class_ClassVarRecord_UnitImpl', LinesToStr([ // statements - 'pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();', + '$mod.$implcode = function () {', + ' pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();', + '};', '']), LinesToStr([ // $mod.$main ''])); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index d3f5908660..26afc5744c 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -29256,20 +29256,20 @@ begin CheckSource('TestRTTI_ProcType', LinesToStr([ // statements 'this.$rtti.$ProcVar("TProcA", {', - ' procsig: rtl.newTIProcSig(null)', + ' procsig: rtl.newTIProcSig([])', '});', 'this.$rtti.$MethodVar("TMethodB", {', - ' procsig: rtl.newTIProcSig(null),', + ' procsig: rtl.newTIProcSig([]),', ' methodkind: 0', '});', 'this.$rtti.$ProcVar("TProcC", {', - ' procsig: rtl.newTIProcSig(null, 2)', + ' procsig: rtl.newTIProcSig([], null, 2)', '});', 'this.$rtti.$ProcVar("TProcD", {', ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])', '});', 'this.$rtti.$ProcVar("TProcE", {', - ' procsig: rtl.newTIProcSig(null, rtl.nativeint)', + ' procsig: rtl.newTIProcSig([], rtl.nativeint)', '});', 'this.$rtti.$ProcVar("TProcF", {', ' procsig: rtl.newTIProcSig([["p", this.$rtti["TProcA"], 2]], rtl.nativeuint)', @@ -29578,13 +29578,13 @@ begin ' this.Fly = function () {', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("Fly", 0, null);', + ' $r.addMethod("Fly", 0, []);', '});', 'rtl.createClass(this, "TEagle", this.TBird, function () {', ' this.Fly = function () {', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("Fly", 0, null);', + ' $r.addMethod("Fly", 0, []);', '});', '']), LinesToStr([ // $mod.$main @@ -29738,17 +29738,19 @@ procedure TTestModule.TestRTTI_Class_Method; begin WithTypeInfo:=true; StartProgram(false); - Add('type'); - Add(' TObject = class'); - Add(' private'); - Add(' procedure Internal; external name ''$intern'';'); - Add(' published'); - Add(' procedure Click; virtual; abstract;'); - Add(' procedure Notify(Sender: TObject); virtual; abstract;'); - Add(' function GetNotify: boolean; external name ''GetNotify'';'); - Add(' procedure Println(a,b: longint); varargs; virtual; abstract;'); - Add(' end;'); - Add('begin'); + Add([ + 'type', + ' TObject = class', + ' private', + ' procedure Internal; external name ''$intern'';', + ' published', + ' procedure Click; virtual; abstract;', + ' procedure Notify(Sender: TObject); virtual; abstract;', + ' function GetNotify: boolean; external name ''GetNotify'';', + ' procedure Println(a,b: longint); varargs; virtual; abstract;', + ' function Fetch(URL: string): word; async; external name ''Fetch'';', + ' end;', + 'begin']); ConvertProgram; CheckSource('TestRTTI_Class_Method', LinesToStr([ // statements @@ -29758,12 +29760,11 @@ begin ' this.$final = function () {', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("Click", 0, null);', + ' $r.addMethod("Click", 0, []);', ' $r.addMethod("Notify", 0, [["Sender", $r]]);', - ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});', - ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {', - ' flags: 2', - ' });', + ' $r.addMethod("GetNotify", 1, [], rtl.boolean, 4);', + ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, 2);', + ' $r.addMethod("Fetch", 1, [["URL", rtl.string]], rtl.word, 20);', '});', '']), LinesToStr([ // $mod.$main @@ -30507,7 +30508,7 @@ begin ' this.$final = function () {', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("DoIt", 0, null);', + ' $r.addMethod("DoIt", 0, []);', '});', 'rtl.createClass(this, "TSky", this.TObject, function () {', ' this.DoIt = function () {', @@ -30549,14 +30550,14 @@ begin ' this.DoIt = function () {', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("DoIt", 0, null);', + ' $r.addMethod("DoIt", 0, []);', '});', 'rtl.createClass(this, "TSky", this.TObject, function () {', ' this.DoIt = function () {', ' $mod.TObject.DoIt.call(this);', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("DoIt", 0, null);', + ' $r.addMethod("DoIt", 0, []);', '});', '']), LinesToStr([ // $mod.$main @@ -30633,7 +30634,7 @@ begin '});', 'this.$rtti.$Class("TBridge");', 'this.$rtti.$ProcVar("TProc", {', - ' procsig: rtl.newTIProcSig(null, this.$rtti["TBridge"])', + ' procsig: rtl.newTIProcSig([], this.$rtti["TBridge"])', '});', 'rtl.createClass(this, "TOger", this.TObject, function () {', ' this.$init = function () {', @@ -30696,7 +30697,7 @@ begin ' instancetype: this.$rtti["TObject"]', '});', 'this.$rtti.$ProcVar("TProcA", {', - ' procsig: rtl.newTIProcSig(null, this.$rtti["TClass"])', + ' procsig: rtl.newTIProcSig([], this.$rtti["TClass"])', '});', 'rtl.createClass(this, "TObject", null, function () {', ' this.$init = function () {', @@ -31169,10 +31170,10 @@ begin ' eltype: rtl.string', '});', 'this.$rtti.$ProcVar("TProc", {', - ' procsig: rtl.newTIProcSig(null)', + ' procsig: rtl.newTIProcSig([])', '});', 'this.$rtti.$MethodVar("TMethod", {', - ' procsig: rtl.newTIProcSig(null),', + ' procsig: rtl.newTIProcSig([]),', ' methodkind: 0', '});', 'this.StaticArray = rtl.arraySetLength(null,"",2);', @@ -31457,7 +31458,7 @@ begin ' null,', ' function () {', ' var $r = this.$rtti;', - ' $r.addMethod("GetItem", 1, null, rtl.longint);', + ' $r.addMethod("GetItem", 1, [], rtl.longint);', ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);', ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");', ' }', @@ -31524,8 +31525,8 @@ begin ' this.$kind = "com";', ' var $r = this.$rtti;', ' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);', - ' $r.addMethod("_AddRef", 1, null, rtl.longint);', - ' $r.addMethod("_Release", 1, null, rtl.longint);', + ' $r.addMethod("_AddRef", 1, [], rtl.longint);', + ' $r.addMethod("_Release", 1, [], rtl.longint);', ' }', ');', 'rtl.createInterface(', @@ -31536,7 +31537,7 @@ begin ' this.IUnknown,', ' function () {', ' var $r = this.$rtti;', - ' $r.addMethod("GetItem", 1, null, rtl.longint);', + ' $r.addMethod("GetItem", 1, [], rtl.longint);', ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);', ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");', ' }', @@ -31588,7 +31589,7 @@ begin ' return Result;', ' };', ' var $r = this.$rtti;', - ' $r.addMethod("GetItem", 1, null, rtl.longint);', + ' $r.addMethod("GetItem", 1, [], rtl.longint);', ' $r.addProperty("Item", 1, rtl.longint, "GetItem", "");', '});', 'this.t = null;', @@ -31676,8 +31677,8 @@ begin ' pas.system.IUnknown,', ' function () {', ' var $r = this.$rtti;', - ' $r.addMethod("Swoop", 1, null, pas.unit2.$rtti["TWordArray"]);', - ' $r.addMethod("Glide", 1, null, pas.unit2.$rtti["TArray<System.Word>"]);', + ' $r.addMethod("Swoop", 1, [], pas.unit2.$rtti["TWordArray"]);', + ' $r.addMethod("Glide", 1, [], pas.unit2.$rtti["TArray<System.Word>"]);', ' }', ');', 'this.Fly = function () {', @@ -31882,7 +31883,7 @@ begin ' attr: [$mod.TCustomAttribute, "Create$1", [14]]', ' }', ' );', - ' $r.addMethod("Fly", 0, null, null, {', + ' $r.addMethod("Fly", 0, [], null, 0, {', ' attr: [$mod.TCustomAttribute, "Create$1", [15]]', ' });', '});', |