{$mode delphi} {$codepage utf-8} {$namespace org.freepascal.test} {$j-} Unit test; interface const unitintconst = 3; unitfloatconst = 2.0; unitdoubleconst = 0.1; const tcl: longint = 4; type trec = record a,b,c,d,e: longint; end; const tcrec: trec = (a:1;b:2;c:3;d:4;e:5); type TMyClass = class const classintconst = 4; classfloatconst = 3.0; classdoubleconst = 0.3; classtcstringconst: unicodestring = 'abcdef'; class var rec: trec; var intfield: jint; staticbytefield: jbyte; static; constructor create; overload; constructor create(l: longint);overload; constructor create(l1, l2: longint);overload; function sub(a1, a2: longint): longint; function test(l1, l2: longint): longint; class function staticmul3(l: longint): longint; static; procedure longboolobj(l: jlong; b: boolean; obj: tobject); procedure setintfield(l: jint); function getintfield: jint; property propintfield: jint read getintfield write setintfield; procedure setstaticbytefield(b: byte); function getstaticbytefield: byte; class procedure setstaticbytefieldstatic(b: byte); static; class function getstaticbytefieldstatic: byte; static; class procedure settestglobal(l: longint); static; class function gettestglobal: longint; static; end; tisinterface = interface end; tisclassbase = class procedure abstr; virtual; abstract; end; tisclassbase2 = class(tisclassbase) end; tisclass1 = class(tisclassbase2) type tisclass1nested = class(tisinterface) var anonrec: record c: char; end; type tisclass1nestedl2 = class anonrec: record l: longint; end; constructor create; function testl2: jint; end; constructor create; function testl1: jint; end; constructor create; procedure abstr; override; end; tisclass1ref = class of tisclass1; type tnestrec = record r: trec; arr: array[3..4] of byte; end; const tcnestrec: tnestrec = (r:(a:1;b:2;c:3;d:4;e:5);arr:(7,6)); var anonrec: record s: string; end; function testset: jint; function testloop: longint; function testfloat: jint; function testcnvint1: longint; function testint2real: longint; function TestCmpListOneShort: longint; function TestCmpListTwoShort: longint; function TestCmpListOneWord: longint; function TestCmpListTwoWord: longint; function TestCmpListOneInt64: longint; function TestCmpListTwoInt64: longint; function TestCmpListThreeInt64: longint; function TestCmpListRangesOneShort: longint; function TestCmpListRangesTwoShort: longint; function TestCmpListRangesOneWord: longint; function TestCmpListRangesTwoWord: longint; function TestCmpListRangesThreeWord: longint; function TestCmpListRangesOneInt64: longint; function TestCmpListRangesTwoInt64: longint; function testsqr: longint; function testtrunc: longint; function testdynarr: longint; function testdynarr2: longint; function testbitcastintfloat: jint; function testis: longint; function testneg: longint; function testtry1: longint; function testtry2: longint; function testtryfinally1: longint; function testtryfinally2: longint; function testtryfinally3: longint; function testsmallarr1: longint; function testopenarr1: longint; function testopenarr2: longint; function testopenarr3: longint; function testopendynarr: longint; function testsmallarr2: longint; function testsmallarr3: longint; function testsmallarr4: longint; function testrec1: longint; function testopenarr1rec: longint; function testrec2: longint; function testunicodestring: JLString; function testunicodestring2: JLString; function testunicodestring3(a: unicodestring): unicodestring; function testunicodestring4(a: unicodestring): unicodestring; function testunicodestring5: unicodestring; function testunicodestring6: unicodestring; function testunicodestring7: unicodestring; procedure main(const args: array of string); var myrec: trec; implementation uses {$ifdef java}jdk15{$else}androidr14{$endif}; { package visibility } var testglobal: jint; var funkyl: longint; function funky: longint; begin result:=funkyl; inc(funkyl); end; function testset: jint; var s,s2: set of 0..31; c1, c2: cardinal; const exit1: jint = 1; begin result:=0; s:=[3..6]; s:=s+[10..20]; if not([3..4]<=s) then exit(exit1); s:=s-[15..20]; s2:=[15..20]; if s2<=s then exit(2); s:=s+s2; if not(s2<=s) then exit(3); if s<=s2 then exit(4); c1:=1234; c2:=c1 mod 5; if c2<>4 then exit(5); end; function testloop: longint; var i,j: longint; const exit1: jint = 1; begin result:=0; i:=0; while i<10 do i:=i+1; if i<>10 then exit(exit1); i:=0; repeat i:=i+5; until i=20; if (i<20) or (i>20) then exit(2); j:=0; for i:=1 to 10 do j:=j+i; i:=10; if (j<(i*(i+1) div 2)) or (j>(i*(i+1) div 2)) then exit(3); end; function testfloat: jint; var s1, s2: single; d1, d2: double; begin result:=0; s1:=0.5; s1:=s1+1.5; s2:=2.0; if (s1 < s2) or (s1 > s2) or (s1 <> s2) then exit(1); s1:=s1+s2; if s1<>4.0 then exit(2); s1:=s1-s2; if s1<>s2 then exit(3); s1:=s1*s2; if s1<>4.0 then exit(4); s1:=s1/s2; if s1<>s2 then exit(5); d1:=0.5; d1:=d1+1.5; d2:=2.0; if (d1 < d2) or (d1 > d2) or (d1 <> d2) then exit(6); d1:=d1+d2; if d1<>4.0 then exit(7); d1:=d1-d2; if d1<>d2 then exit(8); d1:=d1*d2; if d1<>4.0 then exit(9); d1:=d1/d2; if d1<>d2 then exit(10); end; function testcnvint1: longint; var tobyte : byte; toword : word; tolong : longint; {$ifndef tp} toint64 : int64; {$endif} b1 : boolean; bb1 : bytebool; wb1 : wordbool; lb1 : longbool; b2 : boolean; bb2 : bytebool; wb2 : wordbool; lb2 : longbool; begin result:=0; { left : LOC_REGISTER } { from : LOC_REFERENCE/LOC_REGISTER } b1 := TRUE; tobyte := byte(b1); if tobyte <> 1 then exit(1); b1 := FALSE; tobyte := byte(b1); if tobyte <> 0 then exit(2); b1 := TRUE; toword := word(b1); if toword <> 1 then exit(3); b1 := FALSE; toword := word(b1); if toword <> 0 then exit(4); b1 := TRUE; tolong := longint(b1); if tolong <> 1 then exit(5); b1 := FALSE; tolong := longint(b1); if tolong <> 0 then exit(6); bb1 := TRUE; tobyte := byte(bb1); if tobyte <> 255 then exit(7); bb1 := FALSE; tobyte := byte(bb1); if tobyte <> 0 then exit(8); bb1 := TRUE; toword := word(bb1); if toword <> 65535 then exit(9); bb1 := FALSE; toword := word(bb1); if toword <> 0 then exit(10); bb1 := TRUE; tolong := longint(bb1); if tolong <> -1 then exit(11); bb1 := FALSE; tolong := longint(bb1); if tolong <> 0 then exit(12); wb1 := TRUE; tobyte := byte(wb1); if tobyte <> 255 then exit(13); wb1 := FALSE; tobyte := byte(wb1); if tobyte <> 0 then exit(14); wb1 := TRUE; toword := word(wb1); if toword <> 65535 then exit(15); wb1 := FALSE; toword := word(wb1); if toword <> 0 then exit(16); wb1 := TRUE; tolong := longint(wb1); if tolong <> -1 then exit(17); wb1 := FALSE; tolong := longint(wb1); if tolong <> 0 then exit(18); {$ifndef tp} b1 := TRUE; toint64 :=int64(b1); if toint64 <> 1 then exit(19); b1 := FALSE; toint64 :=int64(b1); if toint64 <> 0 then exit(20); bb1 := TRUE; toint64 :=int64(bb1); if toint64 <> -1 then exit(21); bb1 := FALSE; toint64 :=int64(bb1); if toint64 <> 0 then exit(22); wb1 := TRUE; toint64 :=int64(wb1); if toint64 <> -1 then exit(23); wb1 := FALSE; toint64 :=int64(wb1); if toint64 <> 0 then exit(24); {$endif} lb1 := TRUE; tobyte := byte(lb1); if tobyte <> 255 then exit(25); lb1 := FALSE; tobyte := byte(lb1); if tobyte <> 0 then exit(26); lb1 := TRUE; toword := word(lb1); if toword <> 65535 then exit(27); lb1 := FALSE; toword := word(lb1); if toword <> 0 then exit(28); lb1 := TRUE; tolong := longint(lb1); if tolong <> -1 then exit(29); lb1 := FALSE; tolong := longint(lb1); if tolong <> 0 then exit(30); { left : LOC_REGISTER } { from : LOC_REFERENCE } wb1 := TRUE; b2 := wb1; if not b2 then exit(31); wb1 := FALSE; b2 := wb1; if b2 then exit(32); lb1 := TRUE; b2 := lb1; if not b2 then exit(33); lb1 := FALSE; b2 := lb1; if b2 then exit(34); wb1 := TRUE; bb2 := wb1; if not bb2 then exit(35); wb1 := FALSE; bb2 := wb1; if bb2 then exit(36); lb1 := TRUE; bb2 := lb1; if not bb2 then exit(37); lb1 := FALSE; bb2 := lb1; if bb2 then exit(38); b1 := TRUE; lb2 := b1; if not lb2 then exit(39); b1 := FALSE; lb2 := b1; if lb2 then exit(40); bb1 := TRUE; lb2 := bb1; if not lb2 then exit(41); bb1 := FALSE; lb2 := bb1; if lb2 then exit(42); { left : LOC_REGISTER } { from : LOC_JUMP } toword := 0; tobyte := 1; tobyte:=byte(toword > tobyte); if tobyte <> 0 then exit(43); toword := 2; tobyte := 1; tobyte:=byte(toword > tobyte); if tobyte <> 1 then exit(44); toword := 0; tobyte := 1; toword:=word(toword > tobyte); if toword <> 0 then exit(45); toword := 2; tobyte := 1; toword:=word(toword > tobyte); if toword <> 1 then exit(46); toword := 0; tobyte := 1; tolong:=longint(toword > tobyte); if tolong <> 0 then exit(47); toword := 2; tobyte := 1; tolong:=longint(toword > tobyte); if tolong <> 1 then exit(48); {$ifndef tp} toword := 0; tobyte := 1; toint64:=int64(toword > tobyte); if toint64 <> 0 then exit(49); toword := 2; tobyte := 1; toint64:=int64(toword > tobyte); if toint64 <> 1 then exit(50); {$endif} { left : LOC_REGISTER } { from : LOC_FLAGS } wb1 := TRUE; bb1 := FALSE; bb1 := (wb1 <> bb1); if not bb1 then exit(51); wb1 := FALSE; bb1 := FALSE; bb1 := (wb1 <> bb1); if bb1 then exit(52); lb1 := TRUE; bb1 := FALSE; bb1 := (bb1 = lb1); if bb1 then exit(53); lb1 := FALSE; bb1 := TRUE; bb1 := (bb1 <> lb1); if not bb1 then exit(54); lb1 := TRUE; bb1 := FALSE; wb1 := (bb1 = lb1); if wb1 then exit(55); lb1 := TRUE; bb1 := TRUE; wb1 := (bb1 = lb1); if not wb1 then exit(56); lb1 := TRUE; bb1 := FALSE; lb1 := (bb1 = lb1); if lb1 then exit(57); lb1 := FALSE; bb1 := FALSE; lb1 := (bb1 = lb1); if not lb1 then exit(58); bb1 := TRUE; bb2 := FALSE; lb1 := (bb1 <> bb2); if not lb1 then exit(59); bb1 := FALSE; bb2 := TRUE; lb1 := (bb1 = bb2); if lb1 then exit(60); end; function testint2real: longint; var l: longint; c: cardinal; i: int64; q: qword; s: single; d: double; begin result:=0; l:=-12345; c:=high(longint)+33; i:=-56789; q:=qword(high(int64))+48; s:=l; if s<>-12345 then exit(1); s:=c; if s<>high(longint)+33 then exit(2); s:=i; if s<>-56789 then exit(3); s:=q; if s<>qword(high(int64))+48 then exit(4); l:=-12345; c:=high(longint)+33; i:=-56789; q:=qword(high(int64))+48; d:=l; if d<>-12345 then exit(5); d:=c; if d<>high(longint)+33 then exit(6); d:=i; if d<>-56789 then exit(7); d:=q; if d<>qword(high(int64))+48 then exit(8); l:=123456789; c:=987654321; i:=high(cardinal)+12345; q:=12345; s:=l; if s<>123456789 then exit(11); s:=c; if s<>987654321 then exit(12); s:=i; if s<>high(cardinal)+12345 then exit(13); s:=q; if s<>12345 then exit(14); l:=123456789; c:=987654321; i:=high(cardinal)+12345; q:=12345; d:=l; if d<>123456789 then exit(16); d:=c; if d<>987654321 then exit(17); d:=i; if d<>high(cardinal)+12345 then exit(18); d:=q; if d<>12345 then exit(19); end; { low = high } function TestCmpListOneShort: longint; var s: smallint; failed :boolean; begin s := -12; failed := true; case s of -12 : failed := false; -10 : ; 3 : ; else end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListTwoShort: longint; var s: smallint; failed :boolean; begin s := 30000; failed := true; case s of -12 : ; -10 : ; 3 : ; else failed := false; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListOneWord: longint; var s: word; failed :boolean; begin s := 12; failed := true; case s of 12 : failed := false; 10 : ; 3 : ; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListTwoWord: longint; var s: word; failed :boolean; begin s := 30000; failed := true; case s of 0 : ; 512 : ; 3 : ; else failed := false; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListOneInt64: longint; var s: int64; failed :boolean; begin s := 3000000; failed := true; case s of 3000000 : failed := false; 10 : ; 3 : ; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListTwoInt64: longint; var s: int64; failed :boolean; begin s := 30000; failed := true; case s of 0 : ; 512 : ; 3 : ; else failed := false; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListThreeInt64: longint; var s: int64; l : longint; failed :boolean; begin l:=3000000; s := (int64(l) shl 32); failed := true; case s of (int64(3000000) shl 32) : failed := false; 10 : ; 3 : ; end; if failed then result:=1 else result:=0; end; function TestCmpListRangesOneShort: longint; var s: smallint; failed :boolean; begin s := -12; failed := true; case s of -12..-8 : failed := false; -7 : ; 3 : ; else end; if failed then result:=1 else result:=0; end; function TestCmpListRangesTwoShort: longint; var s: smallint; failed :boolean; begin s := 30000; failed := true; case s of -12..-8 : ; -7 : ; 3 : ; else failed := false; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListRangesOneWord: longint; var s: word; failed :boolean; begin s := 12; failed := true; case s of 12..13 : failed := false; 10 : ; 3..7 : ; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListRangesTwoWord: longint; var s: word; failed :boolean; begin s := 30000; failed := true; case s of 0..2 : ; 3..29999 : ; else failed := false; end; if failed then result:=1 else result:=0; end; function TestCmpListRangesThreeWord: longint; var s: word; failed :boolean; begin s := 3; failed := true; case s of 12..13 : ; 10 : ; 3..7 : failed := false; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListRangesOneInt64: longint; var s: int64; failed :boolean; begin s := 3000000; failed := true; case s of 11..3000000 : failed := false; 10 : ; 0..2 : ; end; if failed then result:=1 else result:=0; end; { low = high } function TestCmpListRangesTwoInt64: longint; var s: int64; failed :boolean; begin s := 30000; failed := true; case s of 513..10000 : ; 512 : ; 0..3 : ; else failed := false; end; if failed then result:=1 else result:=0; end; function testsqr: longint; var s1, s2: single; d1, d2: double; begin result:=0; s1:=25.0; s2:=sqr(s1); if s2<>625.0 then exit(1); d2:=sqr(s1); if d2<>625.0 then exit(2); d1:=7.0; d2:=sqr(d1); if d2<>49.0 then exit(3); d2:=sqr(d1); if d2<>49.0 then exit(4); end; function testtrunc: longint; var s1: single; d1: double; l: longint; i: int64; begin result:=0; s1:=123.99; l:=trunc(s1); if l<>123 then exit(1); i:=trunc(s1); if i<>123 then exit(2); d1:=67533.345923; l:=trunc(d1); if l<>67533 then exit(3); i:=trunc(d1); if i<>67533 then exit(4); end; function testdynarr: longint; type TReal1DArray = array of Double; TReal2DArray = array of array of Double; var MaxMN : Integer; PassCount : Integer; Threshold : Double; AEffective : TReal2DArray; AParam : TReal2DArray; XE : TReal1DArray; B : TReal1DArray; N : Integer; Pass : Integer; I : Integer; J : Integer; CntS : Integer; CntU : Integer; CntT : Integer; CntM : Integer; WasErrors : Boolean; IsUpper : Boolean; IsTrans : Boolean; IsUnit : Boolean; V : Double; S : Double; begin SetLength(AEffective, 2, 2); // crash occurs at this line WasErrors := False; MaxMN := 10; PassCount := 5; N:=2; isupper:=false; isunit:=true; istrans:=false; while N<=MaxMN do begin for i:=low(aeffective) to pred(length(aeffective)) do for j:=low(aeffective[i]) to pred(length(aeffective[i])) do aeffective[i,j]:=i*10+j; SetLength(AEffective, N+1, N+1); for i:=low(aeffective) to pred(length(aeffective))-1 do for j:=low(aeffective[i]) to pred(length(aeffective[i]))-1 do if aeffective[i,j]<>i*10+j then begin result:=-1; exit; end; for i:=low(aeffective) to pred(length(aeffective))-1 do if aeffective[i,pred(length(aeffective[i]))]<>0 then begin result:=-2; exit; end; Inc(N); end; { check shallow copy } AParam:=aeffective; aeffective[1,1]:=123; if AParam[1,1]<>123 then exit(-3); result:=0; end; function testdynarr2: longint; type tstaticarr = array[0..1] of longint; tstaticarr2 = array[0..1] of array of array of longint; var a,b: array of array of tstaticarr; c,d: tstaticarr2; w: word; arrb: array of byte; arrc: array of char; arrw: array of word; arrwc: array of unicodechar; arrd: array of dword; arrq: array of qword; arra: array of ansistring; arrs: array of shortstring; begin setlength(a,2,2); a[0,0,0]:=1; b:=a; a[0,0,1]:=1; funkyl:=1; setlength(a[funky],35); if b[0,0,0]<>1 then exit(1); if b[0,0,1]<>1 then exit(2); if length(b[1])<>35 then exit(3); setlength(c[0],2,2); d:=c; c[0,0,0]:=1; setlength(c[1],42); if d[0,0,0]<>1 then exit(4); if length(d[1])<>0 then exit(5); b[1,0,0]:=555; a:=copy(b,1,1); if length(a)<>1 then exit(6); if a[0,0,0]<>555 then exit(7); setlength(arrb,4); if length(arrb)<>4 then exit(8); for w:=low(arrb) to high(arrb) do if arrb[w]<>0 then exit(9); setlength(arrc,32); if length(arrc)<>32 then exit(10); for w:=low(arrc) to high(arrc) do if arrc[w]<>#0 then exit(11); setlength(arrw,666); if length(arrw)<>666 then exit(11); for w:=low(arrw) to high(arrw) do if arrw[w]<>0 then exit(12); setlength(arrwc,12346); if length(arrwc)<>12346 then exit(13); for w:=low(arrwc) to high(arrwc) do if arrwc[w]<>#0 then exit(14); setlength(arrd,20000); if length(arrd)<>20000 then exit(15); for w:=low(arrd) to high(arrd) do if arrd[w]<>0 then exit(16); setlength(arrq,21532); if length(arrq)<>21532 then exit(17); for w:=low(arrq) to high(arrq) do if arrq[w]<>0 then exit(18); setlength(arra,21533); if length(arra)<>21533 then exit(19); for w:=low(arra) to high(arra) do if arra[w]<>'' then exit(20); setlength(arrs,21534); if length(arrs)<>21534 then exit(21); for w:=low(arrs) to high(arrs) do if arrs[w]<>'' then exit(12); result:=0; end; function testbitcastintfloat: jint; var f: jfloat; d: jdouble; i: jint; l: jlong; begin result:=-1; f:=123.125; i:=jint(f); f:=1.0; f:=jfloat(i); if f<>1123434496.0 then exit; result:=-2; d:=9876.0625; l:=jlong(d); d:=1.0; d:=jdouble(l); if d<>4666655037106159616 then exit; result:=0; end; { ********************** Is test ******************** } type tisclass2 = class(tisclass1) constructor create; end; constructor tisclass1.create; begin end; constructor tisclass1.tisclass1nested.create; begin anonrec.c:='x'; end; function tisclass1.tisclass1nested.testl1: jint; begin if anonrec.c='x' then result:=12345 else result:=-1; end; constructor tisclass1.tisclass1nested.tisclass1nestedl2.create; begin anonrec.l:=961; end; function tisclass1.tisclass1nested.tisclass1nestedl2.testl2: jint; begin if anonrec.l=961 then result:=42 else result:=-1; end; procedure tisclass1.abstr; begin end; constructor tisclass2.create; begin end; function testispara(cref: tisclass1ref): longint; begin if cref<>tisclass2 then result:=14; result:=0; end; function testis: longint; var myclass1 : tisclass1; myclass2 : tisclass2; nested1 : tisclass1.tisclass1nested; nested2 : tisclass1.tisclass1nested.tisclass1nestedl2; myclassref : tisclass1ref; begin { create class instance } myclass1:=tisclass1.create; myclass2:=tisclass2.create; {if myclass1 is tisclass1 } if not(myclass1 is tisclass1) then exit(1); if (myclass1 is tisclass2) then exit(2); if not (myclass2 is tisclass2) then exit(3); if (myclass1 is tisclass2) then exit(4); nested1:=tisclass1.tisclass1nested.create; nested2:=tisclass1.tisclass1nested.tisclass1nestedl2.create; if not(nested1 is tisclass1.tisclass1nested) then exit(5); if nested1.testl1<>12345 then exit(6); if not(nested2 is tisclass2.tisclass1nested.tisclass1nestedl2) then exit(7); if nested2.testl2<>42 then exit(8); {$ifndef oldcomp} myclassref:=tisclass1; if not(myclass1 is myclassref) then exit(10); if not(myclass2 is myclassref) then exit(11); myclassref:=tisclass2; if (myclass1 is myclassref) then exit(12); if not(myclass2 is myclassref) then exit(13); myclass1:=myclass2; myclass1.abstr; myclass2:=tisclass2(myclass1 as myclassref); result:=testispara(tisclass2); if result<>0 then exit(14); if not(nested1 is tisinterface) then exit(15); if nested2 is tisinterface then exit(16); {$endif} result:=0; end; function testneg: longint; var b: shortint; l: longint; i: int64; s: single; d: double; begin b:=1; b:=-b; if b<>-1 then exit(1); l:=-1234567; l:=-l; if l<>1234567 then exit(2); i:=-123456789012345; i:=-i; if i<>123456789012345 then exit(3); s:=123.5; s:=-s; if s<>-123.5 then exit(4); d:=-4567.78; d:=-d; if d<>4567.78 then exit(5); result:=0; end; { ******************** End Is test ****************** } { ****************** Exception test ***************** } function testtry1: longint; begin result:=-1; try raise JLException.create; except result:=0; end; end; function testtry2: longint; begin result:=-1; try raise JLException.create; except on JLException do result:=0; else result:=-2 end; if result<>0 then exit; result:=-3; try try raise JLException.create; except result:=-4; raise end; except on JLException do if result=-4 then result:=0; end; end; function testtryfinally1: longint; begin result:=-1; try try try raise JLException.create; except on JLException do begin result:=1; raise; end else result:=-2 end; finally if result=1 then result:=0; end; except on JLException do if result<>0 then raise end; end; function testtryfinally2: longint; var i,j: longint; check1, check2: byte; begin j:=0; check1:=0; check2:=0; result:=-1; try for i:=1 to 10 do try inc(j); if j=1 then begin inc(check1); continue; end; if j=2 then begin inc(check2); break; end; finally if j=1 then inc(check1); if j=2 then inc(check2); end; finally if check1<>2 then result:=-1 else if check2<>2 then result:=-2 else if j<>2 then result:=-3 else result:=0; end; end; function testtryfinally3: longint; var i,j: longint; check1, check2: byte; begin j:=0; check1:=0; check2:=0; result:=-1; try for i:=1 to 10 do try inc(j); if j=1 then begin inc(check1); continue; end; if j=2 then begin inc(check2); exit; end; finally if j=1 then inc(check1); if j=2 then inc(check2); end; finally if check1<>2 then result:=-10 else if check2<>2 then result:=-20 else if j<>2 then result:=-30 else result:=0; end; end; { **************** End Exception test *************** } { **************** Begin array test *************** } function testsmallarr1: longint; type tarr = array[4..6] of longint; var a1,a2: tarr; a3,a4: array[1..2,3..5] of tarr; i,j,k: longint; begin a1[4]:=1; a1[5]:=2; a1[6]:=3; { plain copy } a2:=a1; if (a2[4]<>1) or (a2[5]<>2) or (a2[6]<>3) then exit(1); { has to be deep copy } a1[5]:=255; if a2[5]<>2 then exit(2); { copy to multi-dim array } a3[1,4]:=a1; if (a3[1,4,4]<>1) or (a3[1,4,5]<>255) or (a3[1,4,6]<>3) then exit(3); i:=2; j:=3; a1[4]:=38; a1[5]:=39; a1[6]:=40; { copy to multi-dim array } a3[i,j]:=a1; if (a3[i,j,4]<>38) or (a3[i,j,5]<>39) or (a3[i,j,6]<>40) then exit(4); { copy multi-dim array to multi-dim array } a4:=a3; { check for deep copy } for i:=low(a3) to high(a3) do for j:=low(a3[i]) to high(a3[i]) do for k:=low(a3[i,j]) to high(a3[i,j]) do a3[i,j,k]:=-1; if (a4[1,4,4]<>1) or (a4[1,4,5]<>255) or (a4[1,4,6]<>3) then exit(5); i:=2; j:=3; if (a4[i,j,4]<>38) or (a4[i,j,5]<>39) or (a4[i,j,6]<>40) then exit(6); result:=0; end; function testopenarrval(a1: longint; arr: array of jfloat; a2: longint): longint; var i: longint; begin result:=a1+length(arr)+trunc(arr[high(arr)])+a2; for i:=low(arr) to high(arr) do arr[i]:=1.0; end; function testopenarrconst(a1: longint; const arr: array of jfloat; a2: longint): longint; begin result:=a1+length(arr)+trunc(arr[high(arr)])+a2; end; function testopenarrvar(a1: longint; var arr: array of jfloat; a2: longint): longint; begin result:=a1+length(arr)+trunc(arr[high(arr)])+a2; arr[0]:=3.0; end; function testopenarr1: longint; var arr: array[4..10] of jfloat; i: longint; begin result:=0; arr[10]:=2.0; if testopenarrval(1,arr,3)<>13 then exit(1); for i:=4 to 9 do if arr[i]<>0.0 then exit(2); if arr[10]<>2.0 then exit(3); if testopenarrconst(2,arr,4)<>15 then exit(4); if testopenarrvar(3,arr,5)<>17 then exit(5); if arr[4]<>3.0 then exit(6); end; type tarrdynarr = array[1..10,1..4] of array of array of byte; function testoutopenarrdyn(out arr: array of tarrdynarr): longint; var i, j, k: longint; begin for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do for k:=low(arr[i][j]) to high(arr[i][j]) do begin if length(arr[i][j,k])<>0 then exit(-1); setlength(arr[i][j,k],j,k); end; result:=0; end; function testopenarr2: longint; var arr: array[20..30] of tarrdynarr; dynarr: array of tarrdynarr; i,j,k: longint; barr, barr2: array of byte; rarr: array of trec; rarr2: array of array of trec; begin setlength(barr,4); barr[1]:=4; if barr[1]<>4 then exit(-40); barr2:=copy(barr); if barr2[1]<>4 then exit(-50); barr2[2]:=48; if barr[2]=48 then exit(-60); setlength(rarr,5); rarr[4].a:=135; if rarr[4].a<>135 then exit(-70); setlength(rarr2,4,5); rarr2[3,4].b:=124; if rarr2[3,4].b<>124 then exit(-80); for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do for k:=low(arr[i][j]) to high(arr[i][j]) do begin setlength(arr[i][j,k],20,20); end; result:=testoutopenarrdyn(arr); if result<>0 then exit; for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do for k:=low(arr[i][j]) to high(arr[i][j]) do begin if (length(arr[i][j,k])<>j) then exit(-2); if (length(arr[i][j,k][0])<>k) then exit(-3); if (length(arr[i][j,k][j-1])<>k) then exit(-4); end; setlength(dynarr,31); result:=testoutopenarrdyn(dynarr); for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do for k:=low(arr[i][j]) to high(arr[i][j]) do begin if (length(arr[i][j,k])<>j) then exit(-5); if (length(arr[i][j,k][0])<>k) then exit(-6); if (length(arr[i][j,k][j-1])<>k) then exit(-7); end; end; function testopenarr3: longint; var arr: array[4..10] of jfloat; i: longint; begin result:=0; arr[10]:=2.0; if testopenarrval(1,[1.0,2.0,3.0,4.0,5.0,6.0,2.0],3)<>13 then exit(1); if testopenarrconst(2,[1.0,2.0,3.0,4.0,5.0,6.0,7.0],4)<>20 then exit(2); end; type ByteArray = array of byte; procedure FillChar(var X: Array of Byte; Count: integer; Value: byte; FirstIndex: integer); var i: integer; y: bytearray; begin for i := FirstIndex to (FirstIndex + Count) - 1 do X[i] := Value; end; function Err : ByteArray; begin SetLength(Result, 10); FillChar(Result, Length(Result)-2, 1, 2); // !!!! end; function testopendynarr: longint; var x: bytearray; i: longint; begin x:=err; for i:=0 to 1 do if x[i]<>0 then exit(1); for i:=2 to high(x) do if x[i]<>1 then exit(2); result:=0; end; type tdoublearray10 = array[1..10] of jdouble; function testarrval(arr: tdoublearray10): double; var i: longint; begin result:=0.0; for i:=low(arr) to high(arr) do begin result:=result+arr[i]; arr[i]:=-1.0; end; end; function testsmallarr2: longint; var arr: tdoublearray10; i: longint; barr1,barr2: array[1..2] of byte; begin result:=0; for i:=low(arr) to high(arr) do arr[i]:=i; if testarrval(arr)<>(10*11 div 2) then exit(1); for i:=low(arr) to high(arr) do if arr[i]<>i then exit(2); barr1[1]:=1; barr1[2]:=2; barr2:=barr1; if barr2[1]<>1 then exit(3); if barr2[2]<>2 then exit(4); end; type tsmall2darr = array[1..10,5..9] of longint; function smallarr2dfunc: tsmall2darr; var i, j: longint; begin for i:=low(result) to high(result) do for j:=low(result[i]) to high(result[i]) do result[i,j]:=i*(high(result[i])-low(result[i])+1)+(j-low(result[i])); end; function testsmallarr3: longint; var a: tsmall2darr; begin a:=smallarr2dfunc; if a[1,5]<>5 then exit(1); if a[2,9]<>14 then exit(2); result:=0; end; function testoutarrdyn(out arr: tarrdynarr): longint; var i, j: longint; begin for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do begin if length(arr[i,j])<>0 then exit(-1); setlength(arr[i,j],i,j); end; result:=0; end; function testsmallarr4: longint; var arr: tarrdynarr; i,j: longint; begin for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do begin setlength(arr[i,j],20,20); end; result:=testoutarrdyn(arr); if result<>0 then exit; for i:=low(arr) to high(arr) do for j:=low(arr[i]) to high(arr[i]) do begin if (length(arr[i,j])<>i) then exit(-2); if (length(arr[i,j][0])<>j) then exit(-3); if (length(arr[i,j][i-1])<>j) then exit(-4); end; end; function testrec1: longint; var r1, r2: trec; begin r1.a:=1; r1.b:=2; r1.c:=3; r1.d:=4; r1.e:=5; if r1.a<>1 then exit(1); if r1.b<>2 then exit(2); if r1.c<>3 then exit(3); if r1.d<>4 then exit(4); if r1.e<>5 then exit(5); r2:=r1; if r2.a<>1 then exit(6); if r2.b<>2 then exit(7); if r2.c<>3 then exit(8); if r2.d<>4 then exit(9); if r2.e<>5 then exit(10); r2.a:=10; if r1.a<>1 then exit(11); result:=0; end; function testrec2: longint; var r1, r2: tnestrec; begin r1:=tcnestrec; r1.r.a:=1; r1.r.b:=2; r1.r.c:=3; r1.r.d:=4; r1.r.e:=5; r1.arr[4]:=6; if r1.r.a<>1 then exit(1); if r1.r.b<>2 then exit(2); if r1.r.c<>3 then exit(3); if r1.r.d<>4 then exit(4); if r1.r.e<>5 then exit(5); if r1.arr[4]<>6 then exit(12); r2:=r1; if r2.r.a<>1 then exit(6); if r2.r.b<>2 then exit(7); if r2.r.c<>3 then exit(8); if r2.r.d<>4 then exit(9); if r2.r.e<>5 then exit(10); if r1.arr[4]<>6 then exit(13); r2.r.a:=10; r2.arr[4]:=7; if r1.r.a<>1 then exit(11); if r1.arr[4]<>6 then exit(14); anonrec.s:='abcdef'; if anonrec.s<>'abcdef' then exit(15); result:=0; end; function testopenarrvalrec(a1: longint; arr: array of trec; a2: longint): longint; var i: longint; begin result:=a1+length(arr)+arr[high(arr)].a+a2; for i:=low(arr) to high(arr) do arr[i].a:=123; end; function testopenarrconstrec(a1: longint; const arr: array of trec; a2: longint): longint; begin result:=a1+length(arr)+arr[high(arr)].b+a2; end; function testopenarrvarrec(a1: longint; var arr: array of trec; a2: longint): longint; begin result:=a1+length(arr)+arr[high(arr)].c+a2; arr[0].d:=987; end; function testopenarr1rec: longint; var arr: array[4..10] of trec; i: longint; begin result:=0; arr[10].a:=2; arr[10].b:=2; arr[10].c:=2; arr[10].d:=2; arr[10].e:=2; if testopenarrvalrec(1,arr,3)<>13 then exit(1); for i:=4 to 9 do if arr[i].a<>0.0 then exit(2); if arr[10].a<>2.0 then exit(3); if testopenarrconstrec(2,arr,4)<>15 then exit(4); if testopenarrvarrec(3,arr,5)<>17 then exit(5); if arr[4].d<>987 then exit(6); end; function testunicodestring: JLString; var s1, s2: unicodestring; sarr: array[0..0] of unicodestring; begin s1:='abc'; sarr[0]:=s1; funkyl:=0; if length(sarr[funky])<>3 then begin result:=''; exit; end; s2:=s1; s2:='~ê∂êºîƒ~©¬'; result:=s2; end; function testunicodestring2: JLString; begin result:='\'#13#10'"'; end; function testunicodestring3(a: unicodestring): unicodestring; begin result:=a+'def'; end; function testunicodestring4(a: unicodestring): unicodestring; begin // JLSystem.fout.println(JLString('in testunicodestring4')); // JLSystem.fout.println(JLString(a)); result:=a; // JLSystem.fout.println(JLString(result)); result[2]:='x'; // JLSystem.fout.println(JLString(result)); result[3]:='2'; // JLSystem.fout.println(JLString(result)); end; function testunicodestring5: unicodestring; var arr: array[0..3] of ansichar; arr2: array[1..5] of ansichar; c: ansichar; wc: widechar; begin arr:='abc'#0; arr2:='defgh'; c:='i'; wc:='j'; result:=arr+arr2; result:=copy(result,1,length(result))+c; result:=result+wc; end; function testunicodestring6: unicodestring; const tcstr: string = 'ab'; var arr: array[0..3] of widechar; arr2: array[1..5] of widechar; swap: ansichar; wc: widechar; i: longint; begin arr:='ab'; arr2:='cdefg'; swap:='h'; wc:='i'; result:=arr+arr2+swap; result:=result+wc; end; function testunicodestring7: unicodestring; const tcstr: string = 'ab'; var arr: array[0..3] of unicodechar; arr2: array[1..5] of unicodechar; c: ansichar = 'h'; wc: unicodechar; begin funkyl:=1; arr:=tcstr; arr2:='cdefg'; wc:='i'; result:=arr+arr2; result:=result+c; result:=result+wc; result[funky]:='x'; end; { **************** End array test *************** } constructor TMyClass.create; begin end; constructor TMyClass.create(l: longint); var dummy: TMyClass; begin dummy:=TMyClass.create; create(l,l); end; constructor TMyClass.create(l1,l2: longint); begin inherited create; propintfield:=4; if propintfield<>4 then jlsystem.fout.println('WRONG!!!!!!!!!!!!!!!!!!!'); end; function TMyClass.sub(a1, a2: longint): longint; begin result:=a1-a2; end; function TMyClass.test(l1, l2: longint): longint; var locall: longint; localsub: TMyClass; begin localsub:=TMyClass.create(1245); locall:=localsub.sub(l1,l2); result:=locall+1; if result>4 then result:=-1; end; class function tmyclass.staticmul3(l: longint): longint; static; begin result:=l*3; end; procedure tmyclass.longboolobj(l: jlong; b: boolean; obj: tobject); begin l:=5; b:=true; obj:=nil; end; procedure tmyclass.setintfield(l: jint); const xxx: longint = 4; begin intfield:=l; longboolobj(xxx,true,self); end; function tmyclass.getintfield: jint; begin result:=intfield; end; procedure tmyclass.setstaticbytefield(b: byte); begin staticbytefield:=b; myrec.a:=b; end; function tmyclass.getstaticbytefield: byte; begin result:=staticbytefield; end; class procedure tmyclass.setstaticbytefieldstatic(b: byte); begin staticbytefield:=b; end; class function tmyclass.getstaticbytefieldstatic: byte; begin result:=staticbytefield; end; class procedure tmyclass.settestglobal(l: longint); begin testglobal:=l; end; class function tmyclass.gettestglobal: longint; begin result:=testglobal; end; procedure main(const args: array of string); begin JLSystem.fout.println('This is the entry point'); end; begin myrec.b:=1234; TMyClass.rec.c:=5678; end.